From ef496fd66137ffc408ef1d3d8d91f909576795fc Mon Sep 17 00:00:00 2001 From: Paul Kimpel Date: Sat, 16 Jul 2016 18:19:45 -0700 Subject: [PATCH] Commit changes to SNOBOL files in preparation for proofing and correction: correct sequence numbers, up-case text; commit README file. --- SNOBOL-UW-Chambers/README.txt | 37 + SNOBOL-UW-Chambers/SNTEST.card | 672 +- SNOBOL-UW-Chambers/SYMBOL.SNOBOL.alg_m | 15583 +++++++++++------------ 3 files changed, 8162 insertions(+), 8130 deletions(-) create mode 100644 SNOBOL-UW-Chambers/README.txt diff --git a/SNOBOL-UW-Chambers/README.txt b/SNOBOL-UW-Chambers/README.txt new file mode 100644 index 0000000..e71bc25 --- /dev/null +++ b/SNOBOL-UW-Chambers/README.txt @@ -0,0 +1,37 @@ +SNOBOL3 Interpreter for the Burroughs B5500 + +This implementation of SNOBOL3 was written by John Chambers at the +University of Wisconsin. The source was apparently obtained from CUBE +library tape CUBEA13, file SNOBOL/L200010. + +A user manual is available at +http://bitsavers.org/pdf/burroughs/B5000_5500_5700/listing/ +B5700_Snobol_Manual_Jun76.pdf. + +The compiler and test program were originally transcribed by Rich +Cornwell of North Carolina, US. + + +**NOTE** + These files have not yet been proofread and corrected. + + +SNOBOL3-Compile.card + Card deck to compile the SNOBOL interpreter. + +SYMBOL/SNOBOL.alg_m + Source of the interpreter, transcribed from + http://bitsavers.org/pdf/burroughs/B5000_5500_5700/listing/ + B5700_Snobol_Compiler_Apr77.pdf + by Rich Cornwell of + +SNTEST.card + A card deck with a series of SNOBOL test runs supplied by Rich + Cornwell. + + +__________ +2016-07-16 Paul Kimpel + Commit initial files as transcribed by Rich Cornwell; overwrite with + revised source having up-cased text and sequence number corrections, + ready for proofreading. diff --git a/SNOBOL-UW-Chambers/SNTEST.card b/SNOBOL-UW-Chambers/SNTEST.card index 442e761..a5509a2 100644 --- a/SNOBOL-UW-Chambers/SNTEST.card +++ b/SNOBOL-UW-Chambers/SNTEST.card @@ -1,159 +1,159 @@ -?execute snobol/disk -?file print = print back up disk -?common=3 -?data program --list -* example 2, differentiation of algebraic expression +?EXECUTE SNOBOL/DISK +?FILE PRINT = PRINT BACK UP DISK +?COMMON=3 +?DATA PROGRAM +-LIST +* EXAMPLE 2, DIFFERENTIATION OF ALGEBRAIC EXPRESSION * -* this program differentiates a fully parenthesized -* algebraic expression with respect to x. the exponentiation -* operator is indicated by a dollar sign. -- space 2 - define("d(d)","do","u,v,n") - define("simplify(exp)","s0","u") - trace("d,simplify") -- space -* READ In the expression. -- space -read exp = trim(syspit) /f(end) -- space - mode("anchor") - syspot = - syspot = "the derivative of " exp " is " simplify(d(exp)) -. /(end) -- space 2 -* the function "d" -- space -do d "(" *(u)* "+" *(v)* ")" = "(" d(u) "+" d(v) ")" -. /s(return) -- space - D "(" *(u)* "-" *(v)* ")" = "(" d(u) "-" d(v) ")" -. /s(return) -- space - D "(" *(u)* "*" *(v)* ")" = "((" u "*" d(v) ")+(" -. v "*" d(u) "))" /s(return) -- space - D "(" *(u)* "/" *(v)* ")" = "(((" v "*" d(u) ")-(" -. u "*" d(v) "))/(" v "$2))" /s(return) -- space - D "(" *(u)* "$" *(v)* ")" = -. "((" n "*(" U "$" n - "1" "))*" d(U) ")" -. /s(return) -- space - d = equals(d,"x") "1" /s(return) - d = "0" /(return) +* THIS PROGRAM DIFFERENTIATES A FULLY PARENTHESIZED +* ALGEBRAIC EXPRESSION WITH RESPECT TO X. THE EXPONENTIATION +* OPERATOR IS INDICATED BY A DOLLAR SIGN. +- SPACE 2 + DEFINE("D(D)","DO","U,V,N") + DEFINE("SIMPLIFY(EXP)","S0","U") + TRACE("D,SIMPLIFY") +- SPACE +* READ IN THE EXPRESSION. +- SPACE +READ EXP = TRIM(SYSPIT) /F(END) +- SPACE + MODE("ANCHOR") + SYSPOT = + SYSPOT = "THE DERIVATIVE OF " EXP " IS " SIMPLIFY(D(EXP)) +. /(END) +- SPACE 2 +* THE FUNCTION "D" +- SPACE +DO D "(" *(U)* "+" *(V)* ")" = "(" D(U) "+" D(V) ")" +. /S(RETURN) +- SPACE + D "(" *(U)* "-" *(V)* ")" = "(" D(U) "-" D(V) ")" +. /S(RETURN) +- SPACE + D "(" *(U)* "*" *(V)* ")" = "((" U "*" D(V) ")+(" +. V "*" D(U) "))" /S(RETURN) +- SPACE + D "(" *(U)* "/" *(V)* ")" = "(((" V "*" D(U) ")-(" +. U "*" D(V) "))/(" V "$2))" /S(RETURN) +- SPACE + D "(" *(U)* "$" *(V)* ")" = +. "((" N "*(" U "$" N - "1" "))*" D(U) ")" +. /S(RETURN) +- SPACE + D = EQUALS(D,"X") "1" /S(RETURN) + D = "0" /(RETURN) -* the function "simplify" -- space -s0 mode("unanch") -s1 exp "(" *(u)* "*0)" = "0" /s(s1) - exp "(0*" *(u)* ")" = "0" /s(s1) -s2 exp "(" *(u)* "$1)" = u /s(s2) -s3 exp "(" *(u)* "*1)" = u /s(s3) -s4 exp "(1*" *(u)* ")" = u /s(s4) -s5 exp "(0+" *(u)* ")" = u /s(s5) -s6 exp "(" *(u)* "+0)" = U /S(S6) -s7 exp "(" *(u)* "-0)" = u /s(s7) - simplify = exp /(return) -end -?data card -(((a*(x$2))+(b*x))+c) -?end -?execute snobol/disk -?file print = print back up disk -?common=3 -?data program --list -* example 1. the wang algorithm +* THE FUNCTION "SIMPLIFY" +- SPACE +S0 MODE("UNANCH") +S1 EXP "(" *(U)* "*0)" = "0" /S(S1) + EXP "(0*" *(U)* ")" = "0" /S(S1) +S2 EXP "(" *(U)* "$1)" = U /S(S2) +S3 EXP "(" *(U)* "*1)" = U /S(S3) +S4 EXP "(1*" *(U)* ")" = U /S(S4) +S5 EXP "(0+" *(U)* ")" = U /S(S5) +S6 EXP "(" *(U)* "+0)" = U /S(S6) +S7 EXP "(" *(U)* "-0)" = U /S(S7) + SIMPLIFY = EXP /(RETURN) +END +?DATA CARD +(((A*(X$2))+(B*X))+C) +?END +?EXECUTE SNOBOL/DISK +?FILE PRINT = PRINT BACK UP DISK +?COMMON=3 +?DATA PROGRAM +-LIST +* EXAMPLE 1. THE WANG ALGORITHM * -* this program is the algorithm by hao want (cf. "toward -* mechanical mathematics", ibm journal be research and -* development for the propositional calculus., it prints out a -* PRoof or disproof according as a given formula is a theorem -* or not. thealogrithm uses sequents which consist of two -* lists of formulas seperated by an arrow (--*). INITIALLY, for -* a given formula p the sequent +* THIS PROGRAM IS THE ALGORITHM BY HAO WANT (CF. "TOWARD +* MECHANICAL MATHEMATICS", IBM JOURNAL BE RESEARCH AND +* DEVELOPMENT FOR THE PROPOSITIONAL CALCULUS., IT PRINTS OUT A +* PROOF OR DISPROOF ACCORDING AS A GIVEN FORMULA IS A THEOREM +* OR NOT. THEALOGRITHM USES SEQUENTS WHICH CONSIST OF TWO +* LISTS OF FORMULAS SEPERATED BY AN ARROW (--*). INITIALLY, FOR +* A GIVEN FORMULA P THE SEQUENT * -* --* f +* --* F * -* is formed. wang has defined rules for simplifying a formula -* IN a sequent by removing the main connective and then -* generating a new sequent or sequents. there is a terminal -* test for a sequent consisting of only atomic formulas: +* IS FORMED. WANG HAS DEFINED RULES FOR SIMPLIFYING A FORMULA +* IN A SEQUENT BY REMOVING THE MAIN CONNECTIVE AND THEN +* GENERATING A NEW SEQUENT OR SEQUENTS. THERE IS A TERMINAL +* TEST FOR A SEQUENT CONSISTING OF ONLY ATOMIC FORMULAS: * -* two sequent consisting of only atomic formulas is valid if -* the two lists of formulas have a formula in common. +* TWO SEQUENT CONSISTING OF ONLY ATOMIC FORMULAS IS VALID IF +* THE TWO LISTS OF FORMULAS HAVE A FORMULA IN COMMON. * -* by repeated application of the rules one is led to a set of -* sequents consisting of atomic formulas. if each one of these -* sequents is valid then so is the original formula. -- space 5 - define("wang(ante,conseq)" , "wang","phi,psi") -* read in the expression -- space -read exp = trim(syspit) /f(end) - syspot = - syspot = "formula: " exp - syspot = - wang(," " exp) /f(invalid) - syspot = "valid" /(read) -invalid syspot = "not valid" /(read) -wang syspot = ante " --* " conseq - ante " not(" *(phi)* ")" = /s(anot) - ante " and(" *(phi)* "," *(psi)* ")" = /s(aand) - ante " imp(" *(phi)* "," *(psi)* ")" = /s(aimp) - ante " or(" *(phi)* "," *(psi)* ")" = /s(aor) - ante " equ(" *(phi)* "," *(psi)* ")" = /s(aequ) -- space - conseq " not(" *(phi)* ")" = /s(cnot) - conseq " and(" *(phi)* "," *(psi)* ")" = /s(cand) - conseq " imp(" *(phi)* "," *(psi)* ")" = /s(cimp) - conseq " or(" *(phi)* "," *(psi)* ")" = /s(cor) - conseq " equ(" *(phi)* "," *(psi)* ")" = /s(cequ) -- space - (ante " :" conseq " ") " " *(p)* " " ** ":" ** " " p " " -. /s(return)f(freturn) -anot wang(ante,conseq " " phi) /s(return)f(freturn) +* BY REPEATED APPLICATION OF THE RULES ONE IS LED TO A SET OF +* SEQUENTS CONSISTING OF ATOMIC FORMULAS. IF EACH ONE OF THESE +* SEQUENTS IS VALID THEN SO IS THE ORIGINAL FORMULA. +- SPACE 5 + DEFINE("WANG(ANTE,CONSEQ)" , "WANG","PHI,PSI") +* READ IN THE EXPRESSION +- SPACE +READ EXP = TRIM(SYSPIT) /F(END) + SYSPOT = + SYSPOT = "FORMULA: " EXP + SYSPOT = + WANG(," " EXP) /F(INVALID) + SYSPOT = "VALID" /(READ) +INVALID SYSPOT = "NOT VALID" /(READ) +WANG SYSPOT = ANTE " --* " CONSEQ + ANTE " NOT(" *(PHI)* ")" = /S(ANOT) + ANTE " AND(" *(PHI)* "," *(PSI)* ")" = /S(AAND) + ANTE " IMP(" *(PHI)* "," *(PSI)* ")" = /S(AIMP) + ANTE " OR(" *(PHI)* "," *(PSI)* ")" = /S(AOR) + ANTE " EQU(" *(PHI)* "," *(PSI)* ")" = /S(AEQU) +- SPACE + CONSEQ " NOT(" *(PHI)* ")" = /S(CNOT) + CONSEQ " AND(" *(PHI)* "," *(PSI)* ")" = /S(CAND) + CONSEQ " IMP(" *(PHI)* "," *(PSI)* ")" = /S(CIMP) + CONSEQ " OR(" *(PHI)* "," *(PSI)* ")" = /S(COR) + CONSEQ " EQU(" *(PHI)* "," *(PSI)* ")" = /S(CEQU) +- SPACE + (ANTE " :" CONSEQ " ") " " *(P)* " " ** ":" ** " " P " " +. /S(RETURN)F(FRETURN) +ANOT WANG(ANTE,CONSEQ " " PHI) /S(RETURN)F(FRETURN) - -AAND wang(ante " " phi " " psi, conseq) /s(return)f(freturn) +AAND WANG(ANTE " " PHI " " PSI, CONSEQ) /S(RETURN)F(FRETURN) - -aor wang(ante " " phi,conseq) /f(freturn) - wang(ante " " psi,conseq) /s(return)f(freturn) +AOR WANG(ANTE " " PHI,CONSEQ) /F(FRETURN) + WANG(ANTE " " PSI,CONSEQ) /S(RETURN)F(FRETURN) - -aimp wang(ante " " psi,conseq) /f(freturn) - wang(ante,conseq " " phi) /s(return)f(freturn) +AIMP WANG(ANTE " " PSI,CONSEQ) /F(FRETURN) + WANG(ANTE,CONSEQ " " PHI) /S(RETURN)F(FRETURN) - -aequ wang(ante " " phi " " psi,conseq) /f(freturn) - wang(ante,conseq " " phi " " psi) /S(return)F(FREturn) +AEQU WANG(ANTE " " PHI " " PSI,CONSEQ) /F(FRETURN) + WANG(ANTE,CONSEQ " " PHI " " PSI) /S(RETURN)F(FRETURN) - -cnot wang(ante " " phi,conseq) /s(return)f(freturn) +CNOT WANG(ANTE " " PHI,CONSEQ) /S(RETURN)F(FRETURN) - -cand wang(ante,conseq " " phi) /f(freturn) - wang(ante,conseq " " psi) /s(return)f(freturn) +CAND WANG(ANTE,CONSEQ " " PHI) /F(FRETURN) + WANG(ANTE,CONSEQ " " PSI) /S(RETURN)F(FRETURN) - -cor wang(ante,conseq " " phi " " psi) /s(return)F(FRETURN) +COR WANG(ANTE,CONSEQ " " PHI " " PSI) /S(RETURN)F(FRETURN) - -CIMP WANG(ANTE " " PHI,CONSEQ " " PSI) /s(return)f(freturn) +CIMP WANG(ANTE " " PHI,CONSEQ " " PSI) /S(RETURN)F(FRETURN) - -cequ wang(ante " " phi,conseq " " psi) /f(freturn) - wang(ante " " psi,conseq " " phi) /s(RETURN)f(freturn) -end -imp(not(or(p,q)),not(p)) -imp(and(not(p),not(q)),equ(p,q)) -imp(imp(OR(P,Q),or(p,r)),OR(P,imp(q,r))) -stop -?end -?execute snobol/disk -?file print = print back up disk -?common=3 -?data program --list +CEQU WANG(ANTE " " PHI,CONSEQ " " PSI) /F(FRETURN) + WANG(ANTE " " PSI,CONSEQ " " PHI) /S(RETURN)F(FRETURN) +END +IMP(NOT(OR(P,Q)),NOT(P)) +IMP(AND(NOT(P),NOT(Q)),EQU(P,Q)) +IMP(IMP(OR(P,Q),OR(P,R)),OR(P,IMP(Q,R))) +STOP +?END +?EXECUTE SNOBOL/DISK +?FILE PRINT = PRINT BACK UP DISK +?COMMON=3 +?DATA PROGRAM +-LIST * BLANK IS A CONCATENATION OPERATOR! FIRST = "HORACE" SECOND = "GREELEY" NAME = FIRST " " SECOND SYSPOT = NAME - INT = 12 div 2 * 3 + INT = 12 DIV 2 * 3 * MULTIPLICATION HAS HIGHER PRECEDENCE THAN DIVISION * ARITHMETIC HAS HIGHER PRECENCE THAN CONCATENATION SYSPOT = "12 / 2 * 3 = " INT @@ -174,208 +174,208 @@ LOOP STUFF "CAT" = "DOG" /S(LOOP) END THE CAT JUMPED OVER THE DOG. THE DOG JUMPED OVER THE CAT. -?end -?execute snobol/disk -?file print = print back up disk -?common=3 -?data program --list +?END +?EXECUTE SNOBOL/DISK +?FILE PRINT = PRINT BACK UP DISK +?COMMON=3 +?DATA PROGRAM +-LIST * ID START * DATA -READ LINE = SYSPIT - LINE "STOP" /S(QUIT) - NLINE = LINE - NLINE *LAST* "," *FIRST* "-" *TITLE* - AUTHOR = FIRST " " LAST - TITLE = " " TITLE " " - TITLE " THE " = " " - TITLE " A " = " " - TITLE " AN " = " " - STITLE = TITLE -DEBLANK TITLE " " = " " /S(DEBLANK) -LOOP TITLE " " = "," /S(LOOP) - TITLE *FIRSTCHAR/"1"* = - WORDLIST = WORDLIST TITLE - SYSPOT = LINE - SYSPOT = AUTHOR "-" STITLE - SYSPOT = TITLE "$" WORDLIST - /(READ) -QUIT SIZE = "14" -REDEFINE ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789. " -DECR SIZE = SIZE - "1" - SIZE "-" /S(DONE) -BACK WORDLIST *WORD* "," = /F(LAST) - WORD *HEAD/SIZE* *PIT/"1"* /F(ALL) - $PIT = $PIT WORD "," /(BACK) -ALL BIN = BIN WORD "," /(BACK) -LAST BIN *WORDLIST* = -AGAIN ALPHABET *PIT/"1"* = /F(REDEFINE) - WORDLIST = WORDLIST $PIT - $PIT = /(AGAIN) -DONE SYSPOT = "WORDLIST" WORDLIST -END READ -STURGEON,THEODORE-MORE THAN HUMAN -SMITH,E.E.-GRAY LENSMAN -SMITH,E.E.-TRIPLANETARY -RAGAN,RICHARD-TEST THE PROGRAM +READ LINE = SYSPIT + LINE "STOP" /S(QUIT) + NLINE = LINE + NLINE *LAST* "," *FIRST* "-" *TITLE* + AUTHOR = FIRST " " LAST + TITLE = " " TITLE " " + TITLE " THE " = " " + TITLE " A " = " " + TITLE " AN " = " " + STITLE = TITLE +DEBLANK TITLE " " = " " /S(DEBLANK) +LOOP TITLE " " = "," /S(LOOP) + TITLE *FIRSTCHAR/"1"* = + WORDLIST = WORDLIST TITLE + SYSPOT = LINE + SYSPOT = AUTHOR "-" STITLE + SYSPOT = TITLE "$" WORDLIST + /(READ) +QUIT SIZE = "14" +REDEFINE ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789. " +DECR SIZE = SIZE - "1" + SIZE "-" /S(DONE) +BACK WORDLIST *WORD* "," = /F(LAST) + WORD *HEAD/SIZE* *PIT/"1"* /F(ALL) + $PIT = $PIT WORD "," /(BACK) +ALL BIN = BIN WORD "," /(BACK) +LAST BIN *WORDLIST* = +AGAIN ALPHABET *PIT/"1"* = /F(REDEFINE) + WORDLIST = WORDLIST $PIT + $PIT = /(AGAIN) +DONE SYSPOT = "WORDLIST" WORDLIST +END READ +STURGEON,THEODORE-MORE THAN HUMAN +SMITH,E.E.-GRAY LENSMAN +SMITH,E.E.-TRIPLANETARY +RAGAN,RICHARD-TEST THE PROGRAM STOP -?end -?execute snobol/disk -?file print = print back up disk -?common=3 -?data program --list - DEFINE("PERM(NAME,RENAME)","ENT") -READ1 CARD1 = SYSPIT - CARD1 "STOP" /S(END) - CARD2 = SYSPIT - CARD1 *NUMCOD1/"6"* = - CARD2 *NUMCOD2/"4"* = - CARD1 *Y/"2"* = - CARD2 *Y/"4"* = - EQUALS(CARD1,CARD2) /S(SAME) - NUM1 = PERM(CARD1,"FIRST") - NUM2 = PERM(CARD2,"LAST") - .EQ(NUM1,NUM2) /S(ASET) - .LT(NUM1,NUM2) /S(FILL1)F(FILL2) -FILL1 A = NUM1 -ADD A = A + "1" - $("FIRST" A ) = - .EQ(A,NUM2) /F(ADD)S(CONT) -FILL2 A = NUM2 -INCR A = A + "1" - $("LAST" A) = - .EQ(A,NUM1) /F(INCR)S(CONT) -ASET A = NUM1 -CONT COUNT = "0" -MORE COUNT = COUNT + "1" - SYSPOT = NUMCOD1 " " NUMCOD2 " " $("FIRST" COUNT) - SYSPOT = NUMCOD1 " " NUMCOD2 " " $("LAST" COUNT) - .EQ(COUNT,A) /F(MORE)S(READ1) -SAME SYSPOT = NUMCOD1 " " NUMCOD2 " " CARD1 /(READ1) -ENT NAME = TRIM(NAME) " " -DEBLANK NAME " " = " " /S(DEBLANK) - NAME *WORD1* " " = - NAME = NAME "$" WORD1 " " - PERM = "0" -LOOP PERM = PERM + "1" - NAME *WORD* " " = - NAME = NAME WORD " " - NAME ANCHOR(X) "$" = /S(RETURN) - $(RENAME PERM ) = NAME -CLEAN $(RENAME PERM ) "$" = /S(CLEAN)F(LOOP) -END -STURGEON,THEODORE-MORE THAN HUMAN -SMITH,E.E.-GRAY LENSMAN -SMITH,E.E.-TRIPLANETARY -RAGAN,RICHARD-TEST THE PROGRAM +?END +?EXECUTE SNOBOL/DISK +?FILE PRINT = PRINT BACK UP DISK +?COMMON=3 +?DATA PROGRAM +-LIST + DEFINE("PERM(NAME,RENAME)","ENT") +READ1 CARD1 = SYSPIT + CARD1 "STOP" /S(END) + CARD2 = SYSPIT + CARD1 *NUMCOD1/"6"* = + CARD2 *NUMCOD2/"4"* = + CARD1 *Y/"2"* = + CARD2 *Y/"4"* = + EQUALS(CARD1,CARD2) /S(SAME) + NUM1 = PERM(CARD1,"FIRST") + NUM2 = PERM(CARD2,"LAST") + .EQ(NUM1,NUM2) /S(ASET) + .LT(NUM1,NUM2) /S(FILL1)F(FILL2) +FILL1 A = NUM1 +ADD A = A + "1" + $("FIRST" A ) = + .EQ(A,NUM2) /F(ADD)S(CONT) +FILL2 A = NUM2 +INCR A = A + "1" + $("LAST" A) = + .EQ(A,NUM1) /F(INCR)S(CONT) +ASET A = NUM1 +CONT COUNT = "0" +MORE COUNT = COUNT + "1" + SYSPOT = NUMCOD1 " " NUMCOD2 " " $("FIRST" COUNT) + SYSPOT = NUMCOD1 " " NUMCOD2 " " $("LAST" COUNT) + .EQ(COUNT,A) /F(MORE)S(READ1) +SAME SYSPOT = NUMCOD1 " " NUMCOD2 " " CARD1 /(READ1) +ENT NAME = TRIM(NAME) " " +DEBLANK NAME " " = " " /S(DEBLANK) + NAME *WORD1* " " = + NAME = NAME "$" WORD1 " " + PERM = "0" +LOOP PERM = PERM + "1" + NAME *WORD* " " = + NAME = NAME WORD " " + NAME ANCHOR(X) "$" = /S(RETURN) + $(RENAME PERM ) = NAME +CLEAN $(RENAME PERM ) "$" = /S(CLEAN)F(LOOP) +END +STURGEON,THEODORE-MORE THAN HUMAN +SMITH,E.E.-GRAY LENSMAN +SMITH,E.E.-TRIPLANETARY +RAGAN,RICHARD-TEST THE PROGRAM STOP -?end -?execute snobol/disk -?file print = print back up disk -?common=3 -?data program --list -- TITLE PROCESS S A T AND 1 2 T H G R A D E CARDS. -* THIS PROGRAM TAKES AN SAT CARD AND A 12TH GRADE SCHOOL CARD -* AND ATTEMPTS TO GENERATE A SINGLE CARD COMBINING THE -* INFORMATION ON BOTH OF THESE. IN PARTICULAR THE PROGRAM -* SEARCHES OUT THE BEST SCHOOL NAME FROM THE TWO CARDS. -* WHEN A MATCH IS NOT OBTAINED MULTIPLE CARDS ARE GENERATED -* CONTAINING CYCLIC PERMUTATIONS OF THE SCHOOL NAME FROM -* BOTH CARDS. THE CHOICE OF THE ADDRESS CARD TO BE USED -* IS LEFT TO THE DISCRETION OF THE USER. IN GENERAL -* ONLY ONE CARD WILL BE GENERATED SINCE CERTAIN KEYWORDS -* SUCH AS "HIGH" , "SCHOOL", "HS", "H S" ARE ELIMINATED -* FROM THE TEXT BEFORE COMPARISON OF SCHOOL NAMES IS -* ATTEMPTED. THIS RESULTS IN A MUCH HIGHER PERCENTAGE OF -* MATCHES THAN WOULD OTHERWISE BE OBTAINED. -* -* RICHARD RAGAN -* FSU COMPUTING CNTR. -* 5-1-66 - DEFINE("EXCERPT(STRING,WORD1,WORD2)","ENTRY") - DEFINE("PERM(NAME,RENAME)","ENT") - DEFINE("HSGET(SNAME,SLOC)","Z") - DEFINE("RESTOR(QUAL,QUAN)","104") - BLANK = " " -READ SAT = SYSPIT - SAT "STOP" /S(END) - 12TH = SYSPIT - 12TH *12CODE/"4"* *FILLER/"3"* *12NAME/"27"* *COUNTY/"4"* -. *FILLER/"3"* *CTYCODE/"2"* *FILLER/"3"* *12LOC* - SAT *FILLER/"2"* *SATCODE/"4"* *FILLER/"2"* *SATNAME/"21"* -. *FILLER/"22"* *SATLOC* - 12NAME = TRIM(12NAME) " " - SATNAME = TRIM(SATNAME) " " -DEMIN 12NAME "-" = " " /S(DEMIN) -DEMINUS SATNAME "-" = " " /S(DEMINUS) - SATNAME = HSGET(SATNAME,12LOC) - S12NAME = 12NAME - SSATNAME = SATNAME - 12NAME = EXCERPT(12NAME," SCHOOL "," SCH ") - 12NAME = EXCERPT(12NAME," H "," S ") - 12NAME = EXCERPT(12NAME," HS "," HIGH ") - SATNAME = EXCERPT(SATNAME," SCHOOL "," SCH ") - SATNAME = EXCERPT(SATNAME," H "," S ") - SATNAME = EXCERPT(SATNAME," HS "," HIGH ") - 12NAME = EXCERPT(12NAME," SR "," JR ") - SATNAME = EXCERPT(SATNAME," SR "," JR ") - EQUALS(12NAME,SATNAME) /S(LUCK) - OFF = RESTOR(12NAME,S12NAME) - ON = RESTOR(SATNAME,SSATNAME) - P12 = PERM(12NAME,"12.") - PSAT = PERM(SATNAME,"SAT.") - COUNT = "0" -MORE COUNT = COUNT + "1" - ALL = $("12." COUNT) OFF - ALL = ALL BLANK - ALL *FIXFLD/"27"* - SYSPPT = 12CODE SATCODE CTYCODE COUNTY FIXFLD TRIM(12LOC) - .EQ(P12,COUNT) /F(MORE) - COUNT = "0" -AGAIN COUNT = COUNT + "1" - NONE = $("SAT." COUNT) ON - NONE = NONE BLANK - NONE *FLD/"27"* - SYSPPT = 12CODE SATCODE CTYCODE COUNTY FLD TRIM(12LOC) - .EQ(PSAT,COUNT) /F(AGAIN)S(READ) -LUCK .GE(SIZE(S12NAME),SIZE(SSATNAME)) /S(S12)F(SSAT) -S12 S12NAME = S12NAME BLANK - S12NAME *SAVE/"27"* - SYSPPT = 12CODE SATCODE CTYCODE COUNTY SAVE TRIM(12LOC) -. /(READ) -SSAT SSATNAME = SSATNAME BLANK - SSATNAME *KEEP/"27"* - SYSPPT = 12CODE SATCODE CTYCODE COUNTY KEEP TRIM(12LOC) -. /(READ) -- EJECT -ENTRY STRING WORD1 = " " - STRING WORD2 = " " - EXCERPT = STRING /(RETURN) -- EJECT -Z SNAME ANCHOR(X) "HIGH SCHOOL" /F(FRETURN) - SLOC *TNAME* "FLORIDA" /S(ROTAT) - SLOC *TNAME* "FLA" /F(FRETURN) -ROTAT HSGET = TNAME SNAME /(RETURN) -- EJECT -ENT NAME = TRIM(NAME) " " - PERM = "1" -DEBLANK NAME " " = " " /S(DEBLANK) - $(RENAME PERM) = NAME - NAME *WORD1* " " = - NAME = NAME "$" WORD1 " " - NAME ANCHOR(X) "$" = /S(RETURN) -LOOP PERM = PERM + "1" - $(RENAME PERM) = NAME - NAME *WORD* " " = - NAME ANCHOR(X) "$" = /S(OKAY) - NAME = NAME WORD " " -CLEAN $(RENAME PERM) "$" = /S(CLEAN) -BL $(RENAME PERM) " " = " " /S(BL)F(LOOP) -OKAY $(RENAME PERM) "$" = /(RETURN) -- EJECT -104 QUAN QUAL *CODE* - RESTOR = TRIM(CODE) " " /(RETURN) -END -?end +?END +?EXECUTE SNOBOL/DISK +?FILE PRINT = PRINT BACK UP DISK +?COMMON=3 +?DATA PROGRAM +-LIST +- TITLE PROCESS S A T AND 1 2 T H G R A D E CARDS. +* THIS PROGRAM TAKES AN SAT CARD AND A 12TH GRADE SCHOOL CARD +* AND ATTEMPTS TO GENERATE A SINGLE CARD COMBINING THE +* INFORMATION ON BOTH OF THESE. IN PARTICULAR THE PROGRAM +* SEARCHES OUT THE BEST SCHOOL NAME FROM THE TWO CARDS. +* WHEN A MATCH IS NOT OBTAINED MULTIPLE CARDS ARE GENERATED +* CONTAINING CYCLIC PERMUTATIONS OF THE SCHOOL NAME FROM +* BOTH CARDS. THE CHOICE OF THE ADDRESS CARD TO BE USED +* IS LEFT TO THE DISCRETION OF THE USER. IN GENERAL +* ONLY ONE CARD WILL BE GENERATED SINCE CERTAIN KEYWORDS +* SUCH AS "HIGH" , "SCHOOL", "HS", "H S" ARE ELIMINATED +* FROM THE TEXT BEFORE COMPARISON OF SCHOOL NAMES IS +* ATTEMPTED. THIS RESULTS IN A MUCH HIGHER PERCENTAGE OF +* MATCHES THAN WOULD OTHERWISE BE OBTAINED. +* +* RICHARD RAGAN +* FSU COMPUTING CNTR. +* 5-1-66 + DEFINE("EXCERPT(STRING,WORD1,WORD2)","ENTRY") + DEFINE("PERM(NAME,RENAME)","ENT") + DEFINE("HSGET(SNAME,SLOC)","Z") + DEFINE("RESTOR(QUAL,QUAN)","104") + BLANK = " " +READ SAT = SYSPIT + SAT "STOP" /S(END) + 12TH = SYSPIT + 12TH *12CODE/"4"* *FILLER/"3"* *12NAME/"27"* *COUNTY/"4"* +. *FILLER/"3"* *CTYCODE/"2"* *FILLER/"3"* *12LOC* + SAT *FILLER/"2"* *SATCODE/"4"* *FILLER/"2"* *SATNAME/"21"* +. *FILLER/"22"* *SATLOC* + 12NAME = TRIM(12NAME) " " + SATNAME = TRIM(SATNAME) " " +DEMIN 12NAME "-" = " " /S(DEMIN) +DEMINUS SATNAME "-" = " " /S(DEMINUS) + SATNAME = HSGET(SATNAME,12LOC) + S12NAME = 12NAME + SSATNAME = SATNAME + 12NAME = EXCERPT(12NAME," SCHOOL "," SCH ") + 12NAME = EXCERPT(12NAME," H "," S ") + 12NAME = EXCERPT(12NAME," HS "," HIGH ") + SATNAME = EXCERPT(SATNAME," SCHOOL "," SCH ") + SATNAME = EXCERPT(SATNAME," H "," S ") + SATNAME = EXCERPT(SATNAME," HS "," HIGH ") + 12NAME = EXCERPT(12NAME," SR "," JR ") + SATNAME = EXCERPT(SATNAME," SR "," JR ") + EQUALS(12NAME,SATNAME) /S(LUCK) + OFF = RESTOR(12NAME,S12NAME) + ON = RESTOR(SATNAME,SSATNAME) + P12 = PERM(12NAME,"12.") + PSAT = PERM(SATNAME,"SAT.") + COUNT = "0" +MORE COUNT = COUNT + "1" + ALL = $("12." COUNT) OFF + ALL = ALL BLANK + ALL *FIXFLD/"27"* + SYSPPT = 12CODE SATCODE CTYCODE COUNTY FIXFLD TRIM(12LOC) + .EQ(P12,COUNT) /F(MORE) + COUNT = "0" +AGAIN COUNT = COUNT + "1" + NONE = $("SAT." COUNT) ON + NONE = NONE BLANK + NONE *FLD/"27"* + SYSPPT = 12CODE SATCODE CTYCODE COUNTY FLD TRIM(12LOC) + .EQ(PSAT,COUNT) /F(AGAIN)S(READ) +LUCK .GE(SIZE(S12NAME),SIZE(SSATNAME)) /S(S12)F(SSAT) +S12 S12NAME = S12NAME BLANK + S12NAME *SAVE/"27"* + SYSPPT = 12CODE SATCODE CTYCODE COUNTY SAVE TRIM(12LOC) +. /(READ) +SSAT SSATNAME = SSATNAME BLANK + SSATNAME *KEEP/"27"* + SYSPPT = 12CODE SATCODE CTYCODE COUNTY KEEP TRIM(12LOC) +. /(READ) +- EJECT +ENTRY STRING WORD1 = " " + STRING WORD2 = " " + EXCERPT = STRING /(RETURN) +- EJECT +Z SNAME ANCHOR(X) "HIGH SCHOOL" /F(FRETURN) + SLOC *TNAME* "FLORIDA" /S(ROTAT) + SLOC *TNAME* "FLA" /F(FRETURN) +ROTAT HSGET = TNAME SNAME /(RETURN) +- EJECT +ENT NAME = TRIM(NAME) " " + PERM = "1" +DEBLANK NAME " " = " " /S(DEBLANK) + $(RENAME PERM) = NAME + NAME *WORD1* " " = + NAME = NAME "$" WORD1 " " + NAME ANCHOR(X) "$" = /S(RETURN) +LOOP PERM = PERM + "1" + $(RENAME PERM) = NAME + NAME *WORD* " " = + NAME ANCHOR(X) "$" = /S(OKAY) + NAME = NAME WORD " " +CLEAN $(RENAME PERM) "$" = /S(CLEAN) +BL $(RENAME PERM) " " = " " /S(BL)F(LOOP) +OKAY $(RENAME PERM) "$" = /(RETURN) +- EJECT +104 QUAN QUAL *CODE* + RESTOR = TRIM(CODE) " " /(RETURN) +END +?END diff --git a/SNOBOL-UW-Chambers/SYMBOL.SNOBOL.alg_m b/SNOBOL-UW-Chambers/SYMBOL.SNOBOL.alg_m index abc88e1..d1a87e5 100644 --- a/SNOBOL-UW-Chambers/SYMBOL.SNOBOL.alg_m +++ b/SNOBOL-UW-Chambers/SYMBOL.SNOBOL.alg_m @@ -1,7794 +1,7789 @@ -?execute object/reader -?common = 3 -?file newtape = symbol/snobol disk serial -?data card -% $reset list 10000 -% b5500 snobol3 system. 20000 -% 30000 -% written by: 40000 -% john m. chambers 50000 -% dept. of computer sciences 60000 -% univerity of wisconsin 70000 -% 1210 w. dayton st. 80000 -% madison, wisconsin 53706 90000 -% 100000 -% users manual available from above address. 110000 -% 120000 -% 130000 -% data representation: 140000 -% 150000 -% to take advantage of the character mode string compare and move 160000 -% instructions, strings are stored as consecutive chars, preceeded by a 170000 -% 3-char back-pointer to the symbol table. this pointer consists of an 180000 -% "illegal character" followed by 2 chars (12bit) giving a symbol 190000 -% table location (see description of symbtabl). strings are stored in 200000 -% rows of the array data[*,*]. 210000 -% 220000 -% 230000 -% due to the size limitation on algol arrays, and the fact that it 240000 -% was felt undesirable to break up a string, there is a limitation to 250000 -% the size of a string--8181 chars, to be exact. if this limit is 260000 -% exceeded, the procedure string will print a diagnostic and set the 270000 -% flag death to true, terminating the program. 280000 -% a string is identified by a 31-bit "descriptor"; if d is such a 290000 -% descriptor, the following fields locate the string (see define 300000 -% declarations): 310000 -% d.s: size of string 320000 -% d.r: string is in data[d.r,*] 330000 -% d.ch: first char of string, relative to data[d.r,0] 340000 -% in other words, the string consists of d.s characters, starting d.c 350000 -% charsafter data[d.r,d.w]. 360000 -% note that, since all strings are preceded by a 3-char pointer 370000 -% to symbtabl, the value of the ch field must be } 3, this fact 380000 -% is used to distinguish cells which have "missing" values (such 390000 -% as the value parts for strings which have not been assigned a 400000 -% value). thus, if the ch field is < 3, there is no string attached, 410000 -% and the value is considered to be null. the s field should be 0 420000 -% in such cases. 430000 -% several "bugs" have been found to be caused by not recognizing 440000 -% that a string descriptor may not pointto a string--this can be 450000 -% avoided by testing to see if the ch field is } 3. if so, the 460000 -% string exists; if not, there is no string, and the value is null. 470000 -% 480000 -% 490000 -% 500000 -% 510000 -%*********************************************************************** 520000 -begin 530000 -integer common; % these bits are currently relevant: 540000 - % [47:1] = 1 turns of tracing for all variables. 550000 - % [46:1] = 1 causes a complete dump at the end of run. 560000 - % [45:1] = 1 says that mode("inform") op -inform is to turn on 570000 - % system debugging aids. 580000 -define 590000 - c=[45:3]#, % char with in word of string descriptor 600000 - c1=[6:6]#, 610000 - c2=[12:6]#, 620000 - c3=[18:6]#, 630000 - c4=[24:6]#, 640000 - c5=[30:6]#, 650000 - c6=[36:6]#, 660000 - c7=[42:6]#, 670000 - ch=[35:13]#, % char of data[*,*] row of string descriptor 680000 - cquote4="""[24:42:6]#, % move quote to char 4 690000 - cquote5="""[30:42:6]#, % move quote to char 5 700000 - concr=[30:43:5]#, % move to r field 710000 - concs=[17:35:13]#, % move to s field 720000 - concw=[35:38:10]#, % move to w field 730000 - controlpoint=inst[instruct],nearpoint#, 740000 - datasize=31#, % upper bound on first subscript of data[*,*] 750000 - diskrecord=record#, 760000 - f= false #, 770000 - firstchar(firstchar1)=data[(firstchar1).r,(firstchar1).w], 780000 - (firstchar1).c#, 790000 - intrinsmax=17#, % max # intrinsic fcts of same size 800000 - maxlabellimit=15#, % max number of label limits for debugging 810000 - maxlevel=100#, % maximum allowed depth of function calls 820000 - maxsuspendreason=3#, % number different reasons for suspending. 830000 - mnemmax=20#, 840000 - numcontrolcards=21#, % number of control cards implemented; 850000 - % must be changed if new control cards are 860000 - % to be implemented 870000 - r=[30:5]#, % data[*,*] row of string descriptor 880000 - rch=[30:18]#, % r, w, and c fields 890000 - s=[17:13]#, % size of string 900000 - segment = label dummy;#, % for forcing new segment. 910000 - stacksize=50#, % size of interpreter stack arrays 920000 - stringloc(stringloc1)=(stringloc1).s,firstchar(stringloc1)#, 930000 - t= true #, 940000 - temp=aa#, % 950000 - temp1=ab#, % 960000 - temp2=ac#, % 970000 - tempcel(tempcel1) = tempcell#, % parameterno longer use 980000 - version = 3.0#, % version number: 990000 - % 2.0 is the rewrittencompiler. 1000000 - % 2.1 includes fatal error suspensions when debugging. 1010000 - % 2.2 has most system debugging aids changed to comments. 1020000 - % 3.0 has the array usedcell[*] deleted (changes library files). 1030000 - w=[35:10]#; % word within data[*,*] row of string descriptor 1040000 -define 1050000 - abort = go to abortion;#, % fatal system error. 1060000 - setlimitflag = alimitexists ~ 1070000 - cpulimitexists or 1080000 - iolimitexists or 1090000 - rulelimitexists or 1100000 - (debugging and 1110000 - (debugrulelimitexists or 1120000 - nlabellimit } 0 1130000 - ) 1140000 - ) 1150000 - #; 1160000 -boolean 1170000 - alimitexists, % there is a limit to check at start of insts. 1180000 - b1, % temorary boolean "register" 1190000 - convertf, % deck is 026 char set 1200000 - convertstrings, % convert 3600 i/o strings 1210000 - cpulimitexists, % 1220000 - datacomf, % data com unit in use 1230000 - death, % fatal error has occurred 1240000 - debugging, % debug mode in use 1250000 - debugrulelimitexists, 1260000 - dmpdata, % execute writedata at end of run 1270000 - dmpst, % execute writest (dump symbol table) at end of run 1280000 - dmpstr, % execute stringdump at end of run 1290000 - dumpall, % true if complete dump to be done at eoj 1300000 - errdump, % dump if fatal program error 1310000 - execute, % set false if fatal error during compilation 1320000 - inform, % print system debugging messages 1330000 - iolimitexists, % 1340000 - loadf, % loader is being executed 1350000 - printmessages, % print diagnostic (warning) messages. 1360000 - result, % success/fail flag for interpreter 1370000 - rulelimitexists,% 1380000 - systemdebugging,% true if common.[45:1] = 1 1390000 - systemerror, % fatal error by snobol system, not program 1400000 - traceall; % trace every variable without i/o use 1410000 -boolean array 1420000 - suspendreason[0:maxsuspendreason], % reasons for suspending program: 1430000 - % 0: suspend() was executed 1440000 - % 1: rule limit was hit 1450000 - % 2: label limit was hit 1460000 - % 3: fatal error in program 1470000 - usedrow[0:datasize]; % data[i,*] is in use 1480000 -integer 1490000 - anchormode, % 2: unanchored, 3: anchored 1500000 - anchorsize, % for anchored mode, size of inital segment 1510000 - dcsize, % size of last input from dcread 1520000 - debugrulelimit, 1530000 - dividemode, % 0: round; 1: truncation; 2: integer 1540000 - gcs, % number of garbage collector calls 1550000 - i, 1560000 - i1, i2, % temporary integer "registers". 1570000 - j, 1580000 - level, % level (or depth) of recursion of the interpreter 1590000 - listspaces, % number of blank lines between lines of listing 1600000 - loaderlevel, % level of recursion in loader 1610000 - maxinstsize, % size of largest program segment (in chars) 1620000 - nlabellimit, % number of label limits set at last suspension 1630000 - parencount, % depth of parenthesis nesting (compile and scan) 1640000 - rw, % new strings come from data[rw,*] (see string) 1650000 - temprow, % row of symb table giving temp cells 1660000 - unit; % used by i/o routines--file number 1670000 -integer array 1680000 - convertval, % for char set conversions 1690000 - dottype, % partitions chars in internal rep. of arith, 1700000 - oplevel[0:63], % precedence level of arith ops 1710000 - dpntr, % pointer to next available char in data[i,*] 1720000 - notmoved[0:datasize], % points to first char moved by last call 1730000 - % of garbage collector. 1740000 - months[1:12], % number of days in each month 1750000 - rules[0:maxlevel]; % # rules executed at various levels 1760000 -real 1770000 - cpulimit, % limit to cpu time in seconds. 1780000 - gctimecp, % cpu time spend collecting garbage 1790000 - gctimeio, % i/o time spend collecting garbage 1800000 - iolimit, % limit to i/o time in seconds. 1810000 - randno, % number for .randf function 1820000 - rulelimit, % limit to number of rules executed, 1830000 - teenyneg; % = oct3777777777777777 1840000 -alpha 1850000 - aa,ab,ac, % temporary alpha "registers" 1860000 - arrow, % = "~" 1870000 - blank, % = " " 1880000 - blanks, % = " " (8 blanks) 1890000 - colon, % = ":" 1900000 - comma, % = "," 1910000 - crlf, % = "{!~" 1920000 - eqsign, % = "=" 1930000 - qmark, % illegal char 1940000 - quote, % = """ 1950000 - printloc, % symbol table location of print (see code 1960000 - % for syspot in snblout.) 1970000 - slash, % = "/" 1980000 - star, % = "*" 1990000 - stopper; % = blank & quote & qmark (for ending scans.) 2000000 -alpha array 2010000 - buffer[0:14], % used by compiler to hold next input card 2020000 - bufout[0:16], % for building printer output messages. 2030000 - code[0:1022], 2040000 - controlcard[0:numcontrolcards], % names of control cards 2050000 - data[0:datasize,0:1022], % string and program storage area 2060000 - intrinsfct[3:7,0:intrinsmax], % names of intrinsic function. 2070000 - intrinsndx[3:7,1:intrinsmax], % indices of intrinsic functions. 2080000 - labellimit[0:maxlabellimit], % symbol table locations of 2090000 - % label limits during debugging 2100000 - mnemonic[0:1,0:mnemmax], % various mnemonic commands and words 2110000 - nextrecord[0:15,0:17], % holds records for look-type strings 2120000 - scratch[0:1022], % temporary string array 2130000 - words[0:30]; % variousalphanumeric strings 2140000 -monitor intovr, expovr, index, flag; 2150000 -%********symbol table*************************************************** 2160000 -% 2170000 -% the symbol table: 2180000 -% 2190000 -% 2200000 -% every data object (strings, literal, function, label) requires 2210000 -% an entry in the symbol table. this table consists of the following 2220000 -% three array and associated macros: 2230000 -% 2240000 -define 2250000 - name[name1] = namtabl[(name1).str,(name1).stw] #, 2260000 - valu[valu1] = valtabl[(valu1).str,(valu1).stw] #, 2270000 - io[io1] = iotabl[(io1).str,(io1).stw] #, 2280000 - strmax = 15 #, % max first subscript to symb table. 2290000 - stwmax = 255 #; % max second subscript to symb table. 2300000 -alpha array 2310000 - namtabl, 2320000 - valtabl, 2330000 - iotabl[0:strmax,0:stwmax]; 2340000 -% 2350000 -% some more variables associated with the symbol table are: 2360000 -% 2370000 -define 2380000 - ccycle=[9:44:4]#, % move to cycle field 2390000 - cfilno=[5:44:4]#, % move to filno field 2400000 - cinuse=[3:47:1]#, % 2410000 - ciotype=[14:45:3]#, % move to iotype field 2420000 - ciouse=[3:46:2]#, 2430000 - clink=[5:36:12]#, % move to link field 2440000 - concstr = [36:44:4] #, 2450000 - coutus=[4:47:1]#, % 2460000 - cycle=[9:4]#, % number times file location used 2470000 - filno=[5:4]#, % index of associated file 2480000 - inuse=[3:1]#, % = 1 if input string 2490000 - iotype=[14:3]#, % type of i/o usage: 2500000 - % value input output 2510000 - % 0 illegal illegal 2520000 - % 1 i/o i/o 2530000 - % 2 look trace 2540000 - % 3 teletype teletype 2550000 - % 4 illegal illegal 2560000 - % 5 illegal syspot 2570000 - % 2580000 - iouse=[3:2]#, % inuse and outuse fields combined. 2590000 - link=[5:12]#, % list links in symbol table. 2600000 - loc=[17:31]#, % s, r, w, and c fields (string loc in data[*,*]) 2610000 - outuse=[4:1]#, % = 1 if output string 2620000 - ovfl=[13:1]#, % = 1 if overlfow allowed on output 2630000 - scattersize=75#,% size of scatter areas in symb table. 2640000 - str = [36:4] #, 2650000 - stw = [40:8] #, 2660000 - tcycle=[9:9:4]#,% transfer to cycle field 2670000 - tfilno=[5:5:4]#,% transfer to filno field 2680000 - type=[1:2]#; % type of entry: 2690000 - % 0 = string 2 = function 2700000 - % 1 = literal 3 = label 2710000 -boolean 2720000 - symbtablsetup; % avsls set up in scatter rows. 2730000 -boolean array 2740000 - usedst[0:strmax]; % true if symb table row in use. 2750000 -integer 2760000 - scatterno; % max row index of scatter areas. 2770000 -alpha array 2780000 - templist[0:strmax]; % temp s.t. locs for interpreter. 2790000 -integer array 2800000 - nextcell[0:strmax]; % heads of available space lists. 2810000 -% 2820000 -% 2830000 -% a symbol table entry consists of three words--one word 2840000 -% from each of the tree arrays. a "symbol table address" is a 2850000 -% 12-bit integer consisting of two fields called str and stw. 2860000 -% the three words associated with an address p can be referred 2870000 -% to in the following ways: 2880000 -% 2890000 -% name[p] = namtabl[p.str,p.stw] is the name of the object 2900000 -% valu[p] = valtabl[p.str,p.stw] is the value of the object. 2910000 -% io[p] = iotabl[p.str,p.stw] is the i/o use of the object 2920000 -% 2930000 -% normally, the first form giving (singly subscripted) is used; the 2940000 -% doubly-subscripted forms are used only when the two subscripts 2950000 -% have been calculated separately. 2960000 -% 2970000 -% the symbol table is a scattered-entry, linked-list type of table. 2980000 -% entries are scattered into the "scatter areas", which are words 0 to 2990000 -% scattersize+15 of rows 0 to scatterno. that is, the i,j words 3000000 -% of the symbol table (namtabl[i,j], valtabl[i,j], iotable[i,j]) 3010000 -% are in the scatter area if: 3020000 -% 0 { i { scatterno 3030000 -% 0 { j { scattersize+15 3040000 -% word 0,0 is not included; it is a "non-cell" which should always 3050000 -% be filled with zeroes. the reason for the "+15" is that there 3060000 -% are really two scatter areas--one for literals and one for all 3070000 -% other types of data objects. this is to keep the length of 3080000 -% lists that must be scanned at run time (for indirection, creating 3090000 -% new functions, etc,) as small as possible. literals are scattered 3100000 -% into the [scattersize,scattersize+15] part of each row, and the 3110000 -% [0,scattersize) part is for other types of objects. the part 3120000 -% of the symbol table outside of the scatter areas is initialized 3130000 -% as available space lists (one per row. the top address given by 3140000 -% nextcell[row]). when several entries scatter into the same 3150000 -% location, a linked list is formed into the part of the row that 3160000 -% is outside the scatter area. links through these lists are in 3170000 -% the link field of the name part (name[p]). 3180000 -% 3190000 -% the following fields are used in a symbol table entry: 3200000 -% name[p].type is the type of the entry: 3210000 -% 0 = named string or temporary cell. 3220000 -% 1 = literal 3230000 -% 2 = function 3240000 -% 3 = label (code segment) 3250000 -% name[p] and garbage collector.[3:1] is used by checksymbtabl. 3260000 -% name[p].[4:1] is unused. 3270000 -% name[p].link is the link to the next entry that had the same 3280000 -% location in the scatter area. a zero link is end-of-list. 3290000 -% for temporary cells, the link should be zero. 3300000 -% name[p].loc points to the name of the object (in data[*,*]), 3310000 -% for literals, this field is zero. 3320000 -% valu[p].[1:1] = 1 for progrma-defioned functions, otherwise 3330000 -% it should be zero. 3340000 -% valu[p].[2:1] is unused. 3350000 -% valu[p].iouse indicates the i/o use, and has two subfields: 3360000 -% valu[p].inuse = 1 for input strings and functions with 3370000 -% the calles being traced. 3380000 -% valu[p].outuse = 1 for output strings, labels being traced, 3390000 -% and functions with returns being traced. 3400000 -% valu[p].link has several uses, depending on the type of the object: 3410000 -% strings: the link field gives the next cell on the push-down 3420000 -% stack. if zero, there is no push-down stack. 3430000 -% intrinsic functions: the index for the case statement in 3440000 -% the interpreter that branches to the function code. 3450000 -% program-defined functions: the symbol table location of 3460000 -% the entry point. 3470000 -% labels: the reference count. it is bumped by one each time 3480000 -% the label is encountered. 3490000 -% valu[p].loc is the location of: 3500000 -% strings: the value. 3510000 -% literals: ditto. 3520000 -% functions: (program-defined) a string of 2-char pointers to 3530000 -% the symb table location of the formal parameters and 3540000 -% local variables. for intrinsic functions, this field 3550000 -% is ignored. 3560000 -% io[p].[1:2] is unused. 3570000 -% io[p].iouse = valu[p].iouse (redundant). 3580000 -% io[p].filno is the index to the file arrays for file i/o strings. 3590000 -% io[p].cycle is currently not in use. 3600000 -% io[p].ovfl = 1 for output strings when the tails of output strings 3610000 -% too long for a record are to be written on the next record. 3620000 -% normally = 0, which causes truncation of long output strings. 3630000 -% io[p].iotype is the type of i/o operation, as follows: 3640000 -% value input output 3650000 -% 0 illegal illega 3660000 -% 1 i/o i/o 3670000 -% 2 look trace 3680000 -% 3 teletype teletype 3690000 -% 4 illegal illegal 3700000 -% 5 illegal syspot 3710000 -% io[p].[17:31] is unused. 3720000 -%********local variables for compiler*********************************** 3730000 -boolean 3740000 - bufferfull, % buffer[*] contains a card. 3750000 - dclist, % list prog on teletype. 3760000 - gt, % false at start of compile; true when go-to part reached 3770000 - gtlast, % last inst had a go-to part 3780000 - gtf, % failure exit has been found 3790000 - gts, % success exit has been found 3800000 - lstf, % list program on line printer file print 3810000 - pcc, % list control cards, enve if not lstf 3820000 - programfromremote, % program from teletype, not file program 3830000 - punchf; % punch new program deck 3840000 -integer 3850000 - errors, % number of syntax errors found 3860000 - fieldsize, % number of chars per card that are instruction 3870000 - instnum, % number of inst being compiled 3880000 - instsize, % size of inst being compiled 3890000 - marker, % first char (qmark) of inst in code[*] 3900000 - messages, % number of informative messages printed 3910000 - p, % point in inst[*] being compiled 3920000 - ptr; % next char in code[*] 3930000 -integer array 3940000 - backtrack[0:50,0:5], 3950000 - chartype[0:63]; 3960000 -alpha 3970000 - nextsegment,% symtabl loc of next labeled instruction 3980000 - slastlabel; % symtabl loc of last labeled instruction 3990000 -%********local variables for compiler*********************************** 4000000 -%********stack arrays*************************************************** 4010000 -% the following arrays constitute the "stack" used by the 4020000 -% compiler and interpreter. the index of the next word available 4030000 -% is the global integer sp. 4040000 -boolean array 4050000 - pname[0:stacksize]; % true for named quantities 4060000 -integer array 4070000 - pback, % link for back reference 4080000 - pminleft, % min size of rest of pattern 4090000 - ppoint, % pointer to matched substrings 4100000 - psize, % size of pattern element 4110000 - ptype[0:stacksize]; % type of element, as follows; 4120000 - % 0: undefined 4130000 - % 1: constant pattern element 4140000 - % 2: arbitrary string variable 4150000 - % 3: fixed-length variable 4160000 - % 4: balanced variable 4170000 - % 5: back refernce 4180000 - % 6: undefined 4190000 - % 7: numeric value--in pst[i] 4200000 -alpha array 4210000 - ploc, % scanner only: loc of value of element 4220000 - pst[0:stacksize]; % symbol table address of element 4230000 -%********stack arrays*************************************************** 4240000 -%********local variables for interpreter******************************** 4250000 -% warning: the number of variables in this section must be the same 4260000 -% as the number of variables copied in the defined section of function. 4270000 -boolean % 4280000 - backreflag, % 4290000 - noreplacement, % 4300000 - nobackorbal, 4310000 - selfreflag, % 4320000 - success, % 4330000 - varflag; % 4340000 -integer 4350000 - count, 4360000 - entry, % entry point & last label transfered to 4370000 - floc, % pointer to failure exit./ 4380000 - frontend, 4390000 - increase, 4400000 - instno, 4410000 - instruct, 4420000 - mks, % "mark stack" pointer 4430000 - nearpoint, 4440000 - nextsourcerecord, % disk addr of next available record of source. 4450000 - nopatterns, 4460000 - noreplaces, 4470000 - rearend, 4480000 - refi, 4490000 - refj, 4500000 - refloc, 4510000 - refpt, 4520000 - refstep, 4530000 - relativepointer, 4540000 - rpr, 4550000 - rsize, 4560000 - size, 4570000 - sloc, % point to success exit. 4580000 - sp; 4590000 -alpha 4600000 - tempref; 4610000 -%********local variables for interpreter******************************** 4620000 -%********file-handling declarations************************************* 4630000 -define filmax = 5 #; % max number of files 4640000 -boolean array 4650000 - ioeof, % eof on last i/o operation. 4660000 - iofileopen, % true for open files. 4670000 - lookf[1:filmax];% next record is in nextrecord[i,*]. 4680000 - % used with look-type input strings. 4690000 -integer array 4700000 - iosize, 4710000 - iospace, 4720000 - record[1:filmax]; 4730000 -alpha array 4740000 - iousage[1:filmax]; 4750000 -file 4760000 - card(1,10,30); 4770000 -file in 4780000 - program (1,10,30); 4790000 -file out 4800000 - print (1,17), 4810000 - punch (1,10); 4820000 -save file out 4830000 - newdisk disk serial [20:600] (1,10,30,save 15); 4840000 -switch file iofile ~ 4850000 - card, % 0--dummy entry 4860000 - card, % card-image input and output file 4870000 - program, % program file for batch jobs; read file 4880000 - print, % line printer file 4890000 - punch, % card punch file 4900000 - newdisk; % file for creating new disk files 4910000 -%********file-handling declarations************************************* 4920000 -%********switch format messages***************************************** 4930000 -switch format message ~ ("**missing qoute."), %00 4940000 -(//"*ignore any output after this--it may be incorrect."//), %01 4950000 -("**unrecognized construct in string reference."), %02 4960000 -("**unidentifiable punched object."), %03 4970000 -("**doubly defined exit."), %04 4980000 -("**character after s or f in go-to not (."), %05 4990000 -("**string refernce missing."), %06 5000000 -("**unrecognized go-to construct."), %07 5010000 -("**illegal label in go-to part."), %08 5020000 -("**illegal comma."), %09 5030000 -("**parenthesis count non-zero at start of go-to part."), %10 5040000 -("**the only unary operator is ",""","-",""","."), %11 5050000 -("**extra right parenthesis."), %12 5060000 -("**extra arrow or equal sign."), %13 5070000 -("**strange use of ",""","/",""","."), %14 5080000 -("**attempted replacement in value expression."), %15 5090000 -("**improper arithmetic operand."), %16 5100000 -("**error in use of arithmetic operator."), %17 5110000 -("**parenthesis count at end of instruction non-zero."), %18 5120000 -("**control parameter non-numeric or outside allowed range."), %19 5130000 -(/"**dummy fmt--message[20]"), %20 5140000 -("**too many elements in instruction"), %21 5150000 -("**unrecongnized instruction type."), %22 5160000 -(/"**dummy fmt--message[23]"), %23 5170000 -("**this label has aleady been used; former value lost."), %24 5180000 -(/"**no end card."/), %25 5190000 -("**entry point undefined."), %26 5200000 -("**missing right parenthesis."), %27 5210000 -("**illegal use of literal."), %28 5220000 -("**missing operand to arithmetic"), %29 5230000 -(/"**dummy fmt--message[30]"), %30 5240000 -(/"**dummy fmt--message[31]"), %31 5250000 -("**define failure--unknown error in first argument."), %32 5260000 -("**define failure--unknown error in local variable list."), %33 5270000 -("**invalid argument for indirection."), %34 5280000 -("usedrow[",i2,"] is ",l5,"; dpntr[",i2,"] = ",i5), %35 5290000 -(x16,"*",10(x4,"*",x4,"*")), %36 5300000 -("data[",i2,"] = "), %37 5310000 -("**missing string variable asterisk."), %38 5320000 -("**missing parameter."), %39 5330000 -(///"**compiler screwed up."///), %40 5340000 -(/"**data communications file in use**"/), %41 5350000 -("**program segment too long--insert extra label on preceding" 5360000 - " instruction."), %42 5370000 -("**end of file."), %43 5380000 -("**parity error in "), %44 5390000 -(/"**out of space in string storage area."), %45 5400000 -(/"**out of space in symbol table."), %46 5410000 -("**illegal use of arrow or equal sign."), %47 5420000 -("**non-numeric literal in arithmetic."), %48 5430000 -("**this statement can not be reached."), %49 5440000 -("**undefined label: "), %50 5450000 -(//"**return from function not preceded by call; statement ", 5460000 - "number ",i6), %51 5470000 -("**illegal name for string variable."), %52 5480000 -("**end format--message."); 5490000 -%********switch format message****************************************** 5500000 -%********switch format ftime******************************************** 5510000 -switch format ftime ~ 5520000 -(/"cpu time = ",f10.1," sec."/"i/o time = ",f10.1," sec."), %00 5530000 -(x25,"b 5 5 0 0 s n o b o l 3 s y s t e m"// 5540000 - "version ",f3.1/ 5550000 - "the date is ",i*," ",a3," 19",a2,/ 5560000 - "compilation started at ",2(i2,":"),i2), %01 5570000 -(/"compilation completed at ",2(i2,":"),i2), %02 5580000 -(/"execution started at ",2(i2,":"),i2), %03 5590000 -(/"normal exit at ",2(i2,":"),i2,", at level ",i*," in statment ", 5600000 - i*), %04 5610000 -(/"abnormal exit at ",2(i2,":"),i2,", at level ",i*," in statement ", 5620000 - i*), %05 5630000 -(//"**end format--ftime."//); 5640000 -%********switch format ftime******************************************** 5650000 -%*********************************************************************** 5660000 -%********various formats************************************************ 5670000 -format % not generally used by most programs: 5680000 - f80a1 (80a1), 5690000 - fclosedr ("**attempt to read from closed file:"), 5700000 - fclosedw ("**attempt to write to closed file:"), 5710000 - fcrlf ("{!~"), 5720000 - fendprog ("**end of program file "), 5730000 - ffixvarsize ("**illegal size ",""",x*,"""," for fixed-length ", 5740000 - "variable in statement ",i6), 5750000 - fgc (//"**garbage collector ",10("*******")), 5760000 - fgcres (/"*garbage collector results:"/ 5770000 - i5," rows collected"/ 5780000 - i5," chars in longest row"/ 5790000 - i5," chars total"/), 5800000 - fgcs (/"garbage collector called ",i*," times; used ",f*.1, 5810000 - " sec cpu time, ",f*.1," sec i/o time."), 5820000 - fnofile ("**file not available."), 5830000 - fo (o), 5840000 - fparity ("**irrecoverable parity error on"), 5850000 - frules ("**number of rules executed = ",i8), 5860000 - fsendcopy ("**send copy of program to system authors."), 5870000 - ftrace ("*s",i5,x1,x*," = ","""), 5880000 - ftracefctcall ("*c",i5,x1,x*,"("), 5890000 - ftracefctret ("*r",i5,x1,x*,"() = ","""), 5900000 - ftracel ("*l ",x*,i*,*(" from ",i*)), 5910000 - fundeffct ("**undefined function called:"), 5920000 - fundeflabel ("**attempted transfer to undefined label "); 5930000 -format % for use with createlibrary and loadlibrary. 5940000 - flib0("snobol library file ",i1), 5950000 - flib1 (i1,i4,3(l1,o)), 5960000 - flib2 (a2,16l1,i6), 5970000 - flib3 (165a2), 5980000 - flib4 (6o), 5990000 - flib5 (32l1), 6000000 - flib6 (12i4), 6010000 - fliboldlp("**library file incompatible with this version of snobol"), 6020000 - fliboldtt("{!library file incompatable with this version of snobol", 6030000 - "{!~"); 6040000 -format % used during most runs: 6050000 - fasterisks (/1023("**********")), 6060000 - fbl ((x8)), 6070000 - fdbl (*(/)), 6080000 - ferrs (i*," syntax errors detected"), 6090000 - fi7 (i7), 6100000 - fi16 (i16), 6110000 - fint (*d,x*,i*), 6120000 - fnum (x*,i*); 6130000 -format % used with teletypes 6140000 - fagain ("{!try again{!~"), 6150000 - fdksearch (x*,"/",x*,":",3i1,4(":",i*)), 6160000 - feh ("{!eh",a1,"{!~"), 6170000 - ffromremote ("{!do you want to type a program",a1,"{!~"), 6180000 - fnoinput ("{!!waiting time up--do you wish to continue",a1,"{!~"), 6190000 - fstat (*(":(",2(i*,"/",i*,":"),8i1,")")), 6200000 - fttaddr (i*,"/",i*), 6210000 - ftthello ("{!snobol version ",f3.1",{!~"), 6220000 - fyesorno ("{!type yes or no.{!~"), 6230000 - fvcrlf (x*,"{!~"); 6240000 -format % used with dump procedures 6250000 - fstackhead (/"**the stack is:"/ 6260000 - " word type st name ....loc.... size point minleft back"), 6270000 - fstackentry (i6,i4,x2,a2,x3,l1,x1,i4,x1,i2,x1,i4,i5,i6,i8,i5); 6280000 -%*********************************************************************** 6290000 -%*********************************************************************** 6300000 -%========== begin data com global declarations ========================= 6310000 -define 6320000 - dcinchar =28#, 6330000 - nbufin =4#, 6340000 - bufinsize =5#, 6350000 - dcoutchar =28#, 6360000 - nbufout =5#, 6370000 - bufoutsize =5#, 6380000 - msgsize = 250 #, 6390000 - anssize = 250 #, % max # of chars in output string 6400000 - ttmax = 15 #; % max # of teltypes allowed. 6410000 -alpha array 6420000 - dcread[0:(msgsize-1).w], 6430000 - dcwrite[0:(anssize-1).w], 6440000 - id, % i. d. of user of teletype 6450000 - stat[0:ttmax]; % status of teletype 6460000 -alpha file in dcin 14 ( nbufin, bufinsize); 6470000 -alpha file out dcout 14 (nbufout,bufoutsize); 6480000 -integer 6490000 - mainuser, % teletype currently in charge 6500000 - numusers, % number of teletypes attached. 6510000 - user; % teletype currently being talkedto 6520000 -real 6530000 - waittime; 6540000 -boolean break; 6550000 -%========== end data com global declarations =========================== 6560000 -begin % global stream procedures 6570000 -%********absaddr******************************************************** 6580000 -integer stream procedure absaddr(a); 6590000 -begin si ~ a; absaddr ~ si; end; 6600000 -%********absaddr******************************************************** 6610000 -%*********************************************************************** 6620000 -comment char returns the pth character of name, right justified; 6630000 -integer stream procedure char(name,p); 6640000 -value p; 6650000 -% 6660000 -% 6670000 -begin si ~ name; 6680000 -si ~ si + p; 6690000 -di ~ loc char; di ~ di + 7; 6700000 -ds ~ 1 chr; 6710000 -end; 6720000 -%*********************************************************************** 6730000 -%********eq************************************************************* 6740000 -boolean stream procedure eq(n,l1,i1,l2,i2); 6750000 -value n, i1, i2; 6760000 -begin si ~ l1; si ~ si + i1; 6770000 -di ~ l2; di ~ di + i2; 6780000 -n(if 1 sc ! dc then jump out); 6790000 -if toggle then tally ~ 0 else tally ~ 1; 6800000 -eq ~ tally; 6810000 -end eq; 6820000 -%********eq************************************************************* 6830000 -%********equal********************************************************** 6840000 -% equal returns true if the n chars starting at the i1th char after l1 6850000 -% are the same as the n chars starting at the l2th char after l2. i1 6860000 -% and i2 must be } 0 and { 63. 6870000 -boolean stream procedure equal(n,l1,i1,l2,i2); 6880000 -value n, i1, i2; 6890000 -% 6900000 -% 6910000 -begin local na, nb; 6920000 -label l; 6930000 -si ~ loc n; si ~ si + 5; 6940000 -di ~ loc na; di ~ di + 7; ds ~ 1 chr; 6950000 -di ~ loc nb; di ~ di + 7; ds ~ 1 chr; 6960000 -si ~ l1; 6970000 -si ~ si + i1; 6980000 -di ~ l2; 6990000 -di ~ di + i2; 7000000 -na(16(32(if 8 sc ! dc then jump out 3 to l))); 7010000 -nb(8(if 8 sc ! dc then jump out 2 to l)); 7020000 -n(if 1 sc ! dc then jump out); 7030000 -l: if toggle then tally ~ 0 else tally ~ 1; 7040000 -equal ~ tally; 7050000 -end; 7060000 -%********equal********************************************************** 7070000 -begin % move stream procedures 7080000 -%********mv************************************************************* 7090000 -stream procedure mv(n,l1,i1,l2,i2); 7100000 -value n, i1, i2; 7110000 -begin si ~ l1; si ~ si + i1; 7120000 -di ~ l2; di ~ di + i2; 7130000 -ds ~ n chr; 7140000 -end mv; 7150000 -%********mv************************************************************* 7160000 -%********move*********************************************************** 7170000 -stream procedure move(n,source,i1,dest,i2); 7180000 -% 7190000 -value n, i1, i2; 7200000 -begin local na, nb; 7210000 -si ~ loc n; si ~ si + 5; 7220000 -di ~ loc na; di ~ di + 7 ; ds ~ 1 chr; 7230000 -di ~ loc nb; di ~ di + 7 ; ds ~ 1 chr; 7240000 -si ~ source; 7250000 -si ~ si + i1; 7260000 -di ~ dest; 7270000 -di ~ di + i2; 7280000 -na(4(32(ds ~ 32 chr))); 7290000 -nb(2(ds ~ 32 chr)); 7300000 -ds ~ n chr; 7310000 -end move; 7320000 -%********move*********************************************************** 7330000 -%********movewds******************************************************** 7340000 -stream procedure movewds(n,l1,l2); value n; 7350000 -begin local na; 7360000 -si ~ loc n; si ~ si + 6; 7370000 -di ~ loc na; di ~ di + 7; ds ~ 1 chr; 7380000 -si ~ l1; di ~ l2; 7390000 -na(2(ds ~ 32 wds)); n(ds ~ 1 wds); 7400000 -end movewds; 7410000 -%********movewds******************************************************** 7420000 -%********moveword******************************************************* 7430000 -stream procedure moveword(a,b); value a, b; 7440000 -begin si ~ a; di ~ b; ds ~ 1 wds; end; 7450000 -%********moveword******************************************************* 7460000 -begin % scan stream procedures 7470000 -%********scanchar******************************************************* 7480000 -% scanchar returns the number of chars from the ith char after l 7490000 -% (0 { i { 63) to the first occurence of either c1 or c2. 7500000 -integer stream procedure scanchar(c1,c2,l,i); value c1,c2,i; 7510000 -begin local p1, p2, p3, temp; 7520000 -label cherche,trouve; 7530000 -si ~ l; si ~ si + i; 7540000 -di ~ loc c1; di ~ di + 7; 7550000 -cherche: if 1 sc = dc then go to trouve; 7560000 - temp ~ di; di ~ loc c2; 7570000 - di ~ di + 7; si ~ si - 1; 7580000 - if 1 sc = dc then go to trouve; 7590000 - di ~ temp; 7600000 - di ~ di - 1; 7610000 - tally ~ tally + 1; 7620000 -temp ~ si; 7630000 -p3 ~ tally; si ~ loc p3; si ~ si + 7; 7640000 -if sc ! "0" then 7650000 - begin si ~ temp; go to cherche; end; 7660000 -tally ~ p2; tally ~ tally + 1; 7670000 -p2 ~ tally; si ~ loc p2; si ~ si + 7; 7680000 -if sc ! "0" then 7690000 - begin tally ~ 0; 7700000 - si ~ temp; go to cherche; 7710000 - end; 7720000 -tally ~ p1; tally ~ tally + 1; 7730000 -p1 ~ tally; tally ~ 0; 7740000 -si ~ temp; 7750000 -go to cherche; 7760000 -trouve: 7770000 - di ~ loc scanchar; di ~ di + 5; 7780000 - si ~ loc p1; si ~ si + 7; ds ~ 1 chr; 7790000 - si ~ loc p2; si ~ si + 7; ds ~ 1 chr; 7800000 - si ~ loc p3; si ~ si + 7; ds ~ 1 chr; 7810000 -end scanchar; 7820000 -%********scanchar******************************************************* 7830000 -%********skipchar******************************************************* 7840000 -integer stream procedure skipchar(c,l,i); value c,i; 7850000 -% 7860000 -begin local p1, p2, p3, temp; 7870000 -label cherche,trouve; 7880000 -si ~ l; si ~ si + i; 7890000 -di ~ loc c; di ~ di + 7; 7900000 -cherche: if 1 sc ! dc then go to trouve; 7910000 - di ~ di - 1; 7920000 - tally ~ tally + 1; 7930000 -temp ~ si; 7940000 -p3 ~ tally; si ~ loc p3; si ~ si + 7; 7950000 -if sc ! "0" then 7960000 - begin si ~ temp; go to cherche; end; 7970000 -tally ~ p2; tally ~ tally + 1; 7980000 -p2 ~ tally; si ~ loc p2; si ~ si + 7; 7990000 -if sc ! "0" then 8000000 - begin tally ~ 0; 8010000 - si ~ temp; go to cherche; 8020000 - end; 8030000 -tally ~ p1; tally ~ tally + 1; 8040000 -p1 ~ tally; tally ~ 0; 8050000 -si ~ temp; 8060000 -go to cherche; 8070000 -trouve: 8080000 - di ~ loc skipchar; di ~ di + 5; 8090000 - si ~ loc p1; si ~ si + 7; ds ~ 1 chr; 8100000 - si ~ loc p2; si ~ si + 7; ds ~ 1 chr; 8110000 - si ~ loc p3; si ~ si + 7; ds ~ 1 chr; 8120000 -end skipchar; 8130000 -%********skipchar******************************************************* 8140000 -%*********************************************************************** 8150000 -% cardtype returns a number identifying the type of instruction 8160000 -% being compiled--the types are: 8170000 -% 1 comment 8180000 -% 2 continuation 8190000 -% 3 control card 8200000 -% 4 end 8210000 -% 5 unlabeled 8220000 -% 6 labeled 8230000 -integer stream procedure cardtype(card); 8240000 -begin si ~ card; 8250000 -if sc = "*" then tally ~ 1 else 8260000 -if sc = "%" then tally ~ 1 else 8270000 -if sc = "." then tally ~ 2 else 8280000 -if sc = "-" then tally ~ 3 else 8290000 -if sc = "e" then 8300000 - begin si ~ si + 1; 8310000 - if sc = "n" then 8320000 - begin si ~ si + 1; 8330000 - if sc = "d" then 8340000 - begin si ~ si + 1; 8350000 - if sc = " " then tally ~ 4 else tally ~ 6; 8360000 - end else tally ~ 6; 8370000 - end else tally ~ 6; 8380000 - end else 8390000 -if sc = " " then tally ~ 5 else tally ~ 6; 8400000 -cardtype ~ tally; 8410000 -end type; 8420000 -%********cardtype******************************************************* 8430000 -begin % algol procedures 8440000 -%********forward declarations******************************************* 8450000 -procedure clear(ar,n); 8460000 - value n; integer n; 8470000 - alpha array ar[0]; 8480000 - forward; 8490000 -boolean procedure combinearithmetic(i); 8500000 - value i; 8510000 - integer i; 8520000 - forward; 8530000 -procedure combinefunction(mks); 8540000 - value mks; 8550000 - integer mks; 8560000 - forward; 8570000 -boolean procedure combinegotopart(mks); 8580000 - value mks; 8590000 - integer mks; 8600000 - forward; 8610000 -boolean procedure combinegroup(mks,con); 8620000 - value mks, con; 8630000 - integer mks; 8640000 - boolean con; 8650000 - forward; 8660000 -boolean procedure combineindirection(mks); 8670000 - value mks; 8680000 - integer mks; 8690000 - forward; 8700000 -boolean procedure combinestrvarname(mks); 8710000 - value mks; 8720000 - integer mks; 8730000 - forward; 8740000 -procedure compile(inst); 8750000 - alpha array inst[0]; 8760000 - forward; 8770000 -integer procedure controlparameter(a,p); 8780000 - alpha array a[0]; 8790000 - integer p; 8800000 - forward; 8810000 -procedure convert(a); 8820000 - alpha array a[0]; 8830000 - forward; 8840000 -alpha procedure date; 8850000 - forward; 8860000 -procedure debug(l); 8870000 - value l; 8880000 - label l; 8890000 - forward; 8900000 -integer procedure digits(n); 8910000 - value n; 8920000 - real n; 8930000 - forward; 8940000 -alpha procedure enterst(n,l,p,x); 8950000 - value n, p, x; 8960000 - integer n, p; 8970000 - alpha array l[0]; 8980000 - alpha x; 8990000 - forward; 9000000 -procedure findusers; 9010000 - forward; 9020000 -procedure garbagecollector; 9030000 - forward; 9040000 -procedure indirect(sp); 9050000 - value sp; 9060000 - integer sp; 9070000 - forward; 9080000 -procedure inform0(i); 9090000 - value i; 9100000 - integer i; 9110000 - forward; 9120000 -procedure informa(i,p); 9130000 - value i, p; 9140000 - integer i; alpha p; 9150000 - forward; 9160000 -procedure informi(i,p); 9170000 - value i, p; 9180000 - integer i, p; 9190000 - forward; 9200000 -procedure informia(i,p1,p2); 9210000 - value i, p1, p2; 9220000 - integer i, p1; 9230000 - alpha p2; 9240000 - forward; 9250000 -procedure informii(i,p1,p2); 9260000 - value i, p1, p2; 9270000 - integer i, p1, p2; 9280000 - forward; 9290000 -procedure initializesymbtabl; 9300000 - forward; 9310000 -boolean procedure input; 9320000 - forward; 9330000 -procedure insertstringconvert(sp); 9340000 - value sp; 9350000 - integer sp; 9360000 - forward; 9370000 -procedure interpreter; 9380000 - forward; 9390000 -integer procedure intrinsic(l,p,s); 9400000 - value p, s; 9410000 - alpha array l[0]; 9420000 - integer p, s; 9430000 - forward; 9440000 -procedure loader(f); 9450000 - file f; 9460000 - forward; 9470000 -procedure lst(a); 9480000 - alpha array a[0]; 9490000 - forward; 9500000 -procedure message0(i); 9510000 - value i; 9520000 - integer i; 9530000 - forward; 9540000 -procedure messageai(i,p1,p2); 9550000 - value i, p1, p2; 9560000 - integer i, p2; 9570000 - alpha p1; 9580000 - forward; 9590000 -procedure messagei(i,p); 9600000 - value i, p; 9610000 - integer i, p; 9620000 - forward; 9630000 -procedure messagett0(i); 9640000 - value i; 9650000 - integer i; 9660000 - forward; 9670000 -procedure messagetta(i,p1); 9680000 - value i, p1; 9690000 - integer i; 9700000 - alpha p1; 9710000 - forward; 9720000 -procedure messagettai(i,p1,p2); 9730000 - value i, p1, p2; 9740000 - integer i, p2; 9750000 - alpha p1; 9760000 - forward; 9770000 -procedure messagetti(i,p); 9780000 - value i, p; 9790000 - integer i, p; 9800000 - forward; 9810000 -integer procedure mnemno(n, a, p); 9820000 - value n; 9830000 - integer n, p; 9840000 - array a[0]; 9850000 - forward; 9860000 -alpha procedure newcell(i); 9870000 - value i; 9880000 - integer i; 9890000 - forward; 9900000 -procedure newstrow(i); 9910000 - value i; 9920000 - integer i; 9930000 - forward; 9940000 -boolean procedure nullargs(n); 9950000 - value n; 9960000 - integer n; 9970000 - forward; 9980000 -boolean procedure numval(st,val); 9990000 - value st; 10000000 - alpha st; 10010000 - integer val; 10020000 - forward; 10030000 -boolean procedure output; 10040000 - forward; 10050000 -boolean procedure pop(stloc); 10060000 - value stloc; 10070000 - alpha stloc; 10080000 - forward; 10090000 -procedure processcontrolcard(a); 10100000 - alpha array a[0]; 10110000 - forward; 10120000 -boolean procedure push(s,t); 10130000 - value s, t; alpha s, t; 10140000 - forward; 10150000 -procedure returncell(l); 10160000 - value l; alpha l; 10170000 - forward; 10180000 -procedure returntemps; 10190000 - forward; 10200000 -alpha procedure scatter(size,loc,p,x); 10210000 - value size, p, x; 10220000 - integer size,p; 10230000 - alpha array loc[0]; 10240000 - alpha x; 10250000 - forward; 10260000 -alpha procedure searchst(n,l,p,x); 10270000 - value n, p, x; 10280000 - integer n, p; 10290000 - alpha array l[0]; 10300000 - alpha x; 10310000 - forward; 10320000 -boolean procedure snbldefine(st1,st2,st3); 10330000 - value st1, st2, st3; 10340000 - alpha st1, st2, st3; 10350000 - forward; 10360000 -boolean procedure snblin(st); 10370000 - value st; 10380000 - alpha st; 10390000 - forward; 10400000 -boolean procedure snblout(st); 10410000 - value st; 10420000 - alpha st; 10430000 - forward; 10440000 -procedure storechars(n,l,i); 10450000 - value n, i; 10460000 - integer n, i; 10470000 - alpha l; 10480000 - forward; 10490000 -alpha procedure string(n,stloc); 10500000 - value n, stloc; 10510000 - integer n; alpha stloc; 10520000 - forward; 10530000 -procedure stringdump(n); 10540000 - value n; 10550000 - integer n; 10560000 - forward; 10570000 -procedure syntaxerr(n,p); 10580000 - value n, p; 10590000 - integer n, p; 10600000 - forward; 10610000 -alpha procedure tempcell; 10620000 - forward; 10630000 -alpha procedure tempval(i); 10640000 - value i; 10650000 - integer i; 10660000 - forward; 10670000 -boolean procedure tracefctcall(f); 10680000 - value f; 10690000 - integer f; 10700000 - forward; 10710000 -boolean procedure tracefctreturn(f,suc); 10720000 - value f, suc; 10730000 - integer f; 10740000 - boolean suc; 10750000 - forward; 10760000 -integer procedure ttindex(st); 10770000 - value st; 10780000 - alpha st; 10790000 - forward; 10800000 -boolean procedure writebuff(bufout,p,size); 10810000 - value size; 10820000 - integer p, size; 10830000 - array bufout[0]; 10840000 - forward; 10850000 -procedure writedata; 10860000 - forward; 10870000 -procedure writeinst; 10880000 - forward; 10890000 -procedure writest; 10900000 - forward; 10910000 -procedure writestack(n); 10920000 - value n; 10930000 - integer n; 10940000 - forward; 10950000 -procedure writetime(f,n); 10960000 - value f, n; 10970000 - integer f, n; 10980000 - forward; 10990000 -label 11000000 - abortion, % fatal system error 11010000 - endofrun, % final dumps, if any 11020000 - endterpret; % transferred to at end or fatal error 11030000 -%********checkoutuse****************************************************11040000 -boolean procedure checkoutuse(st); 11050000 -value st; alpha st; 11060000 -checkoutuse ~ if boolean(valtabl[st.str,st.stw].outuse) 11070000 - then snblout(st) else true; 11080000 -%********checkoutuse****************************************************11090000 -%********checksymbtabl**************************************************11100000 -% checksymtabl looks for symbol table entries which point to strings 11110000 -% not preceded by a pointer back to the same symtabl location. if 11120000 -% any such entries are found, an error message is printed and 11130000 -% the job is terminated abnormally (with a complete dump). 11140000 -procedure checksymbtabl; 11150000 -begin integer i, j, k, rw, chr, p; 11160000 -boolean urk; 11170000 -alpha aa; 11180000 -format ff(/"**symbtabl location ",a2," is not pointed to by its string" 11190000 - " at data[",i2,",*]+ ",i4," chars."), 11200000 - fpush (//"**push-down stack into available space list at ",a2), 11210000 - fg (/"**symbtabl location zero has been altered."); 11220000 -urk ~ false; 11230000 -if namtabl[0,0]!0 or valtabl[0,0]!0 then 11240000 - begin write(print,fg); 11250000 - urk ~ true; 11260000 - end; 11270000 -for i ~ 0 step 1 while i { strmax and usedst[i] do 11280000 - begin j ~ nextcell[i].stw; 11290000 - if j ! 0 then do 11300000 - begin namtabl [i,j].[3:1] ~ 1; 11310000 - j ~ (namtabl[i,j].link).stw; 11320000 - end until j = 0 or j } strmax; 11330000 - for j ~ 0 step 1 until stwmax do 11340000 - begin 11350000 - for aa ~ namtabl[i,j],valtabl[i,j] do if aa.ch > 3 then 11360000 - % check strings for back-pointers 11370000 - begin rw ~ temp.r; 11380000 - chr ~ temp.ch - 2; 11390000 - mv(2,data[rw,chr.w],chr.c,p,6); 11400000 - if i ! p.str or j ! p.stw then 11410000 - begin write(print,ff,j&i concstr,rw,chr+2); 11420000 - urk ~ true; 11430000 - end; 11440000 - end; 11450000 - if namtabl[i,j].[1:2]=0 then % string--check push-down stack 11460000 - begin 11470000 - aa ~ valtabl[i,j].link; 11480000 - while aa ! 0 do 11490000 - begin if boolean(name[aa].[3:1]) then 11500000 - begin write(print,fpush,aa); 11510000 - urk ~ true; 11520000 - end; 11530000 - aa ~ valu[aa].link; 11540000 - end; 11550000 - end; 11560000 - end; 11570000 - end; 11580000 -if urk then abort; 11590000 -end checksymbtabl; 11600000 -%********checksymbtabl**************************************************11610000 -%********clear**********************************************************11620000 -procedure clear(ar,n); value n; alpha array ar[0]; integer n; 11630000 -for n ~ n - 1 while n } 0 do move(8,blanks,0,ar[n],0); 11640000 -%********clear**********************************************************11650000 -%********combinearithmetic**********************************************11660000 -boolean procedure combinearithmetic(i); 11670000 - value i; 11680000 - integer i; 11690000 -begin 11700000 -label faut, fin, unary; 11710000 -integer j, k, levop, n; 11720000 -% if inform then inform0(20); 11730000 -combinearithmetic ~ false; 11740000 -if i+1 } sp then 11750000 - begin syntaxerr(29,ploc[i]); 11760000 - go to fin; 11770000 - end; 11780000 -if i + 2 < sp then if ptype[i+2] = 7 then 11790000 - if oplevel[pst[i+2]] > levop~oplevel[pst[i]] then 11800000 - if not combinearithmetic(i+2) then go to fin; 11810000 -j ~ i; 11820000 -do j ~ j-1 until if j < pback[i] then true else ptype[j]!0; 11830000 -if j < pback[i] then go to unary; 11840000 -for k ~ j, i+1 do 11850000 - case ptype[k] of 11860000 - begin go to faut; 11870000 - % 1: string name 11880000 - ; 11890000 - % 2: function name: 11900000 - go to if k=j then unary else faut; 11910000 - % 3: literal 11920000 - ; 11930000 - % 4: "(" of group 11940000 - go to if k=j then unary else faut; 11950000 - % 5: string variable 11960000 - begin syntaxerr(16,ploc[k]); 11970000 - go to fin; 11980000 - end; 11990000 - % 6: indirection, uncombined 12000000 - if not combineindirection(k) then go to fin; 12010000 - % 7: consecutive arithmetic operators 12020000 - begin syntaxerr(16,ploc[k]); 12030000 - go to fin; 12040000 - end; 12050000 - % 8: "/" of fixed-length var 12060000 - go to if k=j then unary else faut; 12070000 - % 9: str ref, pattern & replacement 12080000 - go to faut; 12090000 - % 10: indirection combined 12100000 - ; 12110000 - % 11: not in use 12120000 - go to faut; 12130000 - % 12: not in use 12140000 - go to faut; 12150000 - % 13: "*" of str var 12160000 - begin syntaxerr(16,ploc[k]); 12170000 - go to fin; 12180000 - end; 12190000 - % 14: label in go-to part 12200000 - go to faut; 12210000 - % 15: expression 12220000 - ; 12230000 - % 16: arith expr 12240000 - ; 12250000 - % 17: "*(" of bal var 12260000 - go to faut; 12270000 - % 18: str ref & pattern 12280000 - go to faut; 12290000 - % 19: complete arith expr-- remove string convert 12300000 - psize[k] ~ psize[k] - 2; 12310000 - % 20: "s(",, "f(", or "(" of go-to part 12320000 - go to faut; 12330000 - % 21: combined go-to part 12340000 - go to faut; 12350000 - end cases; 12360000 -n ~ 0; 12370000 -for k ~ j, i+1, i do 12380000 - begin move(psize[k],code[ppoint[k].w],ppoint[k].c,scratch[n.w],n.c); 12390000 - n ~ n + psize[k]; 12400000 - ptype[k] ~ 0; 12410000 - end; 12420000 -move(n,scratch[*],0,code[ppoint[j].w],ppoint[j].c); 12430000 -psize[j] ~ n; 12440000 -ptype[j] ~ 16; % incomplete arith expr 12450000 -combinearithmetic ~ true; 12460000 -go to fin; 12470000 -faut: 12480000 - writeinst; 12490000 - syntaxerr(40,0); 12500000 - write(print,17,code[*]); 12510000 - writestack(sp); 12520000 - systemerror ~ true; 12530000 - go to fin; 12540000 -unary: 12550000 - if pst[i] = "-" then 12560000 - begin move(k~psize[i+1],code[(J~ppoint[i+1]).w],j.c,scratch[*],0);12570000 - aa ~ ".N"; 12580000 - mv(2,aa,6,scratch[k.w],k.c); 12590000 - move(k+2,scratch[*],0,code[(j~ppoint[i]).w],j.c); 12600000 - ptype[i+1] ~ 0; 12610000 - ptype[i] ~ 16; % arith expr--no string convert 12620000 - psize[i] ~ k+2; 12630000 - combinearithmetic ~ true; 12640000 - go to fin; 12650000 - end else 12660000 - % cant be as unary: 12670000 - begin syntaxerr(11,ploc[i]); 12680000 - go to fin; 12690000 - end; 12700000 -fin: 12710000 - if systemerror then inform0(20); 12720000 - % if inform then writeinst; 12730000 -end combinearithmetic; 12740000 -%********combinearithmetic**********************************************12750000 -%********combinefunction************************************************12760000 -procedure combinefunction(mks); 12770000 - value mks; 12780000 - integer mks; 12790000 -begin integer i, j, n; 12800000 -% if inform then inform0(25); 12810000 -n ~ j ~ 0; 12820000 -for i ~ mks+1 step 1 until sp-1 do if ptype[i] ! 0 then 12830000 - begin move(psize[i],code[ppoint[i].w],ppoint[i].c,scratch[j.w],j.c); 12840000 - i ~ i; 12850000 - j ~ j + psize[i]; 12860000 - ptype[i] ~ 0; % wipe out element 12870000 - n ~ n + 1; 12880000 - end; 12890000 -mv(3,code[(i~ppoint[mks]).w],i.c,scratch[j.w],j.c); 12900000 -mv(1,n,7,scratch[j.w],j.c+3); 12910000 -move(j+4,scratch[*],0,code[i.w],i.c); 12920000 -ptype[mks] ~ 15; % expression 12930000 -pname[mks] ~ false; 12940000 -ptr ~ i + (psize[mks]~j+4); 12950000 -% if inform then writeinst; 12960000 -end combinefunction; 12970000 -%********combinefunction************************************************12980000 -%********combinegotopart************************************************12990000 -boolean procedure combinegotopart(mks); 13000000 - value mks; 13010000 - integer mks; 13020000 -begin 13030000 -label fail, faut, fin; 13040000 -integer i, m; 13050000 -% if inform then inform0(24); 13060000 -if ptype[mks] ! 20 then go to faut; 13070000 -m ~ mks + 1; 13080000 -if ptype[m] = 6 then % indirection 13090000 - begin 13100000 - % get number of indirections: 13110000 - i ~ char(code[ppoint[m].w],ppoint[m].c+1); 13120000 - if i > 1 then 13130000 - begin i ~ i - 1; 13140000 - mv(1,i,7,code[ppoint[m].w],ppoint[m].c+1); % decrease by 1 13150000 - if not combineindirection(m) then go to fail; 13160000 - end else % move back to m: 13170000 - begin ptype[m+1] ~ 0; 13180000 - ppoint[m] ~ ppoint[m+1]; 13190000 - ploc[m] ~ ploc[m+1]; 13200000 - psize[m] ~ psize[m+1]; 13210000 - end; 13220000 - ptr ~ ppoint[m] + psize[m]; 13230000 - storechars(1,"l",7); % label indirection code 13240000 - psize[m] ~ psize[m] + 1; 13250000 - ptype[m] ~ 14; % label expression 13260000 - end; 13270000 -if ptype[m] ! 14 then 13280000 - begin syntaxerr(8,ploc[m]); % illegal label 13290000 - go to fail; 13300000 - end; 13310000 -for i ~ m+1 step 1 until sp-1 do if ptype[i] ! 0 then 13320000 - begin syntaxerr(8,ploc[i]); % illegal label 13330000 - go to fail; 13340000 - end; 13350000 -ptr ~ ppoint[m] + psize[m]; 13360000 - psize[mks] ~ psize[m]; 13370000 -ptype[mks] ~ 21; % go-to part combined 13380000 -ppoint[mks] ~ ppoint[m]; 13390000 -ploc[mks] ~ ploc[m]; 13400000 -combinegotopart ~ true; 13410000 -go to fin; 13420000 -% 13430000 -faut: 13440000 - writeinst; 13450000 - syntaxerr(40,0); 13460000 - writestack(sp); 13470000 - systemerror ~ true; 13480000 -fail: 13490000 - if systemerror then inform0(24); 13500000 - combinegotopart ~ false; 13510000 -fin: 13520000 - % if inform then writeinst; 13530000 -end combinegotopart; 13540000 -%********combinegotopart************************************************13550000 -%********combinegroup***************************************************13560000 -boolean procedure combinegroup(mks,con); 13570000 - value mks, con; 13580000 - integer mks; 13590000 - boolean con; 13600000 -begin 13610000 -label faut, fail, fin; 13620000 -boolean arith; % for deleting parens around arith exprs 13630000 -integer errno, errpoint, i, j, k, n; 13640000 -% 13650000 -% if inform then inform0(21); 13660000 -combinegroup ~ arith ~ false; 13670000 -for i ~ mks step 1 until sp-1 do if ptype[i] ! 0 then 13680000 - case ptype[i] of 13690000 - begin 13700000 - % 1: string name 13710000 - ; 13720000 - % 2: function (incomplete) 13730000 - go to faut; 13740000 - % 3: literal 13750000 - ; 13760000 - % 4: start of group 13770000 - go to faut; 13780000 - % 5: not used 13790000 - go to faut; 13800000 - % 6: $n--indirection, uncombined 13810000 - if not combineindirection(k) then go to fin; 13820000 - % 7: arith operators 13830000 - begin 13840000 - if not combinearithmetic(i) then go to fin; 13850000 - while i > 0 and ptype[i]!16 do i ~ i - 1; % find result 13860000 - if ptype[i] ! 16 then go to faut; 13870000 - insertstringconvert(i); 13880000 - arith ~ true; 13890000 - end; 13900000 - % 8: fixed-length "/" 13910000 - go to faut; 13920000 - % 9: str ref, pattern & replacement 13930000 - go to faut; 13940000 - % 10: indirection combined 13950000 - ; 13960000 - % 11: not in use 13970000 - go to faut; 13980000 - % 12: qmark--error 13990000 - go to faut; 14000000 - % 13: "*" of str var--error 14010000 - go to faut; 14020000 - % 14: label in go-to part 14030000 - go to faut; 14040000 - % 15: expression 14050000 - ; 14060000 - % 16: arith expr--no string convert 14070000 - begin 14080000 - insertstringconvert(i); 14090000 - arith ~ true; % might be arith expr 14100000 - end; 14110000 - % 17: "*(" of bal var 14120000 - go to faut; 14130000 - % 18: str ref & pattern 14140000 - go to faut; 14150000 - % 19: complete arith expr 14160000 - arith ~ true; 14170000 - % 20: "s(",, "f(", or "(" of go-to part 14180000 - go to faut; 14190000 - % 21: combined go-to part 14200000 - go to faut; 14210000 - end cases; 14220000 -n ~ j ~ 0; 14230000 -for i ~ mks step 1 until sp-1 do if ptype[i] ! 0 then 14240000 - begin 14250000 - n ~ n + 1; 14260000 - move(psize[i],code[ppoint[i].w],ppoint[i].c,scratch[j.w],j.c); 14270000 - if n { 1 and not con then 14280000 - begin pname[mks] ~ pname[i]; 14290000 - ptype[mks] ~ ptype[i]; 14300000 - end else ptype[i] ~ 0; 14310000 - j ~ j + psize[i]; 14320000 - end; 14330000 -if j = 0 then 14340000 - begin aa ~ "%00"; 14350000 - mv(j~3,aa,5,scratch[*],0); 14360000 - ptype[mks] ~ 1; % string name 14370000 - pname[mks] ~ true; 14380000 - end; 14390000 -if n > 1 then arith ~ false; % not a simple arith expr. 14400000 -if arith then 14410000 - begin ptype[mks] ~ 19; % complete arith expr 14420000 - pname[mks] ~ false; 14430000 - end else 14440000 -if n > 1 or con then 14450000 - begin aa ~ n & "("[36:42:6]; 14460000 - mv(2,aa,6,scratch[j.w],j.c); 14470000 - j ~ j + 2; 14480000 - pname[mks] ~ false; 14490000 - ptype[mks] ~ 15; % expression 14500000 - end; 14510000 -move(j,scratch[*],0,code[(i~ppoint[mks]).w],i.c); 14520000 -ptr ~ i + (psize[mks]~j); 14530000 -combinegroup ~ true; 14540000 -go to fin; 14550000 -% 14560000 -faut: 14570000 - writeinst; 14580000 - syntaxerr(40,0); 14590000 - write(print,17,code[*]); 14600000 - writestack(sp); 14610000 - systemerror ~ true; 14620000 - go to fin; 14630000 -fail: 14640000 - syntaxerr(errno,errpoint); 14650000 -fin: 14660000 - if systemerror then inform0(21); 14670000 - % if inform then writeinst; 14680000 -end combinegroup; 14690000 -%********combinegroup***************************************************14700000 -%********combineindirection*********************************************14710000 -boolean procedure combineindirection(mks); 14720000 - value mks; 14730000 - integer mks; 14740000 -begin integer i, errno, j, k; 14750000 -label fin, fail, faut; 14760000 -% 14770000 -% if inform then inform0(22); 14780000 -for i ~ mks step 1 until sp-2 do if ptype[i] = 6 then 14790000 - begin 14800000 - case ptype[i+1] of % check for syntax erros 14810000 - begin go to faut; 14820000 - % 1: string name 14830000 - begin j ~ "%"; % to mark as non-input string name 14840000 - mv(1,j,7,code[ppoint[i+1].w],ppoint[i+1].c); 14850000 - end; 14860000 - % 2: function--incomplete 14870000 - ; % to become an error eventually 14880000 - % 3: literal 14890000 - ; 14900000 - % 4: grouping--incomplete 14910000 - begin errno ~ 27; 14920000 - go to fail; 14930000 - end; 14940000 - % 5: not used 14950000 - go to faut; 14960000 - % 6: indirection--should not occur 14970000 - go to faut; 14980000 - % 7: arithmetic operators 14990000 - begin errno ~ 34; 15000000 - go to fail; 15010000 - end; 15020000 - % 8: fixed-length "/" 15030000 - begin errno ~ 34; 15040000 - go to fail; 15050000 - end; 15060000 - % 9: str ref, pattern & replacement 15070000 - go to faut; 15080000 - % 10: indirection combined 15090000 - go to faut; 15100000 - % 11: "," 15110000 - begin errno ~ 34; 15120000 - go to fail; 15130000 - end; 15140000 - % 12: qmark--error 15150000 - go to faut; 15160000 - % 13: "*" of str var 15170000 - begin errno ~ 34; 15180000 - go to fail; 15190000 - end; 15200000 - % 14: label in go-to part 15210000 - go to faut; 15220000 - % 15: expression 15230000 - ; 15240000 - % 16: incomplete arith expression 15250000 - insertstringconvert(i); 15260000 - % 17: "*(" of bal var 15270000 - go to faut; 15280000 - % 18: str ref & pattern 15290000 - go to faut; 15300000 - % 19: complete arith expr 15310000 - ; 15320000 - % 20: "s(",, "f(", or "(" of go-to part 15330000 - go to faut; 15340000 - % 21: combined go-to part 15350000 - go to faut; 15360000 - end cases; 15370000 - % interchange elements: 15380000 - move(k~psize[i+1],code[(j~ppoint[i+1]).w],j.c,scratch[*],0); 15390000 - mv(3,code[ppoint[i].w],ppoint[i].c,scratch[k.w],k.c); 15400000 - move(k+3,scratch[*],0,code[ppoint[i].w],ppoint[i].c); 15410000 - psize[i] ~ k + 3; 15420000 - ptype[i] ~ 10; % indirection, combined 15430000 - pname[i] ~ true; 15440000 - ptype[i+1] ~ 0; % wipe out next element 15450000 - combineindirection ~ true; 15460000 - go to fin; 15470000 - end; 15480000 -% if fall thru, no argument to %: 15490000 - errno ~ 34; 15500000 - go to fail; 15510000 -faut: 15520000 - writeinst; 15530000 - syntaxerr(40,0); 15540000 - write(print,17,code[*]); 15550000 - writestack(sp); 15560000 - systemerror ~ true; 15570000 - go to fin; 15580000 -fail: 15590000 - syntaxerr(errno,ploc[i+1]); 15600000 -fin: 15610000 - if systemerror then inform0(22); 15620000 - % if inform then writeinst; 15630000 -end combineindirection; 15640000 -%********combineindirection*********************************************15650000 -%********combinestrvarname**********************************************15660000 -boolean procedure combinestrvarname(mks); 15670000 - value mks; 15680000 - integer mks; 15690000 -begin label fin, succeed; 15700000 -integer i; 15710000 -% if inform then inform0(23); 15720000 -combinestrvarname ~ false; 15730000 -if i~ptype[mks] ! 13 and i ! 17 then 15740000 - begin writeinst; 15750000 - syntaxerr(40,0); 15760000 - write(print,17,code[*]); 15770000 - writestack(sp); 15780000 - systemerror ~ true; 15790000 - go to fin; 15800000 - end; 15810000 -ptype[mks] ~ 0; 15820000 -if not combinegroup(mks,false) then go to fin; 15830000 -if not pname[mks] then 15840000 - begin syntaxerr(52,ploc[mks+1]); % invalid name 15850000 - go to succeed; 15860000 - end; 15870000 -% mark as non-input 15880000 -if ptype[mks] = 1 then % identifier--change to "%" type 15890000 - begin i ~ "%"; 15900000 - mv(1,i,7,code[ppoint[mks].w],ppoint[mks].c); 15910000 - end else 15920000 -if ptype[mks] = 10 then % indirection--remove "i" 15930000 - begin ptype[mks] ~ 15; % expression 15940000 - psize[mks] ~ psize[mks] - 1; 15950000 - end; 15960000 -succeed: 15970000 - combinestrvarname ~ true; 15980000 -fin: 15990000 - if systemerror then inform0(23); 16000000 - % if inform then writeinst; 16010000 -end combinestrvarname; 16020000 -%********combinestrvarname**********************************************16030000 -%********compile********************************************************16040000 -% 16050000 -% the internal form of a snobol program is described here: 16060000 -% the program is "segmented", with a labeled instruction starting a 16070000 -% segment, and the unlabeled instructions following it are in the 16080000 -% same segement. a segment is a string, whose "name" is the label of 16090000 -% its first instruction, and whose "value" is the internal coded 16100000 -% form of the instructions in the segement. 16110000 -% each segment starts with 2 chars giving the loc of the next 16120000 -% segment, for patching purposes, 16130000 -% each instruction starts with a 7-char "introduction" giving: 16140000 -% 1 char: the illegal char 16150000 -% 2 chars: the number of the instruction, as given in the listing16160000 -% 2 chars: the location of the success exit, relative to the 16170000 -% first char of the segment. 16180000 -% 2 chars: the same for the failure exit. 16190000 -% if either exit isnt specified, and the next instruction is 16200000 -% unlabeled, the pointer is to the illegal char at the start of the 16210000 -% next instruction; if the next inst is labeled, the go-to part is 16220000 -% "filled out" with a transfer to this label. 16230000 -% 16240000 -% the internal code is: 16250000 -% string names and labels in the go-to parts are represented by 16260000 -% a quote followed by a 12-bit (2-chars) pointer to symbtabl. 16270000 -% literals are represented by "@" followed by a 2-char pointer 16280000 -% to symbtabl. 16290000 -% pattern matches are indicated by "=" following the code for 16300000 -% the pattern; replacements are indicated by "~" following the code 16310000 -% for the replacement. (both are postfix operators.) 16320000 -% the reserved labels are represented as follows: 16330000 -% end: "-E" 16340000 -% return: "-r" 16350000 -% freturn: "-f" 16360000 -% syntax errors cause the character "X" where the string reference 16370000 -% should be. 16380000 -% functions are postfix operators, which use 4 characters: "#" 16390000 -% to indicate the function call, 2 chars for the pointer to the 16400000 -% symbol table entry for the function, and 1 char to give the number 16410000 -% of parameters. 16420000 -% indirection is a postfix operator consisting of a "$" and one 16430000 -% character giving the number of indirections. note that this means 16440000 -% that the system cant handle more than 63 consecutive dollar signs 16450000 -% without using parentheses to cause a grouping. this is not 16460000 -% expected to create any hardships with any users. 16470000 -% 16480000 -% the following stack arrays are used by the compiler: 16490000 -% 16500000 -% ploc[*] holds pointers into inst[*], to the start of the original 16510000 -% code for the element, for diagnostic purposes 16520000 -% ppoint[*] holds pointers into code[*], to the start of the 16530000 -% compiled code for the elements 16540000 -% psize[*] holds the size of the compiled piece of code 16550000 -% pback[*] links back to the start of nextings of groups or 16560000 -% of function calls 16570000 -% pst[*] holds the operator for arithmetic operators 16580000 -% ptype[*] is the type of element, as follows: 16590000 -% 0: ignore--combined with earlier elements 16600000 -% 1: string name 16610000 -% 2: start of function call (#---) 16620000 -% 3: literal 16630000 -% 4: "(" at start of grouping 16640000 -% 5: string variable--combined into one element 16650000 -% 6: indirection, uncombined ($n) 16660000 -% 7: arithmetic operator 16670000 -% 8: "/" of fixed-length variable 16680000 -% 9: str ref, pattern, & replacement combined 16690000 -% 10: indirection, combined (includes "i" for input check) 16700000 -% 11: not in use 16710000 -% 12: not in use 16720000 -% 13: "*" at start of string variable 16730000 -% 14: label in go-to part 16740000 -% 15: expression (combined) 16750000 -% 16: arithmetic expression--no string convert added 16760000 -% 17: "*(" of balanced string variable 16770000 -% 18: str ref & pattern together. 16780000 -% 19: complete arith expr (with string convert) 16790000 -% 20: "s(", "f(", or "(" of go-to part 16800000 -% 21: combined go-to part 16810000 -% 16820000 -% 16830000 -procedure compile(inst); alpha array inst[0]; 16840000 -begin label 16850000 - next, illegal, 16860000 - bl, lit, str, 16870000 - name, name1, cma, goto, gtpart, 16880000 - condensepattern, 16890000 - condensereplacement, 16900000 - dlr, 16910000 - endstrvar, 16920000 - error, 16930000 - nop, 16940000 - op, 16950000 - parenerr, 16960000 - qmrk, return, 16970000 - mesfil, 16980000 - semicolon, start, l1 16990000 - ; 17000000 -%******** 17010000 -boolean 17020000 - arith, 17030000 - arf, 17040000 - fixedlength, 17050000 - nf, 17060000 - pattern, 17070000 - replacement, 17080000 - svf; 17090000 -boolean array compilingfct[0:50]; 17100000 -integer 17110000 - firstchar, % flags for first of inst. 17120000 - i, 17130000 - j, 17140000 - t, 17150000 - temp; 17160000 -% 17170000 -p ~ scanchar(" ", " ",inst[*],0); 17180000 -start: 17190000 -for i ~ 0 step 1 until 5 do backtrack[0,i] ~ 0; 17200000 -firstchar ~ mks ~ parencount ~ 0; 17210000 -gtlast ~ gt; 17220000 -pattern ~ replacement ~ gt ~ gts ~ gtf ~ systemerror ~ svf ~ arf ~ 17230000 - fixedlength ~ false; 17240000 -p ~ p + 1; 17250000 -p ~ p + skipchar(" ",inst[p.w],p.c); 17260000 -if p } instsize then go to return; 17270000 - sp ~ -1; 17280000 - if datacomf then if instnum mod 10 = 0 then 17290000 - if instnum = 0 then % return, line feed. 17300000 - begin mv(3,crlf,5,dcwrite[*],0); 17310000 - if output then; 17320000 - end else 17330000 - % write inst #: 17340000 - messagetti(15,instnum); % type # on teletype. 17350000 -next: 17360000 - if (sp~sp+1) } stacksize then 17370000 - begin syntaxerr(21,p); 17380000 - go to return; 17390000 - end; 17400000 -% if inform then 17410000 -% begin mv(6,inst[p.w],p.c,aa,2); 17420000 -% informia(2,sp,aa); 17430000 -% end; 17440000 - ppoint[sp] ~ ptr; 17450000 - ploc[sp] ~ p; % save for syntax errors 17460000 - if p } instsize then go to qmrk; 17470000 - case chartype[char(inst[p.w],p.c)] of 17480000 - begin 17490000 -% 0: error 17500000 - begin syntaxerr(3,p); 17510000 - go to return; 17520000 - end; 17530000 -% 1: blank 17540000 - begin p ~ p + skipchar(" ",inst[p.w],p.c); 17550000 - sp ~ sp - 1; 17560000 - go to next; 17570000 - end; 17580000 -% 2: "~" or "=" 17590000 - begin 17600000 - if sp < 1 then 17610000 - begin syntaxerr(6,p); 17620000 - go to return; 17630000 - end; 17640000 - if not (pname[0] or ptype[0]=6) then 17650000 - begin syntaxerr(15,p); % replacement in value expr 17660000 - go to return; 17670000 - end; 17680000 - if arf then 17690000 - begin syntaxerr(13,p); % extra "~" or "=" 17700000 - go to return; 17710000 - end; 17720000 - if parencount ! 0 then 17730000 - begin syntaxerr(27,p); % missing ")" 17740000 - go to return; 17750000 - end; 17760000 - if svf then 17770000 - begin syntaxerr(38,p); % missing "*" 17780000 - go to return; 17790000 - end; 17800000 - if gt then 17810000 - begin syntaxerr(7,p); % unrecognized go-to construct 17820000 - go to return; 17830000 - end; 17840000 - arf ~ true; 17850000 - p ~ p + 1; 17860000 -condensepattern: 17870000 - % if inform then inform0(27); 17880000 - for i ~ 0 step 1 until sp-1 do 17890000 - case ptype[i] of 17900000 - begin; % if 0, ignore 17910000 - % 1: string name 17920000 - ; 17930000 - % 2: start of function call 17940000 - go to error; 17950000 - % 3: literal 17960000 - ; 17970000 - % 4: "(" of grouping 17980000 - go to error; 17990000 - % 5: str var 18000000 - ; 18010000 - % 6: indirection 18020000 - if not combineindirection(i) then go to return; 18030000 - % 7: arith operators 18040000 - begin if not combinearithmetic(i) then go to return; 18050000 - while i > 0 and ptype[i]!16 do i ~ i - 1; % find result 18060000 - if ptype[i] ! 16 then go to error; 18070000 - insertstringconvert(i); 18080000 - end; 18090000 - % 8: "/" of fixed-length var 18100000 - go to error; 18110000 - % 9: str ref, pattern & repl 18120000 - go to error; 18130000 - % 10: indirection combined 18140000 - ; 18150000 - % 11: unused 18160000 - go to error; 18170000 - % 12: unused 18180000 - go to error; 18190000 - % 13: "*" of str var 18200000 - go to error; 18210000 - % 14: label in go-to part 18220000 - go to error; 18230000 - % 15: expression 18240000 - ; 18250000 - % 16: arith expr--no string convert 18260000 - insertstringconvert(i); 18270000 - % 17: "*(" of bal var 18280000 - go to error; 18290000 - % 18: str ref & pattern 18300000 - go to error; 18310000 - % 19: complete arith expr 18320000 - ; 18330000 - % 20: "s(", "f(", or "(" of go-to part 18340000 - go to error; 18350000 - % 21: combined go-to part 18360000 - go to error; 18370000 - end cases; 18380000 - i1 ~ i2 ~ 0; 18390000 - for i ~ 1 step 1 until sp-1 do if ptype[i] ! 0 then 18400000 - begin 18410000 - move(psize[i],code[ppoint[i].w],ppoint[i].c,scratch[i2.w],i2.c); 18420000 - i2 ~ i2 + psize[i]; 18430000 - i1 ~ i1 + 1; 18440000 - ptype[i] ~ 0; 18450000 - end; 18460000 - if i1 } 1 then 18470000 - begin 18480000 - if ptype[0] = 1 then 18490000 - begin aa ~ "%"; 18500000 - mv(1,aa,7,code[ppoint[0].w],ppoint[0].c); 18510000 - end else 18520000 - if ptype[0] = 10 then 18530000 - begin ptype[0] ~ 15; % expression 18540000 - psize[0] ~ psize[0] - 1; % drop "i" 18550000 - end; 18560000 - ptr ~ ppoint[0] + psize[0]; 18570000 - storechars(1,"s",7); 18580000 - storechars(i2,scratch[0],0); 18590000 - storechars(1,"=",7); 18600000 - psize[0] ~ psize[0] + i2 + 2; 18610000 - firstchar.[43:2] ~ 3; % str ref, pattern exist 18620000 - ptype[0] ~ 18; % str ref & pattern 18630000 - end else 18640000 - firstchar.[43:2] ~ 2; % str ref, no pattern 18650000 - if gt then % put in "/" as go-to delimiter 18660000 - begin storechars(1,"/",7); 18670000 - psize[0] ~ psize[0] + 1; 18680000 - end; 18690000 - pattern ~ true; 18700000 - sp ~ 0; 18710000 - pback[mks~1] ~ 0; 18720000 - % if inform then writeinst; 18730000 - go to next; 18740000 - end; % case for "=" or "~". 18750000 -% 3: letter, digit, or period 18760000 - go to name; 18770000 -% 4: """ 18780000 - go to lit; 18790000 -% 5: "(" 18800000 - begin 18810000 - if gt then if parencount = 0 then go to gtpart; 18820000 - compilingfct[parencount~parencount+1] ~ false; 18830000 - p ~ p + 1; 18840000 - pback[sp] ~ mks; 18850000 - mks ~ sp; 18860000 - ptype[sp] ~ 4; % "("--begin grouping 18870000 - psize[sp] ~ 0; % nothing to store in code here 18880000 - go to next; 18890000 - end; 18900000 -% 6: ")" 18910000 - begin 18920000 - if parencount { 0 then 18930000 - begin syntaxerr(12,p); % extra right paren 18940000 - go to return; 18950000 - end; 18960000 - if svf and not fixedlength then if parencount = 1 then 18970000 - if ptype[mks] = 17 then 18980000 - begin 18990000 - if char(inst[p.w],p.c+1) ! "*" then 19000000 - begin syntaxerr(38,p+1); 19010000 - go to return; 19020000 - end; 19030000 - p ~ p + 1; % skip ")" 19040000 - parencount ~ 0; 19050000 - go to endstrvar; 19060000 - end balanced variable element; 19070000 - if gt and parencount=1 then % end of a piece of the go-to part 19080000 - begin 19090000 - if not combinegotopart(mks) then go to return; 19100000 - end else 19110000 - if compilingfct[parencount] then 19120000 - begin 19130000 - if not combinegroup(mks+1,false) then go to return; 19140000 - combinefunction(if ptype[mks]=2 then mks else (mks~pback[mks])); 19150000 - end else 19160000 - begin ptype[mks] ~ 0; % wipe out "(" entry 19170000 - if not combinegroup(mks,true) then go to return; 19180000 - end; 19190000 - parencount ~ parencount - 1; 19200000 - p ~ p + 1; 19210000 - if ptype[sp~mks]!2 then mks ~ pback[mks]; 19220000 - go to next; 19230000 - end; 19240000 -% 7: "*" 19250000 - go to str; 19260000 -% 8: "$" 19270000 - go to dlr; 19280000 -% 9: ":" go-to part 19290000 -goto: 19300000 - begin 19310000 - if svf then % unmatched str var * before go-to. 19320000 - begin syntaxerr(38,ppoint[sp-1]); 19330000 - go to return; 19340000 - end; 19350000 - if gt then 19360000 - begin syntaxerr(7,p); % unrecognized construct 19370000 - go to return; 19380000 - end; 19390000 - if parencount ! 0 then 19400000 - begin syntaxerr(10,p); % paren count non-zero 19410000 - go to return; 19420000 - end; 19430000 - gt ~ true; 19440000 - p ~ p + 1; 19450000 - psize[sp] ~ ptype[sp] ~ 0; 19460000 - if not arf then 19470000 - begin firstchar.[45:1] ~ 0; % no replacement 19480000 - go to condensepattern; 19490000 - end; 19500000 - % replacement to be condensed 19510000 -condensereplacement: 19520000 - % if inform then inform0(28); 19530000 - for i ~ 0 step 1 until sp-1 do 19540000 - case ptype[i] of 19550000 - begin 19560000 - % 0: ignore 19570000 - ; 19580000 - % 1: string name 19590000 - ; 19600000 - % 2: function call 19610000 - go to error; 19620000 - % 3: literal 19630000 - ; 19640000 - % 4: "(" of grouping 19650000 - go to error; 19660000 - % 5: str var combined 19670000 - go to error; 19680000 - % 6: indirection 19690000 - if not combineindirection(i) then go to return; 19700000 - % 7: arith operator 19710000 - begin 19720000 - if not combinearithmetic(i) then go to return; 19730000 - while i > 0 and ptype[i]!16 do i ~ i-1; % find result 19740000 - if ptype[i] ! 16 then go to error; 19750000 - insertstringconvert(i); 19760000 - end; 19770000 - % 8: "/" of fixed-length var 19780000 - go to error; 19790000 - % 9: str ref, pattern & replacement 19800000 - go to error; 19810000 - % 10: indirection combined 19820000 - ; 19830000 - % 11: unused 19840000 - go to error; 19850000 - % 12: unused 19860000 - go to error; 19870000 - % 13: "*" of str var 19880000 - go to error; 19890000 - % 14: go-to label 19900000 - go to error; 19910000 - % 15: expression 19920000 - ; 19930000 - % 16: arith expr--no str convert 19940000 - insertstringconvert(i); 19950000 - % 17: "*(" of bal var 19960000 - go to error; 19970000 - % 18: str ref & pattern 19980000 - if i ! 0 then go to error; 19990000 - % 19: complete arith expr 20000000 - ; 20010000 - % 20: "s(",, "f(", or "(" of go-to part 20020000 - go to error; 20030000 - % 21: combined go-to part 20040000 - go to error; 20050000 - end cases; 20060000 - if ptype[0] = 1 then % mark as non-input 20070000 - begin aa ~ "%"; 20080000 - mv(1,aa,7,code[ppoint[0].w],ppoint[0].c); 20090000 - end else 20100000 - if ptype[0] = 10 then 20110000 - begin ptype[0] ~ 15; % expression 20120000 - psize[0] ~ psize[0] - 1; % drop "i" 20130000 - end; 20140000 - i1 ~ i2 ~ 0; 20150000 - for i ~ 1 step 1 until sp-1 do if ptype[i]!0 then 20160000 - begin 20170000 - move(psize[i],code[ppoint[i].w],ppoint[i].c,scratch[i2.w],i2.c); 20180000 - i2 ~ i2 + psize[i]; 20190000 - i1 ~ i1 + 1; 20200000 - ptype[i] ~ 0; 20210000 - end; 20220000 - ptr ~ ppoint[0] + psize[0]; 20230000 - firstchar.[45:1] ~ 1; % replacement exits 20240000 - storechars(i2,scratch[0],0); 20250000 - storechars(1,"~",7); 20260000 - psize[0] ~ psize[0] + i2 + 1; 20270000 - ptype[0] ~ 9; % str ref, pattern & replacement 20280000 - replacement ~ true; 20290000 - sp ~ 0; 20300000 - pback[mks~1] ~ 0; 20310000 - % if inform then writeinst; 20320000 - go to next; 20330000 - end; % case for go-to ":" or " /" 20340000 -% 10: "-","+", or "|" 20350000 - go to op; 20360000 -% 11: "," 20370000 - begin 20380000 - if not compilingfct[parencount] then 20390000 - begin syntaxerr(9,p); % illegal comma 20400000 - go to return; 20410000 - end; 20420000 - if not combinegroup(mks+1,false) then go to return; 20430000 - pback[mks+1] ~ (if ptype[mks]=2 then mks else pback[mks]); 20440000 - mks ~ sp ~ mks+1; 20450000 - p ~ p + 1; 20460000 - go to next; 20470000 - end; 20480000 -% 12: "/" 20490000 - begin if svf and parencount = 0 and not fixedlength then 20500000 - begin % fixed-length variable slash 20510000 - if ptype[mks] ! 13 then 20520000 - begin syntaxerr(14,p); 20530000 - go to return; 20540000 - end; 20550000 - if not combinestrvarname(mks) then go to return; 20560000 - ptype[sp~mks+1] ~ 8; % fixed-length "/" 20570000 - ppoint[sp] ~ ptr; 20580000 - psize[sp] ~ 0; 20590000 - p ~ p + 1; 20600000 - fixedlength ~ true; 20610000 - pback[sp] ~ pback[mks]; 20620000 - mks ~ sp; 20630000 - go to next; 20640000 - end; 20650000 - if parencount = 0 then 20660000 - if char(inst[(p-1).w],(p-1).c) = " " then 20670000 - if i~char(inst[p.w],p.c+1) = "S" or i = "f" or i = "(" 20680000 - then go to goto; 20690000 - go to op; 20700000 - end; % case for "/" 20710000 -% 13: qmark 20720000 - if p } instsize then go to qmrk; 20730000 -% 14: ";" 20740000 - go to semicolon; 20750000 - end cases; 20760000 -illegal: 20770000 - syntaxerr(3,p); 20780000 - go to return; 20790000 -lit: 20800000 - if gt then if parencount { 1 then 20810000 - begin syntaxerr(28,p); go to return; end; 20820000 - begin 20830000 - psize[sp] ~ 3; ptype[sp] ~ 3; % literal 20840000 - t ~ p; 20850000 - p ~ p + scanchar(""",""",inst[p.w],p.c+1) + 1; 20860000 - if p } instsize then 20870000 - begin syntaxerr(0,t); 20880000 - go to return; 20890000 - end; 20900000 - t ~ enterst(p-t-1,inst[*],t+1,"lit") & "@"[30:42:6]; 20910000 - storechars(3,t,5); 20920000 - p ~ p + 1; 20930000 - go to next; 20940000 - end; 20950000 -name: 20960000 - if gt then if parencount = 0 or ptype[sp-1] = 20 then go to gtpart; 20970000 - psize[sp] ~ 3; 20980000 - t ~ p; 20990000 - do p ~ p + 1 until chartype[char(inst[p.w],p.c)] ! 3; 21000000 - t ~ if char(inst[p.w],p.c) = "(" 21010000 - then enterst(p-t,inst[*],t,"fct") & "#"[30:42:6] 21020000 - else enterst(p-t,inst[*],t,"symb") & """[30:42:6]; 21030000 - storechars(3,t,5); 21040000 - if char(inst[p.w],p.c) = "(" then 21050000 - begin 21060000 - compilingfct[parencount~parencount+1] ~ true; 21070000 - ptr ~ ptr + 1; % make room for char giving # of params 21080000 - p ~ p + 1; 21090000 - pback[sp] ~ mks; 21100000 - mks ~ sp; 21110000 - ptype[sp] ~ 2; % function caall 21120000 - psize[sp] ~ 3; % #-- 21130000 - go to next; 21140000 - end else 21150000 - begin ptype[sp] ~ 1; % string name 21160000 - pname[sp] ~ true; 21170000 - end; 21180000 - go to next; 21190000 -gtpart: 21200000 - if parencount = 0 then 21210000 - begin 21220000 - if (temp ~ char(inst[p.w],p.c)) = "s" or temp = "f" then 21230000 - if char(inst[p.w],p.c+1) = "(" then 21240000 - begin 21250000 - if (if temp="s" then gts else gtf) then 21260000 - begin syntaxerr(4,p); 21270000 - go to return; 21280000 - end; 21290000 - p ~ p + 2; 21300000 - parencount ~ 1; compilingfct[1] ~ false; 21310000 - if temp = "s" then gts ~ true else gtf ~ true; 21320000 - ptype[sp] ~ 20; % "s(", "f(", or "(" of go-to part 21330000 - pback[sp] ~ mks; mks ~ sp; 21340000 - pst[sp] ~ temp; 21350000 - go to next; 21360000 - end else 21370000 - begin syntaxerr(5,p+1); 21380000 - comment char after s or f not "("; 21390000 - go to return; 21400000 - end else 21410000 - if temp = "(" then 21420000 - begin 21430000 - if gts and gtf then 21440000 - begin syntaxerr(4,p); 21450000 - go to return; 21460000 - end; 21470000 - p ~ p + 1; 21480000 - parencount ~ 1; compilingfct[1] ~ false; 21490000 - gts ~ gtf ~ true; 21500000 - ptype[sp] ~ 20; % "s(", "f(", or "(" of go-to part 21510000 - pback[sp] ~ mks; mks ~ sp; 21520000 - pst[sp] ~ "("; 21530000 - go to next; 21540000 - end else 21550000 - begin syntaxerr(7,p); 21560000 - go to return; 21570000 - end; 21580000 - end else 21590000 - if parencount = 1 then 21600000 - begin 21610000 - t ~ p; p ~ p + 1; 21620000 - p ~ p + min(scanchar(" ","(",inst[p.w],p.c), 21630000 - scanchar(" ",")",inst[p.w],p.c)); 21640000 - if char(inst[p.w],p.c) = "(" then 21650000 - begin syntaxerr(8,p); 21660000 - go to return; 21670000 - end; 21680000 - if char(inst[p.w],p.c) = " " then 21690000 - begin temp ~ p; 21700000 - while char(inst[p.w],p.c) = " " do p ~ p + 1; 21710000 - if p } instsize then 21720000 - begin syntaxerr(18,0); 21730000 - go to return; 21740000 - end; 21750000 - if char(inst[p.w],p.c) ! ")" then 21760000 - begin syntaxerr(8,p); 21770000 - go to return; 21780000 - end; 21790000 - end else temp ~ p; 21800000 - if eq(3,words[6],2,inst[t.w],t.c) then 21810000 - if t+3 = temp then 21820000 - begin storechars(2,"-e",6); 21830000 - psize[sp] ~ 2; 21840000 - go to l1; 21850000 - end else 21860000 - else 21870000 - if eq(6,words[6],6,inst[t.w],t.c) then 21880000 - if t+6 = temp then 21890000 - begin storechars(2,"-r",6); 21900000 - psize[sp] ~ 2; 21910000 - go to l1; 21920000 - end else 21930000 - else 21940000 - if eq(7,words[6],5,inst[t.w],t.c) then 21950000 - if t+7 = temp then 21960000 - begin storechars(2,"-f",6); 21970000 - psize[sp] ~ 2; 21980000 - go to l1; 21990000 - end; 22000000 - t ~ enterst(temp-t,inst[*],t,"inst") & ":"[30:42:6]; 22010000 - storechars(3,t,5); 22020000 - psize[sp] ~ 3; 22030000 -l1: ptype[sp] ~ 14; % identifier--label 22040000 - go to next; 22050000 - end; 22060000 - go to error; 22070000 -str: % "*" encountered--test for string variable or multiply, 22080000 - % an asterisk is a string variable asterisk iff it is in the 22090000 - % pattern part and outside of parentheses. 22100000 - begin 22110000 - define dummy=#; 22120000 - if sp < 1 then 22130000 - begin syntaxerr(2,p); % unrecognized construct in str ref 22140000 - go to return; 22150000 - end; 22160000 - if parencount > 0 then go to op; 22170000 - if arf and not gt then go to op; 22180000 - if svf then go to endstrvar; 22190000 - if gt then 22200000 - begin syntaxerr(3,p); 22210000 - go to return; 22220000 - end; 22230000 - if char(inst[p.w],p.c+1) = "(" then 22240000 - begin ptype[sp] ~ 17; % "*(" of bal str var 22250000 - parencount ~ 1; 22260000 - p ~ p + 2; 22270000 - end else 22280000 - begin ptype[sp] ~ 13; % "*" of arb or f/l str var 22290000 - p ~ p + 1; 22300000 - end; 22310000 - psize[sp] ~ 0; 22320000 - ptr ~ ptr + 2; % for *n 22330000 - pback[sp] ~ mks; 22340000 - mks ~ sp; 22350000 - svf ~ true; 22360000 - go to next; 22370000 - end; 22380000 -endstrvar: 22390000 - begin 22400000 - if i~ptype[mks] = 13 then % simple str var 22410000 - begin 22420000 - if not combinestrvarname(mks) then go to return; 22430000 - aa ~ "*1"; 22440000 - end else 22450000 - if i = 17 then % balance str var 22460000 - begin 22470000 - if not combinestrvarname(mks) then go to return; 22480000 - aa ~ "*2"; 22490000 - end else 22500000 - if i = 8 then % fixed-length var 22510000 - begin ptype[mks] ~ 0; 22520000 - if not combinegroup(mks,false) then go to return; 22530000 - aa ~ "*3"; 22540000 - end else 22550000 - % error-mks doesnt point to valid element 22560000 - go to error; 22570000 - ptr ~ ppoint[mks] + psize[mks]; 22580000 - storechars(2,aa,6); 22590000 - psize[sp~mks] ~ psize[mks] + 2; 22600000 - ptype[sp] ~ 5; % str var--combined 22610000 - p ~ p + 1; % skip "*" 22620000 - svf ~ fixedlength ~ false; 22630000 - go to next; 22640000 - end; 22650000 -op: 22660000 - i ~ char(inst[p.w],p.c); 22670000 - if i = "*" then 22680000 - if char(inst[p.w],p.c) = "*" 22690000 - then p ~ p + 1 % two start--exponentiation 22700000 - else i ~ "|"; % one star--multiplication 22710000 - pst[sp] ~ i; % for combinearithmetic 22720000 - i.c6 ~ "."; 22730000 - ptype[sp] ~ 7; 22740000 - pback[sp] ~ mks; 22750000 - psize[sp] ~ 2; 22760000 - storechars(2,i,6); 22770000 - ptr ~ ptr + 2; % make room for string convert (2 chars). 22780000 - p ~ p + 1; 22790000 - go to next; 22800000 -parenerr: 22810000 - syntaxerr(12,p); 22820000 - go to return; 22830000 -error: 22840000 - writeinst; 22850000 - syntaxerr(40,0); 22860000 - writestack(sp); 22870000 - go to return; 22880000 -dlr: 22890000 - i ~ 1; 22900000 - do begin p ~ p + 1; 22910000 - if j ~ char(inst[p.w],p.c) = "$" then i ~ i + 1; 22920000 - end until j ! "$" and j ! " "; 22930000 - aa ~ "$-i" & i[36:42:6]; 22940000 - storechars(3,aa,5); % "$", no. of indirections, "i" 22950000 - ptype[sp] ~ 6; % indirection 22960000 - psize[sp] ~ 2; 22970000 - go to next; 22980000 -mesfil: 22990000 - syntaxerr(38,0); 23000000 - comment missing str var asterisk; 23010000 - go to return; 23020000 -semicolon: 23030000 - begin 23040000 - % if inform then inform0(29); 23050000 - if sp > 1 then go to qmrk; 23060000 - if arf then if not gt then if sp=1 then if ptype[0]!9 23070000 - then storechars(1,"~",7); % stmt of form ~ 23080000 - if not gts then sloc ~ ptr; 23090000 - if not gtf then floc ~ ptr; 23100000 - temp ~ floc & sloc[24:36:12]; 23110000 - move(4,temp,4,code[marker.w],marker.c+3); 23120000 - instnum ~ instnum + 1; 23130000 - marker ~ ptr; 23140000 - aa ~ 0 & instnum[12:36:12] & qmark[6:42:6]; 23150000 - storechars(7,aa,1); 23160000 - ptr ~ ptr + 1; 23170000 - go to start; 23180000 - end; 23190000 -qmrk: 23200000 - if parencount ! 0 then 23210000 - begin syntaxerr(18,0); 23220000 - comment parencount not-zero at end of instruction; 23230000 - go to return; 23240000 - end; 23250000 - if svf then go to mesfil; 23260000 - ptype[sp] ~ psize[sp] ~ 0; 23270000 - if not gt then 23280000 - begin 23290000 - if not arf then if ptype[0]!18 then if sp>1 23300000 - then go to condensepattern; 23310000 - if arf then if not gt then if ptype[0] ! 9 23320000 - then go to condensereplacement; 23330000 - end; 23340000 - i1 ~ 0; 23350000 - ptr ~ ppoint[0]; 23360000 - sloc ~ floc ~ 0; 23370000 - for i ~ 0 step 1 until sp do if ptype[i] ! 0 then 23380000 - begin 23390000 - move(psize[i],code[ppoint[i].w],ppoint[i].c,scratch[i1.w],i1.c); 23400000 - if ptype[i] = 21 then % go-to part--check locs 23410000 - if i2~pst[i] = "s" then sloc ~ ptr+i1 else 23420000 - if i2 = "f" then floc ~ ptr+i1 else 23430000 - if i2 = "(" then 23440000 - begin 23450000 - if sloc = 0 then sloc ~ ptr + i1; 23460000 - if floc = 0 then floc ~ ptr + i1; 23470000 - end else go to error; 23480000 - i1 ~ i1 + psize[i]; 23490000 - ptype[i] ~ 0; 23500000 - end; 23510000 - storechars(i1,scratch[0],0); 23520000 - psize[0] ~ i1; 23530000 - if p < instsize then 23540000 - begin sp ~ 1; 23550000 - go to semicolon; 23560000 - end; 23570000 - if not gts then sloc ~ ptr; 23580000 - if not gtf then floc ~ ptr; 23590000 -return: 23600000 - mv(2,sloc,6,code[marker.w],marker.c+3); 23610000 - mv(2,floc,6,code[marker.w],marker.c+5); 23620000 - mv(1,firstchar,7,code[marker.w],marker.c+7); 23630000 - if inform then writeinst; 23640000 -end compile; 23650000 -%********compile********************************************************23660000 -%********controlparameter***********************************************23670000 -integer procedure controlparameter(a,p); 23680000 - alpha array a[*]; 23690000 - integer p; 23700000 -begin define dummy =#; 23710000 -i1 ~ p; 23720000 -while char(a[*],i1) > 9 and i1 < 64 do i1 ~ i1 + 1; 23730000 -p ~ i1; 23740000 -while char(a[*],p) { 9 and p < 64 do p ~ p + 1; 23750000 -if i1 } p then i1 ~ -1 else 23760000 - read(a[*],fnum,i1,p-i1,i1); 23770000 -controlparameter ~ i1; 23780000 -end controlparameter; 23790000 -%********controlparameter***********************************************23800000 -%********convert********************************************************23810000 -% this routine does a character-set convert, and (if convertstrings 23820000 -% is true) a conversion of i/o string names. it is currently set 23830000 -% to convert from cdc 3600 snobol (as implemented at the univ. of 23840000 -% wisconsi) to b5500 snobol. users at other installation will 23850000 -% probably want to write thier own routine, to convert from a 23860000 -% local version of snobol to b5500 snobol. 23870000 -procedure convert(a); 23880000 - alpha array a[0]; 23890000 -begin integer i; 23900000 -alpha array c[0:79]; 23910000 -define d = c[i]#, d1 = c[i+1]#, d2 = c[i+2]#, 23920000 - d3 = c[i+3]#, D4 = c[i+4]#, d5 = c[i+5]#; 23930000 -read(a[*],f80a1,for i ~ 0 step 1 until 79 do c[i]); 23940000 -if convertstrings then 23950000 -for i ~ 1 step 1 until fieldsize-6 do 23960000 - if d = "s" and d1 = "y" and d2 = "s" then 23970000 - if d3 = "l" and d4 = "o" and d5 = "k" then % syslok : look 23980000 - begin d ~ "l"; d1 ~ "o"; d2 ~ "o"; d3 ~ "k"; d4 ~ d5 ~ " "; 23990000 - end else if d3 = "p" and d5 = "t" then 24000000 - if d4 = "i" then % syspit : read 24010000 - begin d ~ "r"; d1 ~ "e"; d2 ~ "a"; d3 ~ "d"; d4 ~ d5 ~ " "; 24020000 - end else if d4 = "p" then % sysppt : punch 24030000 - begin d ~ "p"; d1 ~ "u"; d2 ~ "n"; d3 ~ "c"; d4 ~ "h"; d5 ~ " "; 24040000 - end; 24050000 -for i ~ 0 step 1 until 79 do 24060000 - c[i] ~ convertval[c[i]]; 24070000 -write(a[*],f80a1,for i ~ 0 step 1 until 79 do c[i]); 24080000 -end convert; 24090000 -%********convert********************************************************24100000 -%********createlibrary**************************************************24110000 -procedure createlibrary(mfid,fid); 24120000 -value mfid, fid; 24130000 -alpha mfid, fid; 24140000 -begin integer i, j; 24150000 -alpha array x[0:5]; 24160000 -save file libe disk serial [20:200] (15,6,60,save 15); 24170000 -% 24180000 -fill libe with mfid, fid; 24190000 -write(libe,flib0,entier(version)); 24200000 -write(libe,flib1,scatterno,maxinstsize, 24210000 - cpulimitexists,cpulimit, 24220000 - iolimitexists,iolimit, 24230000 - rulelimitexists,rulelimit); 24240000 -write(libe,flib2,entry,for i~0 step 1 until 15 do usedst[i],instnum); 24250000 -write(libe,flib3,for i~0 step 1 until 15 do nextcell[i]); 24260000 -for i ~ 0 step 1 until 15 do 24270000 - if usedst[i] then 24280000 - for j ~ 0 step 2 until 254 do 24290000 - write(libe,flib4,namtabl[i,j],valtabl[i,j],iotabl[i,j], 24300000 - namtabl[i,j+1],valtabl[i,j+1],iotabl[i,j+1]); 24310000 -write(libe,flib5,for i~0 step 1 until 31 do usedrow[i]); 24320000 -write(libe,flib6,for i~0 step 1 until 31 do dpntr[i]); 24330000 -for I ~ 0 Step 1 while usedrow[i] do 24340000 - for j ~ 0 step 6 until dpntr[i].w do 24350000 - begin movewds(6,data[i,j],x[*]); 24360000 - write(libe,6,x[*]); 24370000 - end; 24380000 -lock(libe,save); 24390000 -end createlibrary; 24400000 -%********createlibrary**************************************************24410000 -%********date***********************************************************24420000 -alpha procedure date; 24430000 -begin % produces date in form: 24440000 -% mm/dd/yy 24450000 -alpha x; 24460000 -integer d, m, y; 24470000 -stream procedure alphadate(d,m,y,w); 24480000 - value d, m, y; 24490000 - begin di ~ w; 24500000 - si ~ loc m; ds ~ 2 dec; ds ~ 1 lit "/"; 24510000 - si ~ loc d; ds ~ 2 dec; ds ~ 1 lit "/"; 24520000 - si ~ loc y; ds ~ 2 dec; 24530000 - end alphadate; 24540000 -% 24550000 -x ~ time(0); 24560000 -y ~ 10 | x.[18:6] + x.[24:6]; 24570000 -x ~ 100 | x.[30:6] + 10 | x.[36:6] + x.[42:6]; 24580000 -m ~ 0; 24590000 -while x > 0 do 24600000 - begin m ~ m + 1; 24610000 - x ~ x - months[m]; 24620000 - end; 24630000 -d ~ x + months[m]; 24640000 -alphadate(d,m,y,x); 24650000 -date ~ x; 24660000 -end date; 24670000 -%********date***********************************************************24680000 -%********debug**********************************************************24690000 -% this is the central control routine for the interactive 24700000 -% debugging tools. 24710000 -procedure debug(returnlabel); 24720000 -value returnlabel; 24730000 -label returnlabel; 24740000 -begin integer i, j, k, l, saveuser; 24750000 -boolean newinst; 24760000 -define numcommands= 7 #; 24770000 -alpha array command[0:numcommands]; 24780000 -switch format fdbug ~ 24790000 - ("{!statement ",i*,"~"), %0024800000 - ("{!",i*," statements executed~"), %0124810000 - ("{!last label: ",x*,"~"), %0224820000 - ("{!at label: ",x*,"~"), %0324830000 - ("{!type requests...{!~"), %0424840000 - ("{!level = ",i*,"{!~"), %0524850000 - ("{!",x*," not defined{!~"), %0624860000 - ("{!",x*," not in use{!~"), %0724870000 - ("{!unrecognized command{!~"), %0824880000 - ("{!ok{!~"), %0924890000 - ("{!",x*," executed ",i*," times{!~"), %1024900000 - ("{!",x*," = ","""), %1124910000 - ("{!too many labels.{!~"), %1224920000 - ("{!suspended{!~"), %1324930000 - ("{!!end format--fdbug{!!~",(o)); 24940000 -switch format fsuspendreason ~ 24950000 - ("{!suspend called{!~"), %0024960000 - ("{!rule limit hit{!~"), %0124970000 - ("{!label limit hit{!~"), %0224980000 - ("{!fatal error{!~"), %0324990000 - ("{!end fmt--fsusrsn{!~"); 25000000 -label 25010000 - getcommand, 25020000 - get1, 25030000 - fail, 25040000 - illegal, 25050000 - resume, 25060000 - runloop; 25070000 -% 25080000 -saveuser ~ user; 25090000 -user ~ mainuser; 25100000 -newinst ~ false; 25110000 -debugging ~ true; 25120000 -fill command[*] with 25130000 - "end", 25140000 - "type", 25150000 - "set", 25160000 - "run", 25170000 - "label", 25180000 - "abort", 25190000 - "where", 25200000 - "why", 25210000 - 0; 25220000 -write(dcwrite[*],fdbug[13]); 25230000 -if output then; 25240000 -getcommand: 25250000 - if not input then go to fail; 25260000 -get1: 25270000 - mv(1,arrow,7,dcread[dcsize.w],dcsize.c); 25280000 - % if inform then write(print,10,dcread[*]); 25290000 - if char(dcread[*],0) = "-" then % control card; 25300000 - begin instsize ~ dcsize; 25310000 - mv(3,stopper,5,dcread[dcsize.w],dcsize.c); 25320000 - processcontrolcard(dcread[*]); 25330000 - mv(3,crlf,5,dcwrite[*],0); 25340000 - if output then; 25350000 - go to getcommand; 25360000 - end; 25370000 - i ~ skipchar(" ",dcread[*],0); 25380000 -% edit routines go here sometime... 25390000 - j ~ i + scanchar(" ","~",dcread[*],i); 25400000 - aa ~ 0; 25410000 - if j-i > 5 then go to illegal; 25420000 - mv(j-i,dcread[*],i,aa,8-j+i); 25430000 - for i ~ numcommands step -1 until 0 do 25440000 - if aa = command[i] then case i of 25450000 - begin % code for various commands: 25460000 -%*************************************** 25470000 -% 0: end~ 25480000 - begin result ~ true; 25490000 - go to endterpret; 25500000 - end; 25510000 -% 1: type ~ 25520000 - begin 25530000 - if (aa~searchst(i~(dcsize-j-1),dcread[*],j+1,"symb")) { 0 then 25540000 - begin write(dcwrite[*],fdbug[7],i~min(i,63)); 25550000 - mv(i,dcread[*],j+1,dcwrite[*],2); 25560000 - if output then; 25570000 - go to getcommand; 25580000 - end; 25590000 - ab ~ name[aa]; 25600000 - ac ~ valu[aa]; 25610000 - write(dcwrite[*],fdbug[11],i~min(i,63)); 25620000 - mv(i,dcread[*],j+1,dcwrite[*],2); 25630000 - i ~ i + 6; k ~ ac.ch; 25640000 - mv(j~min(70-i,l~ac.s),firstchar(ac),dcwrite[i.w],i.c); 25650000 - mv(1,arrow,7,dcwrite[(i+j).w],(i+j).c); 25660000 - while i + j } 70 do 25670000 - begin if not output then go to getcommand; 25680000 - k ~ k + j; 25690000 - l ~ l - j; 25700000 - mv(i~2,crlf,5,dcwrite[*],0); 25710000 - move(j~min(70-i,l),data[ac.r,k.w],k.c,dcwrite[*],2); 25720000 - end; 25730000 - mv(1,quote,7,dcwrite[(i~i+j).w],i.c); 25740000 - mv(3,crlf,5,dcwrite[i.w],i.c+1); 25750000 - if output then; 25760000 - go to getcommand; 25770000 - end type; 25780000 -% 2: set ~ ~ 25790000 - begin 25800000 - aa ~ enterst(dcsize-j-1,dcread[*],j+1,"symb"); 25810000 - mv(3,crlf,5,dcwrite[*],0); if output then; 25820000 - if not input then go to fail; 25830000 - ab ~ string(dcsize,aa); 25840000 - if death then go to endterpret; 25850000 - move(dcsize,dcread[*],0,firstchar(ab)); 25860000 - valu[aa].loc ~ ab; 25870000 - mv(3,crlf,5,dcwrite[*],0); if output then; 25880000 - go to getcommand; 25890000 - end set; 25900000 -% 3: run from