d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Initial revision

Browse source
This commit is contained in:
ceriel 1988-10-04 10:33:39 +00:00
parent 17e980aa15
commit 23a7e7b427
11 changed files with 2195 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
lang/a68s/.distr Normal file
View file

@ -0,0 +1,8 @@
COPYRIGHT
README
a68s.1
aem
cpem
liba68s
test
util

10
lang/a68s/COPYRIGHT Normal file
View file

@ -0,0 +1,10 @@
The material in this directory (with the exception of util.xref) is
copyright 1988 by
Dr C. H. Lindsey
Dept. of Computer Science
University of Manchester
MANCHESTER M13 9PL
United Kingdom.
tel. 061-275 6120
uucp chl@ux.cs.man.ac.uk

67
lang/a68s/README Normal file
View file

@ -0,0 +1,67 @@
The ALGOL 68S System
********************
1. See a68s.1 in -man format for the goodies on offer.
2. This system is presently exceeding slow (but correct). The reason is that
it calls run-time routines to do absolutely everything. It is known that
significant improvement can easily be made in this state of affairs, but not
in this release.
3. Other developments expected for the future are facilities for separate and
mixed-language compilation (a student will tackle this next year), and a
non-checking run time option which will run faster (but with less security)
(but no student available for this yet).
4. The system should run on any 44 or 24 system, but not on a 22 system as yet
(that is another development in the waiting). It has actually been tested on
sun3, moon3 and vax4.
5. The system was originally delevoped for CDC machines, and then for PERQs
running under PNX. Thus its method of compilation is not particularly suited
to the ACK way of thinking (a compiler designed with ACK in mind from the
start would have been very different). The CDC origin explains why all the
sources are in upper case, and with numbered lines (however, I like numbered
lines, so I have kept them, and a68s will even accept them still).
6. Version control is by a program /util/tailor, which selectively exposes or
hides commented out sections of the sources according to a recipe. See the
start of aem/a68sdec.p for what all the tailoring parameters mean. Every
source text is passed through tailor before being compiled.
7. The system is written in a bastardized version of PASCAL called cpem (see
README in the directory of that name). {This also provides an "improved" method
of separate compilation which might be of benefit in pem.}
8. The directories aem and liba68s have their own private versions of 'make'
(therefore, '.' must precede '/bin' in your PATH). These prepare the tailoring
recipes according to the system given in ack_sys (set environment variable
MACH to override this). Unlike pem, separate versions of the compiler must
exist to generate 44 and 24 (and eventually 22) code. To avoid keeping too
many .o files around, the Makefile will do a clean before changing from a 44
system to a 24 one, etc.
9. Although a runtime library can be made using 'make' in liba68s, this is
really intended for debugging libraries. A more usual system would be to use
the 'compmodule' system in the liba68s directory of the appropriate mach.
However, it is recommended that this be not included automatically in the
'action' of each mach, because compiling an ALGOL 68S library takes over a
hour on a microvax, and to do it for all of the 'mach's provided would use up
a lot of time.
10. To build the complete system requires
make install in util
make all in cpem
make install in aem
make install in EM/mach/???/liba68s
11. The programs test/test.8 and test/tp8.8 are the main confidence-checkers.
test.8 produces lots of numbers, with clear error messages interspersed if
anything goes wrong. Its last few lines should contain 5 '.'s, followed by
4'.'s and so on down to 0. There is one test needs commenting out if floating
point is not available. tp8.8 is the transput test. It should print out a long
string in vertical columns spread over two pages. After that, if it says "FYLA
read back OK" it should be all right. tp9.8 is the same thing for systems
without floating point. The other programs in the test directory are just
interesting examples, which should work.

418
lang/a68s/a68s.1 Normal file
View file

@ -0,0 +1,418 @@
.TH A68S 1 "Version 2.2a Jul 15 1987"
.SH NAME
a68s, indent68 \- ALGOL 68S compiler
.SH SYNOPSIS
.B a68s
.IR arguments
.PP
.BR ack (etc)
.IR arguments
.PP
.B indent68
.IR filename
.SH DESCRIPTION
ALGOL68S source files should have the extension `.8'.
.LP
.I a68s
accepts the same flags and conventions as
.I ack
(q.v.). Thus 'a68s -o
.I prog
.IR prog .8'
will compile the source in file
.IR prog .8,
producing executable binary in
.IR prog
and a program listing in
.IR prog .8.lst.
.IP
WARNING. Although the
.I ack
system will have produced the usual intermediate files with suffices .k, .m and .o
(and you may even stop the compilation at these intermediate stages if you wish),
do not try to include other files (whether ending in .8 or in .anything else)
as the present compiler has no facilities for separate or
mixed-language compilation. Hopefully, this will be rectified some day.
.IP
If the source file starts with a digit, it will be assumed that every line
starts with a line number (but the sequencing is not checked). These line
numbers will then appear on the .lst file,
and will be used in diagnostic messages.
.LP
`indent68'
will read the given
.IR filename
which is expected to be an ALGOL 68 program.
A correctly indented form of the same program is sent to the standard output.
Note that, unlike more elaborate prettyprinters, it confines itself to
inserting or removing blanks at the beginnings of lines (although it does
insist upon a space after each
.BR go-on-symbol
.RI ( ; )
and after a starting
.BR brief-comment-symbol
.RI ( # ).
It is particularly intended for indenting programs that place their
.BR go-on-symbols
at the start of the line (i.e. before the next
.BR statement
rather than after the last one), but it will produce an acceptable
indentation of any program.
.SH LANGUAGE
The language implemented is the official sublanguage of ALGOL 68 (usually
known as ALGOL 68S), as defined in [1] (see also Appendix 4 of [2]). The only
features of ALGOL 68S not implemented are binary transput and
.IR "stand back channel" .
On the other hand, in addition to the official features of ALGOL 68S, the
.B heap-generator
(but not the
.BR sample-heap-generator )
is implemented. WARNING. The garbage collector is of the "access count"
variety, and it will therefore not collect circular lists which may become
inaccessible (however, circular lists constructed from
.BR local-generators
are collected correctly on range exit).
.PP
The hardware representation is the official one ([3]), except for the absence
of reserved-word stropping.
.PP
The principal limitations with respect to full ALGOL 68 are therefore as
follows.
.TP
1.
All defining occurences must precede their applied occurrences (except for
.BR labels ).
.TP
2.
No
.IR UNION s
or
.BR conformity-clauses
or
.IR EMPTY .
.TP
3.
No
.IR FLEX
(but
.IR STRING
is OK) and no
.BR vacuums .
.TP
4.
Structures may not contain arrays, and
.B 'row-of-row-of'
modes are not permitted (as opposed to
.B 'row-row-of'
modes which are OK).
.TP
5.
No
.BR parallel-clauses
or
.BR void-collateral-clauses
(but
.BR displays
are OK).
.TP
6.
No formatted transput.
.TP
7.
.IR GOTO
(or
.IR GO
.IR TO )
may not be omitted in a
.BR jump .
.TP
8.
No procedured jumps.
.TP
9.
Existing
.BR operators
(notably the
.BR standard-prelude
ones) may not be redefined (nor may their priorities be altered).
.TP
10.
Restricted
.BR standard-prelude .
The following is a complete list of the standard
.BR indicators
available.
.IP
.IR "maxint, maxreal, smallreal, pi, maxabschar"
.br
.IR "sqrt, exp, ln, nextrandom, random"
.br
.IR "cos, arccos, sin, arcsin, tan, arctan"
.br
.IR "bitspack, bytespack"
.br
.IR "standin channel, standout channel, "
.IR "standin, standout"
.br
.IR "open, establish, associate, close"
.br
.IR "put, print, write, get, read"
.br
.IR "space, newline, newpage, set, reset"
.br
.IR "on logical file end, "
.IR "on physical file end, on page end"
.br
.IR "on line end, maketerm"
.br
.IR "chan, char number, line number, page number"
.br
.IR "whole, fixed, float"
.br
.IR "stop"
.br
.IR "REPR, BIN, ENTIER, ROUND, ODD, SIGN, ABS, "
.IR "LWB, UPB"
.br
.IR "RE, IM, ARG, CONJ"
.br
.IR "NOT, AND, OR, OVER, MOD, SHL, SHR, I"
.br
.IR "+ , - , * , / , % , %* , ^ , ** , +*"
.br
.IR "EQ, NE, GE, GT, LE, LT"
.br
.IR "= , /= , >= , > , <= , <"
.br
.IR "PLUSAB, MINUSAB, TIMESAB, DIVAB, OVERAB, "
.IR "MODAB, PLUSTO"
.br
.IR "+:= , -:= , *:= , /:= , %:= , %*:= , +=:"
.PP
.SH PRAGMATS
The following
.BR pragmats
are provided:
.PD 0
.IP
.TP 17
.IR "PR UPPER PR"
(enable upper-case stropping)
.TP
.IR "PR POINT PR"
(disable upper-case stropping)
.br
Note that point stropping always works (with either case of word).
The essential difference with upper-case stropping is that upper-case words are
assumed to be stropped whether a point is present or not. Thus it is always
possible to write
.IR ".PR UPPER .PR" ,
which will be recognised whatever the previous stropping regime.
.TP
.IR "PR LIST PR"
(turn listing on)
.TP
.IR "PR NOLIST PR"
(turn listing off)
.br
listings are sent to the .lst file.
.TP
.IR "PR PAGE PR"
(start a new page on the .lst file)
.TP
.IR "PR WARN PR"
(include compile-time warning messages)
.TP
.IR "PR NOWARN PR"
(omit compile-time warning messages)
.PD
.PP
The words within a
.BR pragmat
may be in either upper or lower case, and one
.BR pragmat
may contain several such words, separated by commas, as in the following
example which shows the default states.
.IP
.IR "PR UPPER, LIST, WARN PR"
.SH DIAGNOSTICS
The compile-time error messages are self-explanatory.
They can be divided into 3 categories:
.RS
.br
Lexcical errors (the offending lexeme is simply ignored)
.br
Syntactic errors (text up to the next
.RI ' ; '
or
.RI ' ) ',
etc. is ignored)
.br
Semantic errors.
.RE
.br
After the first syntactic error, further checking for semantic errors is
inhibited.
.LP
On the .lst file,
a row of "=" indicates parts of the text that have been ignored.
A "1" under a particular symbol indicates the point where an error was detected
(a "2" indicates that 2 errors were found there). An "S" ("C", "P") is printed
in the margin wherever a new line of source text starts within a
.BR string-denotation
.RB ( comment ,
.BR pragmat ).
Thus mismatched delimiters for these things will readily stand out.
.LP
A run-time error message is followed by a print out of the stack, giving the
line number in each active procedure. For each procedure, the active
.BR ranges
are printed, starting from the innermost and finishing with the outermost.
Within each range, the values ascribed to all identifiers and operators
(apart from some manifest values) are listed in the order in which they were
declared in the
.BR range .
Names are printed as a "#" followed by a number. Not much significance should
be attached to these numbers except to note that the same name will always be
printed as the same number. At the end of each range, the value of any active
loop counter
.RI ( .FOR )
together with its increment and target
.RI ( .BY
and
.IR .TO )
will be printed.
.SH ENVIRONMENT ENQUIRIES
The following figures apply primarily to machines with a wordsize of 32 bits.
Figures for 16-bit machines are given in parentheses where appropriate.
.DS
.IP
.IR "max int"
= 2147483647 (32767)
.br
.IR "max real"
= 1.701411733192600E+38 (on the VAX)
.br
.IR "small real"
= 3.469446951953614E-18 (on the VAX)
.br
.IR "bits width"
= 32 (16)
.br
.IR "bytes width"
= 4 (2)
.br
.IR "max abs char"
= 127
.br
.IR "null character"
= NULL
.RI ( REPR(0) )
.br
.IR "int lengths" ,
.IR "int shorths" ,
.IR "real lengths" ,
.IR "real shorths" ,
.br
.IR "bits lengths" ,
.IR "bits shorths" ,
.br
.IR "bytes lengths" ,
.IR "bytes shorths"
.br
all = 1
.br
.IR "int width"
= 10 (5)
.br
.IR "real width"
= 16
.br
.IR "exp width"
= 3
.br
.IR "error character"
= *
.br
.IR "flip"
= T
.br
.IR "flop"
= F
.br
On
.IR "stand in channel" :
.RS
.br
.RS
.IR "get possible" ,
.IR "reset possible"
.RE
.br
On
.IR "stand out channel" :
.br
.RS
.IR "put possible" ,
.IR "reset possible" ,
.IR "compressible" ,
.br
.IR "estab possible"
.RE
.br
On associated files:
.br
.RS
.IR "get possible" ,
.IR "put possiblle" ,
.IR "set possible" ,
.br
.IR "reset possible"
.DE
.SH FILES
.ta \w'/EMDISTR/lib/a68/a68s.out 'u
.PD 0
~em/bin/a68s
.br
~em/bin/indent68
.br
~em/lib/em_a68s?? - the compiler
.br
~em/lib/em_a68s_init?? - compiler initialization
.br
~em/mach/lib/MACH/tail_a68s - runtime library
.br
~em/lang/a68s/a68s.1 - this manual
.SH BUGS
There is no
.IR REAL
arithmetic on the SUNs.
.LP
Excessive static nesting (especially with
.IR ELIF s
or
.IR CASE s
with many alternatives) can exceed certain stack spaces in the compiler.
.LP
Dimensions of arrays are limited to 8.
.LP
.SH SEE ALSO
.TP
ack(I)
.SH REFERENCES
.TP
[1]
P. G. Hibbard,
.IR "A Sublanguage of ALGOL 68" ,
SIGPLAN Notices Vol. 12, No. 5, May 1977.
.TP
[2]
C. H. Lindsey and S. G. van der Meulen,
.IR "Informal Introduction to ALGOL 68" ,
North Holland.
.TP
[3]
Wilfred J. Hansen and Hendrik Boom,
.IR "The Report on the Standard Hardware"
.IR "Representation for ALGOL 68" ,
SIGPLAN Notices Vol. 12, No. 5, May 1977.

6
lang/a68s/util/.distr Normal file
View file

@ -0,0 +1,6 @@
Makefile
checkseq.p
indent.p
reseq.p
tailor.p
xref.c

36
lang/a68s/util/Makefile Normal file
View file

@ -0,0 +1,36 @@
EM=../../..
h=$EM/h
APC=apc
ACC=acc
all: tailor xref checkseq reseq indent68
install: all
cp indent68 $(EM)/bin/indent68
cmp: all
tailor: tailor.p
$(APC) -o tailor tailor.p
indent68: indent.p
$(APC) -o indent68 indent.p
xref: xref.c
cc -o xref xref.c
checkseq: checkseq.p
$(APC) -o checkseq checkseq.p
reseq: reseq.p
$(APC) -o reseq reseq.p
clean:
-rm -f *.o indent68
pr:
@pr tailor.p xref.c checkseq.p reseq.p indent.p
opr:
make pr ^ opr

34
lang/a68s/util/checkseq.p Normal file
View file

@ -0,0 +1,34 @@
program checkseq(output);
(* Rewritten to allow a list of files to be passed in on the command line *)
(* This version : 24 August 1987 by Jon Abbott *)
type buf = packed array [1..20] of char;
string = ^buf;
var
this, last, nargs: integer;
s: string;
inf: text;
function argc: integer; extern;
function argv(i: integer): string; extern;
procedure popen(var f: text; s: string); extern;
begin
nargs := argc;
while nargs>1 do
begin
nargs := nargs-1;
s := argv(nargs);
popen(inf,s);
writeln('checkseq: ',s^);
this := 0;
while not eof(inf) do
begin
last := this;
readln(inf,this);
if this <= last then writeln(last, this)
end
end
end.

428
lang/a68s/util/indent.p Normal file
View file

@ -0,0 +1,428 @@
(*$R-,L-*)
PROGRAM INDENT(SOURCE, INPUT, OUTPUT);
CONST
SMALLINDENT=2; MIDINDENT=2; LARGEINDENT=4;
TYPE
STATETYPE =
(OPENER, MIDDLER, CLOSER, PRAGMENT, DOER, QUOTE, COLON, GO, STROP, OTHER);
CLAUSETYPE =
(BRIEF, CONDCL, CASECL, CLOSEDCL, LOOPCL, INDEXER, ROUTINE, JUMP,
EXIT, SEMICOMMA, STRING, HASH, CO, COMMENT, PR, PRAGMAT, UPPER, POINT, ANY);
TREEP=^TREE;
TREE=RECORD
(*TREE TO HOLD RESERVED WORD DICTIONARY*)
C: CHAR;
LEFT, RIGHT, NEXT: TREEP;
TIP: BOOLEAN;
ST: STATETYPE; CL: CLAUSETYPE;
END;
STACKP=^STACK;
STACK=PACKED RECORD
C: CLAUSETYPE; G: BOOLEAN;
NEXT: STACKP
END;
ALFA=PACKED ARRAY [1..10] OF CHAR;
VAR
SOURCE: TEXT;
ROOT: TREEP;
TOS: STACKP;
VETTEDCHARACTER: RECORD
WORD: PACKED ARRAY [1..80] OF CHAR; (*THE LONGEST CONCEIVABLE BOLDWORD!*)
INDEX: 0..80;
END;
STARTOFLINE,
LINENUMBERS: BOOLEAN; (*TRUE IFF THE SOURCE TEXT INCLUDES LINE NUMBERS*)
I: INTEGER;
INDENT, (*EXPECTED INDENT FOR SUBSEQUENT LINES*)
TEMPINDENT: INTEGER; (*INDENT FOR CURRENT LINE*)
INSTRAGMENT: BOOLEAN;
STROPSTATE: (INPOINT, INUPPER, INPRAGP, INPRAGUP);
GONEON: BOOLEAN; (*TRUE IFF THE LAST TOKEN WAS AN OPENER OR A MIDDLER*)
(**)
(**)
(**)
PROCEDURE SETUPTREE;
(*TO CREATE THE DICTIONARY*)
PROCEDURE INSERT(WORD: ALFA; S: STATETYPE; B: CLAUSETYPE);
VAR TREEPTR: TREEP; INDEX: INTEGER; FOUND: BOOLEAN;
BEGIN TREEPTR := ROOT; INDEX := 1;
WHILE WORD[INDEX]<>' ' DO
BEGIN
WITH TREEPTR^ DO
BEGIN
IF TREEPTR^.NEXT=NIL THEN
BEGIN NEW(NEXT); WITH NEXT^ DO
BEGIN C := WORD[INDEX];
LEFT := NIL; RIGHT := NIL; TIP := FALSE; NEXT := NIL
END
END;
TREEPTR := NEXT
END;
FOUND := FALSE;
WHILE NOT FOUND DO WITH TREEPTR^ DO
IF WORD[INDEX]<C THEN
BEGIN
IF LEFT=NIL THEN
BEGIN NEW(LEFT); WITH LEFT^ DO
BEGIN C := WORD[INDEX];
LEFT := NIL; RIGHT := NIL; TIP := FALSE; NEXT := NIL
END;
FOUND := TRUE
END;
TREEPTR := LEFT
END
ELSE IF WORD[INDEX]>C THEN
BEGIN
IF RIGHT=NIL THEN
BEGIN NEW(RIGHT); WITH RIGHT^ DO
BEGIN C := WORD[INDEX];
LEFT := NIL; RIGHT := NIL; TIP := FALSE; NEXT := NIL
END;
FOUND := TRUE
END;
TREEPTR := RIGHT
END
ELSE FOUND := TRUE;
INDEX := INDEX+1
END;
WITH TREEPTR^ DO
BEGIN TIP := TRUE; ST := S; CL := B END
END (*INSERT*);
(**)
BEGIN (*SETUPTREE*)
NEW(ROOT); ROOT^.NEXT := NIL;
INSERT('( ', OPENER , BRIEF );
INSERT('IF ', OPENER , CONDCL );
INSERT('if ', OPENER , CONDCL );
INSERT('CASE ', OPENER , CASECL );
INSERT('case ', OPENER , CASECL );
INSERT('BEGIN ', OPENER , CLOSEDCL );
INSERT('begin ', OPENER , CLOSEDCL );
INSERT('[ ', OPENER , INDEXER );
INSERT('! ', MIDDLER , BRIEF );
INSERT('THEN ', MIDDLER , CONDCL );
INSERT('then ', MIDDLER , CONDCL );
INSERT('IN ', MIDDLER , CASECL );
INSERT('in ', MIDDLER , CASECL );
INSERT('ELIF ', MIDDLER , CONDCL );
INSERT('elif ', MIDDLER , CONDCL );
INSERT('ELSE ', MIDDLER , CONDCL );
INSERT('else ', MIDDLER , CONDCL );
INSERT('OUSE ', MIDDLER , CASECL );
INSERT('ouse ', MIDDLER , CASECL );
INSERT('OUT ', MIDDLER , CASECL );
INSERT('out ', MIDDLER , CASECL );
INSERT('EXIT ', MIDDLER , EXIT );
INSERT('exit ', MIDDLER , EXIT );
INSERT('; ', MIDDLER , SEMICOMMA);
INSERT(', ', MIDDLER , SEMICOMMA);
INSERT(') ', CLOSER , BRIEF );
INSERT('FI ', CLOSER , CONDCL );
INSERT('fi ', CLOSER , CONDCL );
INSERT('ESAC ', CLOSER , CASECL );
INSERT('esac ', CLOSER , CASECL );
INSERT('END ', CLOSER , CLOSEDCL );
INSERT('end ', CLOSER , CLOSEDCL );
INSERT('] ', CLOSER , INDEXER );
INSERT('# ', PRAGMENT, HASH );
INSERT('CO ', PRAGMENT, CO );
INSERT('co ', PRAGMENT, CO );
INSERT('COMMENT ', PRAGMENT, COMMENT );
INSERT('comment ', PRAGMENT, COMMENT );
INSERT('PR ', PRAGMENT, PR );
INSERT('pr ', PRAGMENT, PR );
INSERT('PRAGMAT ', PRAGMENT, PRAGMAT );
INSERT('pragmat ', PRAGMENT, PRAGMAT );
INSERT('FOR ', DOER , LOOPCL );
INSERT('for ', DOER , LOOPCL );
INSERT('FROM ', DOER , LOOPCL );
INSERT('from ', DOER , LOOPCL );
INSERT('BY ', DOER , LOOPCL );
INSERT('by ', DOER , LOOPCL );
INSERT('TO ', DOER , LOOPCL );
INSERT('to ', DOER , LOOPCL );
INSERT('WHILE ', DOER , LOOPCL );
INSERT('while ', DOER , LOOPCL );
INSERT('DO ', DOER , LOOPCL );
INSERT('do ', DOER , LOOPCL );
INSERT('OD ', CLOSER , LOOPCL );
INSERT('od ', CLOSER , LOOPCL );
INSERT('GO ', GO , JUMP );
INSERT('go ', GO , JUMP );
INSERT('" ', QUOTE , STRING );
INSERT('UPPER ', STROP , UPPER );
INSERT('upper ', STROP , UPPER );
INSERT('POINT ', STROP , POINT );
INSERT('point ', STROP , POINT );
(*':' AFTER BOLD , COLON , ROUTINE ); *)
END;
(**)
(**)
PROCEDURE PUSH(CL: CLAUSETYPE);
VAR TEMP: STACKP;
BEGIN TEMP := TOS; NEW(TOS); WITH TOS^ DO
BEGIN C := CL; G := GONEON; NEXT := TEMP END
END;
(**)
(**)
PROCEDURE POP;
VAR TEMP: STACKP;
BEGIN
IF NOT GONEON AND NOT INSTRAGMENT THEN INDENT := INDENT-MIDINDENT;
TEMP := TOS; GONEON := TOS^.G; TOS := TOS^.NEXT; DISPOSE(TEMP)
END;
(**)
(**)
PROCEDURE VET(VAR SOURCE: TEXT);
(*MOVES NEXT INTERESTING TOKEN TO VETTED CHARACTER,
AND SETS INDENT AND TEMPINDENT ACCORDINGLY*)
VAR TREEPTR: TREEP;
CH: CHAR;
STATE: STATETYPE;
CLAUSE: CLAUSETYPE;
BOLD, FOUND: BOOLEAN;
(**)
PROCEDURE GAP(VAR SOURCE: TEXT);
(*ENSURE THAT AT LEAST (SMALLINDENT-1) BLANKS ARE PRESENT IN OUTPUT*)
VAR I: INTEGER;
BEGIN
I := SMALLINDENT-1;
WHILE NOT EOLN(SOURCE) AND (SOURCE^=' ') AND (I>0) DO
BEGIN GET(SOURCE); I := I-1 END;
IF NOT EOLN(SOURCE) THEN
FOR I := 2 TO SMALLINDENT DO WITH VETTEDCHARACTER DO
BEGIN WORD[I] := ' '; INDEX := I END
END;
(**)
PROCEDURE CHECK(CLAUSE: CLAUSETYPE);
BEGIN WITH TOS^ DO
IF C<>CLAUSE THEN (*ATTEMPT TO FIX BRACKETS MISMATCH*)
IF NEXT^.C=CLAUSE THEN (*ASSUME CLOSER WAS OMITTED*)
BEGIN
IF C IN [BRIEF, INDEXER] THEN INDENT := INDENT-SMALLINDENT
ELSE INDENT := INDENT-LARGEINDENT;
POP;
IF GONEON THEN
BEGIN GONEON := FALSE; INDENT := INDENT+MIDINDENT END
END
ELSE (*ASSUME OPENER WAS OMITTED*)
BEGIN
IF CLAUSE IN [BRIEF, INDEXER] THEN INDENT := INDENT+SMALLINDENT
ELSE INDENT := INDENT+LARGEINDENT;
IF NOT GONEON THEN
BEGIN GONEON := TRUE; INDENT := INDENT-MIDINDENT END;
PUSH(CLAUSE)
END
END;
(**)
BEGIN (*VET*)
(*ASSERT: (SOURCE^ IN [(!)[],.#";]) OR (UPPER & SOURCE^ IN [A..Z]) OR INPRAGMAT*)
CH := SOURCE^;
TEMPINDENT := INDENT;
VETTEDCHARACTER.INDEX := 0;
CASE STROPSTATE OF
INPOINT: BOLD := CH='.';
INUPPER: BOLD := CH IN ['.','A'..'Z'];
INPRAGUP,INPRAGP: BOLD := CH IN ['.','A'..'Z','a'..'z'];
END;
IF CH='.' THEN WITH VETTEDCHARACTER DO
BEGIN INDEX := 1; WORD[1] := '.'; GET(SOURCE); CH := SOURCE^ END;
TREEPTR := ROOT^.NEXT; FOUND := FALSE;
WHILE (TREEPTR<>NIL) AND NOT FOUND DO WITH TREEPTR^ DO
IF C=CH THEN WITH VETTEDCHARACTER DO
BEGIN
INDEX := INDEX+1; WORD[INDEX] := CH;
GET(SOURCE); CH := SOURCE^;
IF BOLD THEN
CASE STROPSTATE OF
INPRAGUP,INPRAGP,INPOINT: FOUND := NOT(CH IN ['A'..'Z', 'a'..'z']) AND TIP;
INUPPER: FOUND := NOT(CH IN ['A'..'Z']) AND TIP;
END
ELSE FOUND := TIP;
IF NOT FOUND THEN TREEPTR := NEXT
END
ELSE IF CH<C THEN TREEPTR := LEFT
ELSE TREEPTR := RIGHT;
IF FOUND THEN WITH TREEPTR^ DO
BEGIN STATE := ST; CLAUSE := CL END
ELSE WITH VETTEDCHARACTER DO
BEGIN
IF BOLD THEN
WHILE (CH IN ['A'..'Z', 'a'..'z']) DO
(*ABSORB REMAINDER OF UNRECOGNIZED BOLDWORD*)
BEGIN INDEX := INDEX+1; WORD[INDEX] := CH; GET(SOURCE); CH := SOURCE^ END
ELSE
BEGIN INDEX := INDEX+1; WORD[INDEX] := CH; GET(SOURCE); CH := SOURCE^ END;
IF (CH=':') AND NOT INSTRAGMENT THEN WITH VETTEDCHARACTER DO
(*START OF ROUTINE-TEXT*)
BEGIN STATE := COLON; CLAUSE := ROUTINE;
INDEX := INDEX+1; WORD[INDEX] := CH; GET(SOURCE)
END
ELSE BEGIN STATE := OTHER; CLAUSE := ANY END
END;
(**)
IF INSTRAGMENT THEN
IF (CLAUSE=TOS^.C) THEN
(*MATCHING CLOSE-STRAGMENT-TOKEN FOUND*)
BEGIN
IF STROPSTATE IN [INPRAGUP,INPRAGP] THEN
STROPSTATE := PRED(PRED(STROPSTATE));
POP;
INSTRAGMENT := FALSE;
IF CLAUSE=HASH THEN INDENT := INDENT-SMALLINDENT
ELSE IF CLAUSE<>STRING THEN INDENT := INDENT-LARGEINDENT;
TEMPINDENT := INDENT
END
ELSE IF (STROPSTATE IN [INPRAGUP,INPRAGP]) AND (STATE=STROP) THEN
IF CLAUSE=UPPER THEN STROPSTATE := INPRAGUP ELSE STROPSTATE := INPRAGP
ELSE (*NO ACTION*)
ELSE (*NOT INSTRAGMENT*)
BEGIN
IF STATE IN [MIDDLER, CLOSER] THEN (*MAYBE END OF ROUTINE-TEXT*)
WHILE TOS^.C=ROUTINE DO
BEGIN
POP; INDENT := INDENT-SMALLINDENT;
IF GONEON THEN
BEGIN GONEON := FALSE; INDENT := INDENT+MIDINDENT END
END;
(**)
IF STATE=GO THEN (*.GO OF .GO .TO*)
BEGIN PUSH(JUMP); STATE := OTHER END
ELSE IF STATE=DOER THEN (*CHANGE IT TO MIDDLER OR OPENER*)
IF TOS^.C=JUMP THEN (*.TO OF .GO .TO*)
BEGIN POP; STATE := OTHER END
ELSE IF (TOS^.C=LOOPCL) AND NOT GONEON THEN STATE := MIDDLER
ELSE STATE := OPENER;
(**)
IF STATE=COLON THEN (*START OF ROUTINE-TEXT*)
BEGIN
IF NOT GONEON THEN
BEGIN GONEON := TRUE; INDENT := INDENT-MIDINDENT END;
PUSH(CLAUSE);
INDENT := INDENT+SMALLINDENT
END
ELSE IF STATE=OPENER THEN (*START OF A NEW INDENT*)
BEGIN
PUSH(CLAUSE);
IF CLAUSE IN [BRIEF, INDEXER] THEN
BEGIN INDENT := INDENT+SMALLINDENT; IF STARTOFLINE THEN GAP(SOURCE) END
ELSE INDENT := INDENT+LARGEINDENT;
GONEON := TRUE
END
ELSE IF STATE=MIDDLER THEN
BEGIN
IF NOT (CLAUSE IN [EXIT, SEMICOMMA]) THEN CHECK(CLAUSE);
IF NOT GONEON THEN
BEGIN GONEON := TRUE; INDENT := INDENT-MIDINDENT END;
IF CLAUSE=SEMICOMMA THEN
BEGIN TEMPINDENT := INDENT-SMALLINDENT; GAP(SOURCE) END
ELSE IF TOS^.C=BRIEF THEN
(* ! OR !: OR .EXIT AFTER ( *)
BEGIN TEMPINDENT := INDENT-SMALLINDENT;
IF STARTOFLINE AND (SOURCE^<>':') AND (CLAUSE<>EXIT) THEN GAP(SOURCE)
END
ELSE TEMPINDENT := INDENT-LARGEINDENT
END
ELSE IF STATE=CLOSER THEN (*END OF INDENT*)
BEGIN
CHECK(CLAUSE); POP;
IF CLAUSE IN [BRIEF, INDEXER] THEN INDENT := INDENT-SMALLINDENT
ELSE INDENT := INDENT-LARGEINDENT;
TEMPINDENT := INDENT;
IF GONEON THEN
BEGIN GONEON := FALSE; INDENT := INDENT+MIDINDENT END
END
ELSE IF STATE=PRAGMENT THEN
BEGIN
TEMPINDENT := INDENT;
PUSH(CLAUSE);
INSTRAGMENT := TRUE;
IF CLAUSE IN [PR,PRAGMAT] THEN
STROPSTATE := SUCC(SUCC(STROPSTATE));
IF CLAUSE=HASH THEN
BEGIN INDENT := INDENT+SMALLINDENT; IF STARTOFLINE THEN GAP(SOURCE) END
ELSE INDENT := INDENT+LARGEINDENT
END
ELSE IF STATE=QUOTE THEN
BEGIN
IF GONEON THEN
BEGIN GONEON := FALSE; INDENT := INDENT+MIDINDENT END;
PUSH(STRING);
INSTRAGMENT := TRUE
END
ELSE (*STATE=OTHER*)
IF GONEON THEN
BEGIN GONEON := FALSE; INDENT := INDENT+MIDINDENT END
END
END (*OF VET*);
(**)
(**)
PROCEDURE MAIN(VAR SOURCE: TEXT);
VAR I: INTEGER;
BEGIN
INDENT := 0; INSTRAGMENT := FALSE;
STROPSTATE := INUPPER; (*THE DEFAULT is UPPER*)
GONEON := TRUE;
SETUPTREE;
LINENUMBERS := SOURCE^ IN ['0'..'9'];
TOS := NIL; PUSH(ANY); PUSH(ANY);
WHILE NOT EOF(SOURCE) DO
BEGIN
WHILE EOLN(SOURCE) DO BEGIN GET(SOURCE); WRITELN(OUTPUT) END;
BEGIN
STARTOFLINE := TRUE;
IF LINENUMBERS THEN
BEGIN
WHILE SOURCE^ IN ['0'..'9'] DO
BEGIN WRITE(OUTPUT, SOURCE^); GET(SOURCE) END;
IF NOT EOLN(SOURCE) AND (SOURCE^=' ') THEN (*FIRST BLANK AFTER LINE NUMBER IS OBLIGATORY*)
BEGIN WRITE(OUTPUT, ' '); GET(SOURCE) END
END;
IF TOS^.C=STRING THEN
(*DO NOT TINKER WITH BLANKS INSIDE STRING-DENOTATIONS*)
BEGIN
WHILE NOT EOLN(SOURCE) AND (SOURCE^=' ') DO
BEGIN WRITE(OUTPUT, ' '); GET(SOURCE) END;
STARTOFLINE := FALSE
END
ELSE WHILE NOT EOLN(SOURCE) AND (SOURCE^=' ') DO
GET(SOURCE); (*GET RID OF EXISTING INDENTATION*)
WHILE NOT EOLN(SOURCE) DO
BEGIN
IF (SOURCE^ IN ['(','!',')','[',']',',','.','#','"',';']) OR
((STROPSTATE<>INPOINT) AND (SOURCE^ IN ['A'..'Z'])) OR
(STROPSTATE IN [INPRAGUP,INPRAGP]) THEN
(*CHARACTER WHICH MIGHT AFFECT INDENTATION*)
BEGIN
VET(SOURCE);
IF STARTOFLINE THEN FOR I := 1 TO TEMPINDENT DO WRITE(OUTPUT, ' ');
WITH VETTEDCHARACTER DO
FOR I := 1 TO INDEX DO WRITE(OUTPUT, WORD[I])
END
ELSE
BEGIN
IF STARTOFLINE THEN FOR I := 1 TO INDENT DO WRITE(OUTPUT, ' ');
IF (SOURCE^<>' ') AND NOT INSTRAGMENT AND GONEON THEN
(*PREPARE TO INDENT ANY CONTINUATION LINE*)
BEGIN GONEON := FALSE; INDENT := INDENT+MIDINDENT END;
WRITE(OUTPUT, SOURCE^); GET(SOURCE);
END;
STARTOFLINE := FALSE
END;
GET(SOURCE); WRITELN(OUTPUT)
END;
END;
END;
(**)
FUNCTION ARGC: INTEGER; EXTERN;
(**)
BEGIN (*INDENT*)
IF ARGC=1 THEN
MAIN(INPUT)
ELSE
BEGIN
RESET(SOURCE);
MAIN(SOURCE);
END;
(*$G-*)
END.

80
lang/a68s/util/reseq.p Normal file
View file

@ -0,0 +1,80 @@
(* reseq.p *)
(* ******* *)
(* A program to renumber a text file. To use this utility type :
reseq <file1 >file2 start step
to create file2 as a renumbered version of file1, starting
with line number start, with increments of step.
NOTE : file1 and file2 had better be different !!! *)
(* Version 1.1 written Friday 31 July 1987 by Jon Abbott. *)
program reseq(input,output);
type buf = packed array [1..10] of char;
string = ^ buf;
var c : char;
start,step,i : integer;
numbered : boolean;
function argc: integer; extern;
function argv(i: integer): string; extern;
procedure number;
begin
if i<10 then write('0000',i:1)
else if i<100 then write('000',i:2)
else if i<1000 then write('00',i:3)
else if i<10000 then write('0',i:4)
else write(i:5);
if not numbered then write(' ');
if not eoln then write(c);
while not eoln do
begin
read(c);
write(c)
end;
readln;
writeln;
i:=i+step
end;
function getarg(n:integer) : integer;
var s : string;
i,g :integer;
begin
s := argv(n);
i:=1;
while (not (s^[i] in ['0'..'9'])) and (i<10) do i:=i+1;
g := 0;
if not (s^[i] in ['0'..'9']) then g := 100
else
while (i<11) and (s^[i] in ['0'..'9']) do begin
g := g*10+ord(s^[i])-ord('0');
i := i+1
end;
getarg := g
end;
begin
start := 100;
step := 10;
if argc>1 then start := getarg(1);
if argc>2 then step := getarg(2);
if argc>3 then
writeln('Syntax : reseq <file1 >file2 start step : subsequent args ignored');
read(c);
numbered := (c in ['0'..'9']);
i := start;
while not eof do
begin
if numbered then
while c in ['0'..'9'] do
read(c);
number;
if not eof then
if not eoln then read(c)
end
end.

333
lang/a68s/util/tailor.p Normal file
View file

@ -0,0 +1,333 @@
(* COPYRIGHT 1979 YAVUZ ONDER, UNIVERSITY OF MANCHESTER *)
(*$G-*)
PROGRAM TAILOR ( INPUT, INFILE, error, output );
(* HOW TO USE 'TAILOR'
* -ANY VERSION IN TEXT IS OPENED BY (*SNN() AND
CLOSED BY ()SNN*) (*
* WHERE S IS '+' OR '-' (NO DEFAULT),
* NN IS AN UNSIGNED TWO DIGIT INTEGER (NO ZERO SUPRESSION)
* IN SOME CASES output WILL CONTAIN '+)' INSTEAD OF
* 'ASTERISK)' AS COMMENT CLOSER.
* -THE NAME OF THE FILE TO BE TAILORED IS THE FIRST ARGUMENT.
* -THERE ARE THREE BASIC OPERATIONS :
* 'INCLUDE' : (I) REMOVES VERSION ENTRY AND CLOSING
* SYMBOLS AND CHANGES '+)'S TO 'ASTERISK )'S
* WITHIN THE VERSION ;
* (II) CHANGES ALL 'ASTERISK )'S TO '+)'S
* WITHIN THE COMPLEMENTED VERSION, EXCEPT IN
* VERSION CLOSER.
* 'SKIP' : (I) REMOVES ALL VERSION INCLUDING ENTRY AND
* CLOSING SYMBOLS ;
* (II) PERFORMS 'INCLUDE' (I) ON COMPLEMENTED VERSION
* 'LEAVE ALONE': IF NO COMMAND EXISTS FOR ANY ONE OF THE VERSIONS
* IN THE TEXT 'INCLUDE' IS PERFORMED ON
* -(ABS(VERSION-NOT-IN-TEXT)).
* -COMMANDS ARE INPUT WHEN REQUIRED BY 'TAILOR'.
* -TO 'INCLUDE' ANY VERSION GIVE ITS NUMBER ('+'S NEED NOT BE GIVEN.).
* -TO 'SKIP' ANY VERSION ENTER ABS(ITS-NUMBER)+100 SIGNED AS IN TEXT...
*
* ... E.G. COMMAND SEQUENCE ' 1 -102 103 -20 200 ' MEANS
* (PERFORM 'INCLUDE' ON 1,2,-3 AND -20 ) AND
* (PERFORM 'SKIP' ON -2 AND 3 ) AND
* (PERFORM 'LEAVE ALONE' ON ALL OTHER VERSIONS IN TEXT.).
* -TO TERMINATE COMMAND SEQUENCE BEFORE THIRTY-SECOND ENTER ANY COMMAND>=300
* THIRTYTWO OR MORE COMMANDS START THE EXECUTION OF THE TAILOR
* AND ONLY FIRST THIRTYTWO (NOW APPROX 50) ARE ACCEPTED.
* -IF ANY VERSION OR ITS COMPLEMENT TAKES PLACE IN MORE THAN ONE
* COMMAND THE LAST ONE IS OBEYED.
* -ZERO CANNOT BE USED AS VERSION NUMBER OR IN COMMANDS.
* -TO REMOVE ALL TAILORING BRACKETS (USEFUL PRIOR TO XREF) INPUT 1000 ONLY.
* -LINE NUMBER ARE REMOVED FROM FILES, EXCEPT WITH THE 1000 COMMAND.
* -THE TAILORED PROGRAM APPEARS ON THE STANDARD OPUTPUT.
* -ERROR MESSAGES APPEAR ON THE FILE GIVEN BY THE SECOND ARGUMENT.
************* END OF HOW TO USE ************************************)
CONST verslimit=50;
VAR VERLIST : ARRAY[1..verslimit]OF INTEGER;
INFILE : TEXT;
error : TEXT;
(* INPUT AND OUTPUT FILES *)
NOOFVER : INTEGER;
(* NUMBER OF COMMANDS (MAX. verslimit) *)
INLFLAG, INIFLAG : INTEGER;
(* FLAGS SHOWING WHETHER IN A 'LEAVE ALONE' OR
'INCLUDE' RESPECTIVELY *)
LINBUF : ARRAY[1..200]OF CHAR;
(* TEMPORARY STORAGE FOR MANIPULATION OF
THE CURRENT LINE *)
FIRSTNONBLANK : INTEGER; (* KEEPS THE POSITION OF FIRST
NONBLANK
CHAR IN LINBUF *)
INCLUDEALL : BOOLEAN;
(*******************************************************)
PROCEDURE INITIALISE ( VAR NOOFVER : INTEGER );
(* READS COMMANDS AND INITIALISES THE GLOBALS *)
LABEL 9;
VAR VERNO, I : INTEGER;
BEGIN
INCLUDEALL := FALSE;
I := 0;
REPEAT
IF I < verslimit THEN
BEGIN
I := I+1;
READ ( VERNO );
IF VERNO < 300 THEN
VERLIST[I]:= VERNO
ELSE
BEGIN
I := I-1;
IF ( VERNO=1000 ) AND ( I=0 ) THEN
INCLUDEALL := TRUE;
GOTO 9
END;
END
ELSE
GOTO 9
UNTIL 1=0;
9: NOOFVER := I;
INLFLAG := 0;
INIFLAG := 0;
FOR I := 1 TO 120 DO
LINBUF[I]:= ' ';
FIRSTNONBLANK := 1(*0*);
RESET ( INFILE );
REWRITE ( output );
REWRITE ( error );
END;
(*******************************************************)
PROCEDURE SEARCHVER;
(* SEARCHES FOLLOWING VERSION IN THE TEXT
WHEN FOUND CALLS PROC SCANLIST *)
LABEL 99;
VAR CH : CHAR;
I, II : INTEGER;
PROCEDURE SCANLIST;
FORWARD;
(****************************)
PROCEDURE FINDEND ( VER : INTEGER );
(* SEARCHES END OF THE VERSION GIVEN IN PARAMETER
IF ENCOUNTERS ANOTHER VERSION ENTRY IN THE MEANTIME
CALLS PROC SCANLIST ( AND ITSELF INDIRECTLY ) *)
LABEL 999, 888, 9999;
VAR II, FIXI, ABVER, CLSVER : INTEGER;
OP : CHAR;
BEGIN
FIXI := I;
ABVER := ABS ( VER );
IF ABVER < 100 THEN
OP := 'I'
ELSE
BEGIN
IF ABVER < 200 THEN
OP := 'S'
ELSE
OP := 'L';
VER := ( ABVER MOD 100 )*VER DIV ABVER;
END;
REPEAT
while EOLN ( INFILE ) (* END-OF-LINE ACTION *)
do
BEGIN
IF NOT ( OP='S' ) THEN
IF FIRSTNONBLANK <> 0 THEN
BEGIN
FOR II := 1 TO I DO
WRITE ( output, LINBUF[II]);
WRITELN ( output )
END
ELSE (*NOTHING*)
ELSE
IF (FIXI>=FIRSTNONBLANK) AND (FIRSTNONBLANK <> 0) THEN
BEGIN
FOR II := 1 TO FIXI-1 DO
WRITE ( output, LINBUF[II]);
WRITELN ( output )
END
ELSE writeln(output) (*to keep line nos in step*);
READLN ( INFILE );
IF EOF ( INFILE ) THEN
GOTO 888;
if (infile^ in ['0'..'9']) AND NOT INCLUDEALL then
for ii := 1 to 6 do get(infile); (*ignore line numbers*)
I := 0;
fixi := 0;
FIRSTNONBLANK := 1(*0*)
END;
READ ( INFILE, CH );
(* ACTION FOR EVERY CHARACTER *)
I := I+1;
LINBUF[I]:= CH;
IF ( FIRSTNONBLANK=0 ) THEN
IF CH<>' ' THEN
BEGIN
FIRSTNONBLANK := I;
FIXI := I-1
END;
IF ( CH=')' ) AND ( I > 6 ) (* A VERSIN CLOSER ? *)
THEN
IF LINBUF[I-6]='(' THEN
IF LINBUF[I-5]=')' THEN
IF ( LINBUF[I-1]='*' ) OR ( LINBUF[I-1]='+' ) THEN
IF ( LINBUF[I-2]IN['0'..'9']) AND ( LINBUF[I-3]IN['0'..'9']) AND ( LINBUF[I-4]IN['+', '-']) THEN
BEGIN
CLSVER := ORD ( LINBUF[I-2])-ORD ( '0' )+( ORD ( LINBUF[I-3])-ORD ( '0' ) )*10;
IF LINBUF[I-4]='-' THEN
CLSVER :=-CLSVER;
IF ( VER=CLSVER ) OR INCLUDEALL THEN
BEGIN
IF ( OP='I' ) OR INCLUDEALL THEN
IF FIRSTNONBLANK=I-6 THEN
BEGIN
FOR II := I DOWNTO I-6 DO
LINBUF[II]:= ' ';
FIRSTNONBLANK := 1(*0*)
END
ELSE
I := I-7;
IF OP='S' THEN
BEGIN
I := FIXI;
IF FIRSTNONBLANK >= FIXI THEN
FIRSTNONBLANK := 1(*0*)
END;
GOTO 9999;
END;
END;
IF OP='S' THEN
GOTO 999;
IF ( CH=')' ) AND ( I > 6 ) (* A NEW VERSION ENTRY ? *)
THEN
IF LINBUF[I-6]='(' THEN
IF LINBUF[I-1]='(' THEN
IF LINBUF[I-5]='*' THEN
IF ( LINBUF[I-2]IN['0'..'9']) AND ( LINBUF[I-3]IN['0'..'9']) AND ( LINBUF[I-4]IN['+', '-']) THEN
SCANLIST;
IF I>1 THEN
IF LINBUF[I]=')' (* CORRECTIONS ON COMMENT CLOSERS
*)
THEN
BEGIN
IF ( INLFLAG > 0 ) AND ( LINBUF[I-1]='*' ) THEN
LINBUF[I-1]:= '+';
IF ( INIFLAG > 0 ) AND ( INLFLAG=0 ) AND ( LINBUF[I-1]='+' ) THEN
LINBUF[I-1]:= '*';
END;
999:
UNTIL EOF ( INFILE );
888:
WRITELN ( error, 'VERSION ', VER : 2, ' NOT CLOSED AT EOF.' );
9999:
END;
(******************************)
PROCEDURE SCANLIST;
VAR II, III, VERSN, COMMAND, ABSVER : INTEGER;
BEGIN
(* COMPUTES VERSION NUMBER FROM TEXT *)
VERSN := ORD ( LINBUF[I-2])-ORD ( '0' )+( ORD ( LINBUF[I-3])-ORD ( '0' ) )*10;
IF LINBUF[I-4]='-' THEN
VERSN :=-VERSN;
ABSVER := ABS ( VERSN );
COMMAND :=-ABS ( VERSN );
(* FINDS COMMAND RELATED TO CURRENT VERSION, IF ANY *)
FOR II := 1 TO NOOFVER DO
IF ( ABSVER=ABS ( VERLIST[II]) ) OR ( ABSVER=ABS ( VERLIST[II])-100 ) or (absver=abs(verlist[ii])-200) THEN
COMMAND := VERLIST[II];
IF ( COMMAND=VERSN ) OR ( ABS ( COMMAND+VERSN )=100 ) OR INCLUDEALL (*
CHECK & ACTION FOR 'INCLUDE' CONDITION
*)
THEN
BEGIN
FOR III := I DOWNTO I-6 DO
LINBUF[III]:= ' ';
IF FIRSTNONBLANK=I-6 THEN
FIRSTNONBLANK := 1(*0*)
ELSE
I := I-7;
INIFLAG := INIFLAG+1;
FINDEND ( VERSN );
INIFLAG := INIFLAG-1;
END
ELSE
IF COMMAND+VERSN=0 (* CHECK & ACTION FOR 'LEAVE ALONE
' CONDITION *)
THEN
BEGIN
INLFLAG := INLFLAG+1;
FINDEND ( ( ABSVER+200 )*VERSN DIV ABSVER );
INLFLAG := INLFLAG-1;
END
ELSE
BEGIN
(* ACTION FOR 'SKIP' CONDITION *)
I := I-7;
IF FIRSTNONBLANK=I-6 THEN
FIRSTNONBLANK := 1(*0*);
FINDEND ( ( ABSVER+100 )*VERSN DIV ABSVER );
END;
END;
(*******************************)
BEGIN (* BODY OF SEARCHVER *)
if (infile^ in ['0'..'9']) AND NOT INCLUDEALL then
for ii := 1 to 6 do get(infile); (*ignore line numbers*)
I := 0;
REPEAT
while EOLN ( INFILE ) do
begin
(* ACTION FOR EOLN S OUT OF ANY VERSION *)
IF FIRSTNONBLANK <> 0 THEN
BEGIN
FOR II := 1 TO I DO
WRITE ( output, LINBUF[II]);
WRITELN ( output );
READLN ( INFILE );
IF EOF ( INFILE ) THEN
GOTO 99;
FIRSTNONBLANK := 1(*0*);
END
ELSE
BEGIN
if eof(infile) then goto 99;
READLN ( INFILE );
IF EOF ( INFILE ) THEN
GOTO 99
END;
if (infile^ in ['0'..'9']) AND NOT INCLUDEALL then
for ii := 1 to 6 do get(infile); (*ignore line numbers*)
I := 0;
end;
READ ( INFILE, CH );
I := I+1;
LINBUF[I]:= CH;
IF FIRSTNONBLANK=0 THEN
IF CH<>' ' THEN
FIRSTNONBLANK := I;
IF ( CH=')' ) AND ( I > 5 ) (* A VERSION ENTRY ? *)
THEN
IF LINBUF[I-1]='(' THEN
IF LINBUF[I-5]='*' THEN
IF LINBUF[I-6]='(' THEN
IF ( LINBUF[I-2]IN['0'..'9']) AND ( LINBUF[I-3]IN['0'..'9']) AND ( LINBUF[I-4]IN['+', '-']) THEN
SCANLIST;
UNTIL EOF ( INFILE );
99:
END;
(***************************************************************)
BEGIN
INITIALISE ( NOOFVER );
SEARCHVER;
END.

775
lang/a68s/util/xref.c Normal file
View file

@ -0,0 +1,775 @@
/*
* xref makes cross references.
* November 1977 Johan Stevenson
*/
#include <stdio.h>
#include <signal.h>
#include <setjmp.h>
/* type of flags() calls */
#define HEAD 0
#define TAIL 1
FILE *input;
FILE *output;
FILE *hashin;
jmp_buf env; /* used by setjmp and longjmp */
int scanout[2]; /* descriptor of output of scan */
int postin[2]; /* descriptor of input of post */
int ch; /*last char*/
int chsy; /*type of last char*/
char id[80]; /*last identifier*/
char fl[80]; /*last filename (see post) */
char buf[80]; /*work space*/
int proc = 0; /*process id of sort*/
int nflag; /*line number flag*/
int nfiles;
int argc;
char **argv;
char *procname;
char *file; /*points to current file*/
int pass1 = 1;
int pass2 = 1;
int only = 0; /* 1 if only selected words needed */
int useroif = 0; /* 1 if user supplied ignore/only file*/
char *oifile = "/usr/lib/xrefign.\0";
int oifsuf = 0; /* index in oifile of last char */
int linecount;
int width = 72; /*line width*/
int type; /* which scanner must be used */
int forced = 0; /* scanner type chosen by user */
stop()
{
if (proc!=0)
kill(proc,9);
exit(-1);
}
main(narg,args) char **args;
int narg;
{
argc=narg;
argv = args;
argc--;
argv++;
if (signal(SIGHUP,stop) != SIG_DFL)
signal(SIGHUP,SIG_IGN);
if (signal(SIGINT,stop) != SIG_DFL)
signal(SIGINT,SIG_IGN);
while (argc && argv[0][0]=='-' && argv[0][1]!='\0')
{
argc--;
flags(*argv++,HEAD);
}
if (argc==0) {
argc++;
*--argv = "-";
}
if (pass1 && pass2) {
if (pipe(scanout)<0 || pipe(postin)<0)
fatal("pipe failed");
if ((proc=fork()) == 0) {
close(0);
close(1);
dup(scanout[0]);
dup(postin[1]);
close(scanout[0]);
close(scanout[1]);
close(postin[0]);
close(postin[1]);
execl("/bin/sort","xref","+1","-3","+0n",0);
execl("/usr/bin/sort","xref","+1","-3","+0n",0);
fatal("sort not found");
}
if (proc == -1) fatal("fork failed");
close(scanout[0]);
close(postin[1]);
}
else if (pass1)
scanout[1] = dup(1);
else if (pass2)
postin[0] = dup(0);
if (pass1) {
if (useroif) {
if ((hashin = fopen(oifile, "r")) == NULL)
fatal("bad ignore/only file: %s",oifile);
buildhash();
fclose(hashin);
}
input = stdin;
output = fdopen(scanout[1], "w");
nfiles = argc;
setjmp(env);
while (argc--)
if (argv[0][0] == '-' && argv[0][1] != '\0')
flags(*argv++,TAIL);
else
scan(*argv++);
fclose(input);
fclose(output);
}
if (pass2) {
input = fdopen(postin[0], "r");
output = stdout;
post();
}
exit(0);
}
flags(s,ftype) register char *s;
{
register c;
s++; /* skip - */
switch (c = *s++) {
case 'p':
case '8':
case 'c':
case 's':
case 'x':
forced++;
type = c;
break;
case '1':
if (ftype == TAIL)
fatal("-1 must precede file arguments");
pass2=0;
pass1++;
break;
case '2':
if (ftype == TAIL)
fatal("-2 must precede file arguments");
pass1=0;
pass2++;
break;
case 'i':
case 'o':
only = (c == 'o');
useroif++;
if (*s == '\0')
fatal("more args expected");
oifile = s;
return;
case 'w':
if (*s == '\0')
fatal("more args expected");
width=atoi(s);
return;
default:
fatal("possible flags: cpsxio12w");
}
if (*s != '\0')
fatal("flags should be given as separate arguments");
}
char *tail(s)
register char *s;
{
register char *t;
t = s;
while (*s)
if (*s++ == '/')
t = s;
return(t);
}
scan(s) char *s;
{
register lastc;
linecount = 0;
nflag = 0;
chsy = 0;
if (nfiles==1)
file = "";
else
file = tail(s);
if (forced==0) {
lastc = suffix(s);
if (lastc=='h')
lastc = 'c';
if (lastc=='c' || lastc=='p' || lastc=='s' || lastc=='8')
type=lastc;
else
type='x';
} else
lastc = type;
if (useroif==0) {
if (oifsuf == 0)
while (oifile[oifsuf] != '\0')
oifsuf++;
if (lastc != oifile[oifsuf] ) {
oifile[oifsuf] = lastc;
if ((hashin = fopen(oifile, "r")) == NULL) {
oifile[oifsuf] = 'x';
if ((hashin = fopen(oifile, "r")) == NULL)
fatal("cannot open %s",oifile);
}
buildhash();
fclose(hashin);
}
}
if (s[0]=='-' && s[1]=='\0')
input = stdin;
else
if ((input = fopen(s, "r")) == NULL)
fatal("cannot open %s",s);
switch (type) {
case 'x':
x_scan();
break;
case 'p':
p_scan();
break;
case '8':
a_scan();
break;
case 'c':
c_scan();
break;
case 's':
s_scan();
break;
}
/*this place is never reached*/
}
suffix(s)
register char *s;
{
while (*s) s++;
if (*(s-2) == '.')
return(*--s);
return('x');
}
fatal(s) char *s;
{
fprintf(stderr, "xref: %s",s);
fprintf(stderr, "\n");
stop();
}
/*============================================*/
#define HSIZE 79
struct {
int integ;
};
struct link {
struct link *next;
char word[];
}
*hashtab[HSIZE];
buildhash()
{
register struct link *p,*q;
register char *s;
int i;
for (i=0; i<HSIZE; i++)
{
p = hashtab[i];
hashtab[i] = 0;
while (q = p)
{
p = q->next;
free(q);
}
}
ch = getc(hashin);
while (ch != EOF) {
s = id;
do {
*s++ = ch;
ch = getc(hashin);
} while (ch>' ');
*s++ = '\0';
h_add(id,s-id);
while (ch!='\n' && ch!=EOF)
ch = getc(hashin);
ch = getc(hashin);
}
}
h_add(s,l) char *s;
int l;
{
register struct link *q,**p;
char temp[80];
char *s2;
if (h_in(s)) return;
s2 = temp;
strcpy(s2,s);
if (strlen(s2)<=2)
strcat(s2,"zz\0");
p = &hashtab[ s2->integ % HSIZE ];
l += 4+((4-(l & 3) & 3));
if ((q = malloc(l)) == 0)
fatal("out of space");
q->next = *p;
*p = q;
strcpy(q->word, s);
}
h_in(s) char *s;
{
register struct link *p;
char temp[80];
char *s2;
s2 = temp;
strcpy(s2,s);
if (strlen(s)<= 2)
strcat(s2,"zz\0");
p = hashtab[ s2->integ % HSIZE ];
while (p) {
if (strcmp(s, p->word) == 0)
return(1);
p = p->next;
}
return(0);
}
/*=====================================*/
#define NL -1
#define ERROR 0
#define LETTER 1
#define DIGIT 2
#define QUOTE 3
#define LPAR 4
#define LBRACE 5
#define DQUOTE 6
#define SLASH 7
#define POINT 9
#define LESS 10
#define USCORE 11
#define OTHER 12
#define HASH 13
char cs[128] = {
/*NUL*/ ERROR, OTHER, OTHER, OTHER, OTHER, OTHER, OTHER, OTHER,
/*010*/ OTHER, OTHER, NL, OTHER, OTHER, OTHER, OTHER, OTHER,
/*020*/ OTHER, OTHER, OTHER, OTHER, OTHER, OTHER, OTHER, OTHER,
/*030*/ OTHER, OTHER, OTHER, OTHER, OTHER, OTHER, OTHER, OTHER,
/*' '*/ OTHER, OTHER, DQUOTE, HASH, OTHER, OTHER, OTHER, QUOTE,
/*'('*/ LPAR, OTHER, OTHER, OTHER, OTHER, OTHER, POINT, SLASH,
/*'0'*/ DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT,
/*'8'*/ DIGIT, DIGIT, OTHER, OTHER, LESS, OTHER, OTHER, OTHER,
/*'@'*/ OTHER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER,
/*'H'*/ LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER,
/*'P'*/ LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER,
/*'X'*/ LETTER, LETTER, LETTER, OTHER, OTHER, OTHER, OTHER, USCORE,
/*'`'*/ OTHER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER,
/*'h'*/ LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER,
/*'p'*/ LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER,
/*'x'*/ LETTER, LETTER, LETTER, LBRACE, OTHER, OTHER, OTHER, OTHER
};
nextch()
{
if (linecount == 0) {
if ((ch=getc(input))==EOF) {
fclose(input);
longjmp(env,0);
}
else {
chsy = cs[ch];
if (chsy != DIGIT)
linecount++;
else {
nflag = 1;
linecount = ch-'0';
chsy = cs[(ch=getc(input))];
while (chsy == DIGIT) {
linecount = linecount*10+ch-'0';
chsy = cs[(ch=getc(input))];
}
}
}
}
else {
if ((ch=getc(input))==EOF) {
fclose(input);
longjmp(env,0);
}
if (chsy < 0) {
if (nflag == 0)
linecount++;
else {
linecount = ch-'0';
chsy = cs[(ch=getc(input))];
while (chsy == DIGIT) {
linecount = linecount*10+ch-'0';
chsy = cs[(ch=getc(input))];
}
}
}
if (ch >= 128)
fatal("bad chars on file %s",*--argv);
chsy = cs[ch];
}
}
out(p)
char *p;
{
fprintf(output, "%d %s %s\n",linecount,p,file);
}
scannumber()
{
do nextch(); while (chsy == DIGIT);
if (ch == '.') {
nextch();
if (chsy!=DIGIT) return;
do nextch(); while (chsy == DIGIT);
}
if (ch == 'e') {
nextch();
if (ch == '+' || ch == '-')
nextch();
while (chsy == DIGIT)
nextch();
}
}
scansymbol(ok1,ok2) {
register char *p;
p = id;
do {
*p++ = ch;
nextch();
} while (chsy==LETTER || chsy==DIGIT || ch==ok1 || ch==ok2);
*p = '\0';
if (h_in(id) == only)
out(id);
}
scanusymbol(ok1,ok2) {
register char *p;
p = id;
do {
if (ch >= 'a' && ch <= 'z')
ch += 'A'-'a';
*p++ = ch;
nextch();
} while (chsy==LETTER || chsy==DIGIT || ch==ok1 || ch==ok2);
*p = '\0';
if (h_in(id) == only)
out(id);
}
escaped() {
if (ch=='\\') nextch();
nextch();
}
comment(lastch) {
nextch();
if (ch=='*') {
nextch();
do {
while(ch!='*') nextch();
nextch();
} while (ch!=lastch);
nextch();
}
}
acmnt1() {
/* handle a .COMMENT ..... .COMMENT */
register char *p;
register int cont;
p = id;
nextch();
if (chsy==DIGIT) scannumber();
else {
do {
*p++ = ch;
nextch();
} while (chsy==LETTER);
/* see if the word is COMMENT */
*p = '\0';
p = id;
if (strcmp("COMMENT",p)) { /* skip to next .COMMENT */
cont = 1;
while (cont) {
while (chsy != POINT) nextch();
nextch();
p = id;
do {
*p++ = ch;
nextch();
} while (chsy==LETTER);
*p = '\0';
p = id;
cont = strcmp("COMMENT",p);
}
}
else { /* do hash lookup - could be pragmat (ignore) or record field */
if (h_in(id)==only)
out(id);
}
}
}
acmnt2() {
register char *p;
int cont;
/* handle a CO ..... CO comment */
p = id;
*p++ = 'C';
nextch();
if (ch!='O') { /* do a scansymbol */
do {
*p++ =ch;
nextch();
} while (chsy==LETTER || chsy==DIGIT || chsy==USCORE);
if (h_in(id)==only)
out(id);
}
else { /* found a CO .... CO */
cont = 1;
while (cont) {
while (ch!='C') nextch();
nextch();
cont = (ch!='O');
}
nextch();
}
}
p_scan() {
nextch();
for(;;) switch (chsy) {
case LETTER:
case USCORE:
scanusymbol('_','\0');
break;
case DIGIT:
scannumber();
break;
case QUOTE:
do nextch(); while (ch!='\'');
nextch();
break;
case DQUOTE:
do nextch(); while (ch!='"');
nextch();
break;
case LPAR:
comment(')');
break;
case LBRACE:
do nextch(); while (ch!='}');
default:
nextch();
}
}
a_scan() {
nextch();
for(;;) switch (chsy) {
case LETTER:
if (ch=='C') acmnt2();
else
scanusymbol('_','\0');
break;
case DIGIT:
scannumber();
break;
case QUOTE:
do nextch(); while (ch!='\'');
nextch();
break;
case DQUOTE:
do nextch(); while (ch!='"');
nextch();
break;
case HASH:
nextch();
while (ch!='#') nextch();
nextch();
break;
case POINT:
acmnt1();
break;
default:
nextch();
}
}
c_scan()
{
nextch();
for (;;) switch (chsy) {
case LETTER:
case USCORE:
scansymbol('_','\0');
break;
case DIGIT:
scannumber();
break;
case SLASH:
comment('/');
break;
case QUOTE:
do escaped(); while (ch!='\'');
nextch();
break;
case DQUOTE:
do escaped(); while (ch!='"');
default:
nextch();
}
}
s_scan()
{
nextch();
for(;;) switch(chsy) {
case LETTER:
case POINT:
scansymbol('_','.');
break;
case DIGIT:
do nextch(); while (chsy==DIGIT);
if (ch=='.' || ch=='f' || ch=='b') nextch();
break;
case DQUOTE:
nextch();
case QUOTE:
escaped();
escaped();
break;
case SLASH:
do nextch(); while (ch!='\n');
break;
case LESS:
nextch();
do escaped(); while (ch!='>');
break;
default:
nextch();
}
}
x_scan()
{
register char *p;
nextch();
for (;;) switch (chsy) {
case LETTER:
p=id;
do {
if (ch<'A' || ch>'Z') *p++ = ch;
else *p++ = ch - 'A' + 'a';
nextch();
if (ch=='-') {
nextch();
if (ch=='\n')
do nextch(); while (chsy!=LETTER);
else *p++ = '-';
}
} while (chsy==LETTER || chsy==DIGIT);
*p = '\0';
if (h_in(id) == only) out(id);
break;
default:
nextch();
}
}
/*=========================================*/
int N;
post()
{
register n,l,i;
int first,newid,newfl,withfile;
first = 1;
id[0] = '\0';
ch = getc(input);
while (ch != EOF) {
l = getfld('\t');
if ((i=atoi(buf)) == 0)
fatal("line number expected");
l = getfld('\t');
newid = strcmp(id,buf);
if (newid) {
strcpy(id,buf);
if (first == 0)
putc('\n',output);
fprintf(output,"%s",id);
if (l > 7)
putc('\n',output);
putc('\t',output);
fl[0] = '\0';
}
l = getfld('\n');
newfl = strcmp(fl,buf);
if (newfl) {
strcpy(fl,buf);
if (newid == 0)
fprintf(output,"\n\t");
fprintf(output,"%s",fl);
if (l > 7)
fprintf(output,"\n\t");
putc('\t',output);
}
if (first) {
first = 0;
withfile = newfl;
N = width - 12;
if (withfile) N -= 8;
if (N<0) fatal("line width too small");
N = (N/5) + 1;
}
if (newid || newfl)
n = N;
else if (n==0) {
fprintf(output,"\n\t");
if (withfile)
putc('\t',output);
n = N;
}
else
putc(' ',output);
n--;
fprintf(output,"%4d",i);
}
putc('\n',output);
}
getfld(stopch) {
register char *p;
p = buf;
while (ch!=EOF && ch!=stopch) {
*p++ = ch;
ch = getc(input);
}
*p = '\0';
ch = getc(input);
return(p-buf);
}