3
# Creates automatically generated files (ByteCode, Splats) from descriptions
5
# This file is part of CLC-INTERCAL
7
# Copyright (c) 2006 Claudio Calvelli, all rights reserved.
9
# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
10
# and distribute it is granted provided that the conditions set out in the
11
# licence agreement are met. See files README and COPYING in the distribution.
13
# Usage: Generate [INPUT [OUTPUT]]
15
# INPUT (or standard input) can contain the following commands to generate
16
# data-dependent lines:
19
# loads filename as a data SPEC (see below)
21
# (prefix)@@FILL GROUP PRE FIELD POST SIZE SEP@@(suffix)
22
# fills a line with as many elements from GROUP as possible, then repeats
23
# with another line until all elements of GROUP have been listed; each
24
# element will be taken from the given FIELD and the line lenght will
25
# not exceed SIZE. (prefix) and (suffix) are added at the start and
26
# the end of each line generated; PRE and POST are added before and
27
# after each element; SEP is added between elements in the same line.
28
# The data is sorted by the given FIELD. For example:
29
# [@@FILL SPLATS 'SP_' NAME '' 76 '/'@@]
31
# [SP_BCMATCH/SP_CHARSET/SP_CIRCULAR/SP_COMMENT/SP_CREATION/SP_DIGITS]
32
# [SP_INVALID/SP_IOTYPE/SP_JUNK/SP_NONUMBER/SP_NOSUCHCHAR/SP_ROMAN/SP_SPOTS]
33
# [SP_THREESPOT/SP_TODO]
35
# (prefix)@@ALL GROUP FIELD@@(suffix)
36
# generates as many lines as there are elements of GROUP; each line is
37
# generated by replacing any @@FIELD@@ in (prefix) and (suffix) with
38
# the corresponding data, and replacing the @@ALL...@@ with the
39
# value of FIELD. The data is sorted by the FIELD. For example:
40
# [@@NUMBER@@ SP_@@ALL SPLATS NAME@@]
45
# to insert a literal whirlpool where this can cause confusion use
46
# @@WHIRLPOOL@@. Note that if your GROUP has a field named WHIRLPOOL
47
# this will not be accessible.
49
# @@MULTI GROUP FIELD@@
52
# is a multiline version of @@ALL...@@: produces a block for each
53
# element of group, sorted by FIELD, in which each line of (content)
54
# is subject to the same substitution rules as @@ALL@@. Does not
55
# automatically insert the FIELD in the output, use @@FIELD@@ for
56
# that. A special syntax @@FIELD SIZE@@ allows to "fold" FIELD:
57
# for a multiline field containing blank lines, each block is
60
# SPEC contains data specification in the form:
61
# @GROUP NAME FIELD...
65
# Each FIELD definition has the form NAME=TYPE where TYPE is m (multiline),
66
# 'd' (digits), 's' (string), 'w' (word) or '@TYPE' (array - cannot be
67
# used for multiline).
69
# Each line of DATA is one record followed by the contents of a multiline
70
# field, if present; alternatively the special line @SOURCE GROUP will
71
# include the whole of another group. The contents of the multiline field
72
# must be more indented than the record they refer to and than the record
73
# that follows, for example:
79
# if a line in a multiline field starts with # it will be interpreted as
80
# a comment and ignored; if it starts with @ it will be interpreted as
81
# an escape (e.g. @END). These can be escaped with a backslash, which
82
# will be removed from the beginning of line. Note that backslashes
83
# anywhere else in the multiline fields are not touched.
84
# All lines in a multiline field will be joined together, separated by
85
# a single space (the above sequence produces "multiline 1 multiline 2
86
# multiline 3"), except a blank line which produces a double newline
95
@ARGV >= 0 && @ARGV <= 2 or die "Usage: $0 PREFIX SUFFIX [INPUT [OUTPUT]]";
96
my ($input, $output) = @ARGV;
98
my $data_dir = $Bin . '/';
99
my $data_suffix = '.Data';
103
# translate INPUT into OUTPUT
104
@ARGV = defined $input ? ($input) : ();
105
if (defined $output) {
106
open(STDOUT, '>', $output)
107
or die "$output: $!";
111
if (/^\s*\@\@DATA\s+(.*?)\@\@$/) {
112
load_spec(File::Spec->catfile($data_dir, $1 . $data_suffix));
115
if (s/^(.*)\@\@FILL\s*//) {
117
my $group = get_field($orig, \$_, 'w');
118
exists $groups{$group}
119
or die "Unknown group $group";
120
my $gp = $groups{$group};
121
my $item_pre = get_field($orig, \$_, 's');
122
my $item_name = get_field($orig, \$_, 'w');
123
exists $gp->{fpos}{$item_name}
124
or die "Unknown field $item_name in group $group";
125
my $item_pos = $gp->{fpos}{$item_name};
126
my $item_post = get_field($orig, \$_, 's');
127
my $line_size = get_field($orig, \$_, 'd');
128
my $item_sep = get_field($orig, \$_, 's');
129
s/^\@\@// or die "Missing \@\@ after \@\@FILL";
131
my @il = map { $_->[$item_pos] } @{$gp->{data}};
132
@il = sort_items(@il);
133
my $line = $line_pre;
136
$nl .= $item_sep if $nl ne $line_pre;
137
$nl .= $item_pre . $item . $item_post;
138
if (sizeof($nl . $line_post) > $line_size) {
139
print $line, $line_post if $line ne $line_pre;
140
$nl = $line_pre . $item_pre . $item . $item_post;
144
print $line, $line_post if $line ne $line_pre;
147
if (s/^(.*)\@\@ALL\s*//) {
149
my $group = get_field($orig, \$_, 'w');
150
exists $groups{$group}
151
or die "Unknown group $group";
152
my $gp = $groups{$group};
153
my $item_name = get_field($orig, \$_, 'w');
154
exists $gp->{fpos}{$item_name}
155
or die "Unknown field $item_name in group $group";
156
my $item_pos = $gp->{fpos}{$item_name};
157
s/^\@\@// or die "Missing \@\@ after \@\@ALL";
159
my @il = map { $_->[$item_pos] } @{$gp->{data}};
160
@il = sort_items(@il);
162
check_escapes($gp, $p, $line_pre);
163
check_escapes($gp, $p, $line_post);
165
for my $item (@{$gp->{data}}) {
166
next if $item->[$item_pos] ne $il;
168
for my $ol ($line_pre, $line_post) {
171
while ($line =~ s/^(.*?)\@\@//) {
173
$line =~ s/^(.*?)\@\@//
174
or die "Missing \@\@ closing $line";
176
my $quote = $gn =~ s/^(['"]?)(\w+)\1$/$2/ ? $1 : '';
178
if ($gn eq 'WHIRLPOOL') {
180
} elsif ($gn =~ /^(.*?):(\w+)$/) {
181
$f = $item->[$p->{$1}];
182
my @a = @{$item->[$p->{$2}]};
183
$f =~ s/%/shift @a || '???'/ge;
185
$f = $item->[$p->{$gn}];
187
$f =~ s/([\\$quote])/\\$1/g if $quote ne '';
190
push @line, $trans . $line;
192
print $line[0], $il, $line[1];
197
if (s/^\s*\@\@MULTI\s*//) {
198
my $group = get_field($orig, \$_, 'w');
199
exists $groups{$group}
200
or die "Unknown group $group";
201
my $gp = $groups{$group};
202
my $item_name = get_field($orig, \$_, 'w');
203
exists $gp->{fpos}{$item_name}
204
or die "Unknown field $item_name in group $group";
205
my $item_pos = $gp->{fpos}{$item_name};
206
s/^\@\@\s*$// or die "Missing \@\@ after \@\@MULTI";
207
my @il = map { $_->[$item_pos] } @{$gp->{data}};
208
@il = sort_items(@il);
213
if (/^\s*\@\@MULTI\@\@\s*$/) {
218
check_escapes($gp, $p, $_);
220
$found or die "Missing \@\@MULTI\@\@";
222
for my $item (@{$gp->{data}}) {
223
next if $item->[$item_pos] ne $il;
224
print translate_escapes($gp, $p, $item, $_) for @line;
231
die "Invalid \@\@-escape: $_";
239
my ($orig, $line, $type) = @_;
240
if ($type =~ s/^\@//) {
242
or die "Invalid array: missing [";
244
while ($$line ne '' && $$line !~ s/^\]\s*//) {
245
push @data, get_field($orig, $line, $type);
250
$$line =~ s/^0x([[:xdigit:]]+)\s*//
252
$$line =~ s/^(\d+)\s*//
254
die "Invalid number: $_";
257
$$line =~ s/^(\w+)\s*//
258
or die "Invalid symbol: $_";
262
if ($$line =~ s/^(['"])//) {
266
while ($$line =~ s/^(.*?)([$quote\\])//) {
268
last if $2 eq $quote;
269
die "Invalid data: \\ at end of line" if $$line eq '';
270
$data .= substr($$line, 0, 1, '');
276
$$line =~ s/^(\S+)\s*//
277
or die "Invalid string: $_";
281
die "Internal error: type is '$type'";
288
my $x = substr($s, 0, 1, '');
290
$l = 8 * (1 + int($l / 8));
300
return $a <=> $b if $a =~ /^\d+$/ && $b =~ /^\d+$/;
301
return -1 if $a =~ /^\d+$/;
302
return 1 if $b =~ /^\d+$/;
309
# we are trying to append $b's data to $a...
311
for my $n (@{$b->{fnames}}) {
312
# $a must have this field
313
return () if ! exists $a->{fpos}{$n};
314
# the fields must have the same type
315
return () if $a->{ftypes}{$n} ne $b->{ftypes}{$n};
316
my $p = $a->{fpos}{$n};
323
my ($gp, $p, $line) = @_;
324
while ($line =~ s/^.*?\@\@//) {
325
$line =~ s/^(.*?)\@\@//
326
or die "Missing \@\@ closing $line";
329
next if $gn eq 'WHIRLPOOL';
331
if ($gn =~ s/^(\w+):(\w+)\s*//) {
335
or die "Invalid field name $2";
336
substr($gp->{ftypes}{$2}, 0, 1) eq '@'
337
or die "Field $2 is not an array";
338
my $mapfrom = get_field($ogn, \$next, 's');
339
my $prefix = get_field($ogn, \$next, 's');
340
my $suffix = get_field($ogn, \$next, 's');
342
$gn =~ s/^(['"])(.*)\1$/$2/;
344
or die "Invalid field name $gn";
348
sub translate_escapes {
349
my ($gp, $p, $item, $line) = @_;
351
while ($line =~ s/^(.*?)\@\@//) {
353
$line =~ s/^(.*?)\@\@//;
355
if ($gn eq 'WHIRLPOOL') {
359
my $fold = $gn =~ s/\s+(\d+)$// ? $1 : undef;
360
my ($mapfrom, $prefix, $suffix, $mapto);
362
if ($gn =~ s/^(\w+):(\w+)\s*//) {
366
$mapfrom = get_field($ogn, \$next, 's');
367
$prefix = get_field($ogn, \$next, 's');
368
$suffix = get_field($ogn, \$next, 's');
370
my $quote = $gn =~ s/^(['"]?)(\w+)\1$/$2/ ? $1 : '';
371
my $f = $item->[$p->{$gn}];
372
if (defined $mapto) {
373
my @a = @{$item->[$p->{$mapto}]};
374
$f =~ s/$mapfrom/$prefix . (shift @a || '???'). $suffix/ge;
379
for my $o (split(/\n\n/, $u)) {
380
while (sizeof($o) > $fold) {
382
while ($o =~ s/^(\S*)(\s+)//) {
383
my ($n, $s) = ($1, $2);
384
if (sizeof($g . $n) > $fold) {
397
$f =~ s/([\\$quote])/\\$1/g if $quote ne '';
406
open(DATASPEC, '<', $dataspec)
407
or die "$0: $dataspec: $!";
408
print STDERR " ($dataspec)\n";
409
my $in_group = undef;
410
my $item_indent = undef;
411
my $last_multi = undef;
415
last if /^\s*\@\__END__/;
420
my $bl = $blank_line;
422
if (defined $in_group) {
423
if (s/^\s*\@END\s*//) {
424
die "group $in_group->{name} ended by \@END $_"
425
if $in_group->{name} ne $_;
426
if ($in_group->{has_m}) {
427
$_->[-1] = ${$_->[-1]} for @{$in_group->{data}};
432
if (s/^\s*\@SOURCE\s+//) {
433
push @{$in_group->{sources}}, $_;
436
die "$0: Invalid \@ escape ($_)" if /^\s*\@/;
437
my $indent = s/^([ \t]+)// ? sizeof($1) : 0;
438
if ($in_group->{has_m} &&
439
defined $item_indent &&
440
$item_indent < $indent)
444
$$last_multi .= "\n\n" if $bl;
445
} elsif ($$last_multi ne '') {
450
$item_indent = $indent;
453
for my $fname (@{$in_group->{fnames}}) {
454
my $ftype = $in_group->{ftypes}{$fname};
455
next if $ftype eq 'm';
456
push @line, get_field($_, \$_, $ftype);
458
die "Extra data at end of line ($_)" if $_ ne '';
459
if ($in_group->{has_m}) {
462
push @line, $last_multi;
464
push @{$in_group->{data}}, \@line;
466
} elsif (s/^\s*\@GROUP\s+//) {
467
my ($group, @fspec) = split;
468
die "$0: duplicate group $group" if exists $groups{$group};
469
die "$0: group $group has no fields!" unless @fspec;
474
for my $fs (@fspec) {
475
$fs =~ /^(\w+)=(.*)$/ or die "Invalid field definition ($fs)";
476
my ($name, $type) = ($1, lc($2));
477
exists $ftypes{$type} and die "Duplicate field name ($name)";
478
$type =~ /^(?:\@*[dws]|m)$/ or die "Invalid field type ($fs)";
479
die "Sorry, multiline fields must be last" if $has_m;
480
$has_m = 1 if $type eq 'm';
481
$fpos{$name} = scalar @fnames;
483
$ftypes{$name} = $type;
494
$groups{$group} = $in_group;
496
die "Invalid line ($_)";
502
for my $g (values %groups) {
503
for my $s (@{$g->{sources}}) {
504
$s ne $g && exists $groups{$s}
505
or die "Invalid source $s for $g->{name}";
508
and die "Sourcing from a group containing sources ($s) not implemented";
509
my @map = field_map($g, $d)
510
or die "$g->{name} cannot source from $s: incompatible fields";
511
for my $d (@{$d->{data}}) {
512
push @{$g->{data}}, [map { $d->[$_] } @map];
added
removed
Generate/Generate
