home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
snobol
/
aisnobol
/
atn.sno
< prev
next >
Wrap
Text File
|
1987-10-18
|
13KB
|
502 lines
* ATN.SNO
* SNOBOL4 program to implement a compiler for an
* Augmented Transition Network Language.
*
* This program is slightly modified from the version in the report
* to provide faster compilation of the network.
*
* Sample input in the ATN source language is contained in file ATN.IN.
*
* Run the program by typing:
*
* SNOBOL4 ATN /I:ATN /1:SLIST
*
* where /1 specifies an optional listing file for the ATN compiler, and
* may be omitted. The program requires a minimum of 192K bytes.
-PLUSOPS 1
-CASE 0
* Keyword settings
&ANCHOR = 0
&DUMP = 0
&FTRACE = 0
&FULLSCAN = 0
&MAXLNGTH = 32767
&STLIMIT = -1
&TRACE = 0
&TRIM = 1
*
* Set CODE_PRINT to 1 to get listing of generated code
*
CODE_PRINT = 0
* I/O Associations
INPUT(.ATNSOURCE)
OUTPUT(.SLIST, 1)
* Defined data types
DATA( 'STACK(TOP,REST)' )
* Global constants
null = ''
nil = STACK()
TOP(nil) = nil
REST(nil) = nil
SENTENCES = nil
LEX_STACK = nil
LEXICAL_FEATURES = TABLE()
* Utility patterns
BLANK = ' '
SC = ';'
Q1 = "'"
Q2 = '"'
COMMA = ','
STAR = '*'
LP = '('
RP = ')'
UL = '_'
PUSHER = '>'
POPPER = '<'
TAB = CHAR(9)
LEFT_END = POS(0)
RIGHT_END = RPOS(0)
BLANKS = SPAN(BLANK)
OPT_BLANKS = BLANKS | null
BB = BREAK(BLANK)
BXB = BREAKX(BLANK)
BBSC = BREAK(BLANK SC)
SPSC = SPAN(SC)
SPBSC = SPAN(BLANK SC)
SPBSCN = SPBSC | null
BSC = BREAK(SC)
LEN1 = LEN(1)
L1REM = LEN1 REM
BRP = BREAK(RP)
BRPN = BRP | null
* Utility functions
* Print X to the source listing file and output file
DEFINE('PRT(X)') :(PRT_END)
PRT OUTPUT = SLIST = X :(RETURN)
PRT_END
* Error MSG to source listing file and output file
DEFINE('ERROR(MSG)') :(ERROR_END)
ERROR ( PRT() PRT(MSG) PRT() ) :(RETURN)
ERROR_END
* Readable display of SNOBOL4 code
DEFINE( 'DISPLAY(SNOCODE)S,L' ) :(DISPLAY_END)
DISPLAY EQ(CODE_PRINT,0) :S(RETURN)
(PRT() PRT('------ Code ------') PRT())
DISPLAY1
SNOCODE LEFT_END (BSC $ S) SPSC = :F(DISPLAY3)
S LEFT_END (NOTANY(BLANK) (BB | null)) $ L = :F(DISPLAY2)
PRT(' | ' L)
DISPLAY2
S LEFT_END BLANKS =
S = TRIM(S)
NULL(S) :S(DISPLAY1)
PRT(' | ' S) :(DISPLAY1)
DISPLAY3
(PRT() PRT('------ End of Code ------') PRT()) :(RETURN)
DISPLAY_END
* Succeeds if X is nil, null, or zero
DEFINE('NULL(X)') :(NULL_END)
NULL (IDENT(X,nil),
+ IDENT(X,null),
+ INTEGER(X) EQ(X,0)) :S(RETURN) F(FRETURN)
NULL_END
* Put COAT on RACK using HANGER
DEFINE( 'PUT(RACK,COAT,HANGER)' ) :(PUT_END)
PUT PROP<RACK> =
+ DIFFER('TABLE',DATATYPE(PROP<RACK>)) TABLE()
ITEM(PROP<RACK>,HANGER) = COAT :(RETURN)
PUT_END
* Get contents of HANGER off RACK
DEFINE( 'GET(RACK,HANGER)' ) :(GET_END)
GET PROP<RACK> =
+ DIFFER('TABLE',DATATYPE(PROP<RACK>)) TABLE() :S(RETURN)
GET = ITEM(PROP<RACK>,HANGER) :(RETURN)
GET_END
* Program text semi-constants used in code generation
&ALPHABET POS(1) (LEN1 $ MAGIC_CHAR)
REPLACE_LIT = MAGIC_CHAR 'RePlAcE' MAGIC_CHAR
BEGIN_TEXT =
+ ' HOLD = REMAINING_WORDS ;'
+ ' REMAINING_WORDS (BREAK(" ") $ CURRENT_WORD) ;'
+ ' THIS_NODE = GENNAME("' REPLACE_LIT '") ;'
+ ' :(' REPLACE_LIT '_START) ;'
WIN_TEXT =
+ REPLACE_LIT '_WIN'
+ ' TESTF(THIS_NODE,FEATS) :F(' REPLACE_LIT '_LOSE) ;'
+ ' ATTACH(THIS_NODE,PARENT) ;'
+ ' LAST_PARSED = THIS_NODE :(RETURN) ;'
LOSE_TEXT =
+ REPLACE_LIT '_LOSE'
+ ' REMAINING_WORDS = HOLD ;'
+ ' REMAINING_WORDS (BREAK(" ") $ CURRENT_WORD) :(FRETURN) ;'
INITIAL_ROUTINE =
+ REPLACE_LIT BEGIN_TEXT
+ WIN_TEXT LOSE_TEXT REPLACE_LIT '_START ;'
* Patterns used in COMPILE routine
COMMENT_PAT = (LEFT_END OPT_BLANKS STAR) | (LEFT_END RIGHT_END)
KEYWORD_PAT = 'NETWORK' | 'FUNCTION' | 'LEXICON'
+ | 'SENTENCES' | 'EXEC'
NAME_PAT = (BB $ NAME) BLANKS FENCE
LEGAL_PAT = LEFT_END KEYWORD_PAT . KEYTYPE BLANKS (BB | REM) . TNAME
COMPLETE_PAT = LEFT_END OPT_BLANKS 'END' OPT_BLANKS *TNAME RIGHT_END
* Definitions of semantic (code-generating) functions
DEFINE( 'S(NA)' )
DEFINE( 'S_(NA)T' )
* Recognizer/compiler patterns for the five types of blocks:
* EXEC, SENTENCES, LEXICON, FUNCTION, and NETWORK
* Recognizer for EXEC statement
EXEC_PAT = LEFT_END 'EXEC' BLANKS (REM $ NAME) S('EX')
* Recognizer/Compiler for SENTENCES block
SENTENCES_LIT = 'SENTENCES' BLANKS FENCE
SENTENCES_HEADER = LEFT_END SENTENCES_LIT NAME_PAT
SENTENCE_PAT = (BSC $ SENT) SPBSC S('SENT')
SENTENCES_BODY = ARBNO(SENTENCE_PAT)
SENTENCES_ENDER = 'END' OPT_BLANKS *NAME RIGHT_END
SENTENCES_PAT = SENTENCES_HEADER SENTENCES_BODY SENTENCES_ENDER
* Recognizer/Compiler for LEXICON block
LEXICON_LIT = 'LEXICON' BLANKS FENCE
LEXICON_HEADER = LEFT_END LEXICON_LIT NAME_PAT
LEX_PUSH_PAT = PUSHER (BB $ F) BLANKS S('PSH')
LEX_POP_PAT = POPPER (BB $ F) BLANKS S('POP')
WORD_PAT = NOTANY(PUSHER POPPER) (BB | null)
LEX_W_PAT = (WORD_PAT $ W) BLANKS S('LEX')
ENTRY_PAT = LEX_W_PAT | LEX_PUSH_PAT | LEX_POP_PAT
ENTRIES_PAT = ARBNO(ENTRY_PAT)
LEXICON_ENDER = SENTENCES_ENDER
LEXICON_PAT = LEXICON_HEADER ENTRIES_PAT LEXICON_ENDER
* Recognizer/Compiler for FUNCTION block
FUNCTION_LIT = 'FUNCTION' BLANKS FENCE
FUNCTION_HEADER = LEFT_END FUNCTION_LIT NAME_PAT
ARG_PAT = (( LP BRPN RP ) $ ARG ) BLANKS S('ARG')
LOC_PAT = LP (BRPN $ LOC) RP BLANKS S('LOC')
FUNCTION_HEADER = FUNCTION_HEADER ARG_PAT LOC_PAT
STATEMENT_PAT = BSC SPSC
STATEMENTS_PAT = ARBNO(STATEMENT_PAT) $ BODY BLANKS
FUNCTION_ENDER = SENTENCES_ENDER
FUNCTION_PAT = FUNCTION_HEADER S('FN') STATEMENTS_PAT
+ FUNCTION_ENDER S('F')
* Recongnizer/Compiler for NETWORK block
* The IF part
IF_LIT = 'IF' BLANKS FENCE
* The conditional clause
CLAUSE_PAT = BXB
COND_PAT = (CLAUSE_PAT $ COND) BLANKS
* The GOTO clause
GOTO_LIT = 'GO' OPT_BLANKS 'TO' BLANKS FENCE
GOTO_LABEL_PAT = (BB $ GOTO_LABEL) BLANKS FENCE
GOTO_PAT = GOTO_LIT GOTO_LABEL_PAT
* The AFTER clause (which may be null)
AFTER_LIT = 'AFTER' BLANKS FENCE
SIDE_PAT = (CLAUSE_PAT $ SIDE) BLANKS
ENDIF_PAT = 'END' OPT_BLANKS 'IF' BLANKS FENCE
AFTER_PAT =
+ ((null $ SIDE) ENDIF_PAT)
+ | (AFTER_LIT SIDE_PAT ENDIF_PAT)
IF_PAT = IF_LIT COND_PAT GOTO_PAT AFTER_PAT S('IF')
* The labelled set of IF statments (the RULE)
LABEL_PAT = (BB $ LABEL) BLANKS FENCE
IFS_PAT = ARBNO(IF_PAT)
END_LABEL_PAT = 'END' OPT_BLANKS *LABEL BLANKS FENCE
RULE_PAT = LABEL_PAT S('LAB') IFS_PAT END_LABEL_PAT S('ELB')
* The set of RULEs (the NETWORK)
NETWORK_LIT = 'NETWORK' BLANKS FENCE
NETWORK_HEADER = LEFT_END NETWORK_LIT NAME_PAT
RULES_PAT = ARBNO(RULE_PAT)
NETWORK_ENDER = SENTENCES_ENDER
* Defer compilation of network to COMPILE code, where each labelled IF block
* will be compiled separately. This prevents the stack overflow which
* occurs if RULES_PAT were used here directly.
*
NETWORK_PAT = NETWORK_HEADER
+ ARB
+ NETWORK_ENDER
* Grand pattern for compiling any legal block
COMPILE_PAT = NETWORK_PAT
+ | FUNCTION_PAT
+ | LEXICON_PAT
+ | SENTENCES_PAT
+ | EXEC_PAT
* Read and compile all text from ATNSOURCE
* (source listing with comments goes to SLIST)
DEFINE( 'COMPILE()NEXT,TEXT' ) :(COMPILE_END)
* Comment or first line of block
COMPILE TEXT = ATNSOURCE :F(RETURN)
* List the record, trim leading blanks, and check for legal syntax
COMPILE1
PRT( TEXT )
COMP6 TEXT TAB = BLANK :S(COMP6)
TEXT COMMENT_PAT :S(COMPILE)
TEXT LEFT_END BLANKS = null
TEXT LEGAL_PAT :S(COMPILE2A)
ERROR('Illegal record') :(FRETURN)
COMPILE2A
IDENT(KEYTYPE,'EXEC') :S(COMPILE4)
COMPILE2
NEXT = ATNSOURCE :S(COMPILE3)
ERROR('Unexpected end of file on ATNSOURCE') :(FRETURN)
* List the record, convert leading blanks to a single blank,
* and concatenate with TEXT
COMPILE3
PRT( NEXT )
COMP7 TEXT TAB = BLANK :S(COMP7)
NEXT COMMENT_PAT :S(COMPILE2)
NEXT LEFT_END BLANKS = BLANK
TEXT = TEXT NEXT
* Check for a complete block. If block is incomplete, keep reading
NEXT COMPLETE_PAT :F(COMPILE2)
* Use COMPILE_PAT to compile TEXT
COMPILE4
TIME_ZERO = TIME()
IDENT(KEYTYPE,'NETWORK') :F(COMP8)
* Handle networks special:
TEXT NETWORK_HEADER S('NTW') = :F(COMPILE5)
* Do network by repeatedly applying RULE_PAT:
COMP9 TEXT RULE_PAT = :S(COMP9)
TEXT NETWORK_ENDER S('ENW') :F(COMPILE5)S(COMP10)
COMP8 TEXT COMPILE_PAT :F(COMPILE5)
COMP10 PRT()
PRT(TIME() - TIME_ZERO ' milliseconds compile time')
PRT() :(COMPILE)
COMPILE5
ERROR('Compilation failed') :(FRETURN)
COMPILE_END
* Semantic (code-generation) functions
:(S_END)
* For immediate code generation
* The code is generated after a part of a syntactic
* pattern has successfully matched
S S = EVAL( "(NULL $ *S_('" NA "')) FENCE " ) :(RETURN)
* This is a big computed GOTO with a branch for every
* semantic contigency.
S_ S_ = .DUMMY :($( 'S_' NA ))
* Initialize the code for a network
S_NTW DEFINE( NAME '(PARENT,FEATS)THIS_NODE,HOLD' )
DISPLAY(' DEFINE(' Q1 NAME '(PARENT,FEATS)THIS_NODE,HOLD' Q1 ') ;')
ROUTINE = INITIAL_ROUTINE :(NRETURN)
* The label for a rule
S_LAB ROUTINE = ROUTINE REPLACE_LIT UL LABEL BLANK :(NRETURN)
* One IF statement is a network
S_IF ROUTINE = ROUTINE
+ ' ?( ' COND BLANK SIDE ' ) '
+ ':S(' REPLACE_LIT UL GOTO_LABEL ') ;' :(NRETURN)
* The end of a labelled rule: If none of the IF statements
* has been satisfied, then the LOSE branch is take
S_ELB ROUTINE = ROUTINE ' :(' REPLACE_LIT '_LOSE) ;' :(NRETURN)
* Wrap-up network: (1) insert NAME in all the right places;
* (2) translate into machine language via CODE.
S_ENW ROUTINE REPLACE_LIT = NAME :S(S_ENW)
DISPLAY( ROUTINE )
CODE( ROUTINE ) :S(NRETURN)
ERROR('Compilation error') :(FRETURN)
* Push a sentence onto the stack of sentences
S_SENT SENTENCES = STACK(SENT,SENTENCES) :(NRETURN)
* Push F onto the stack of lexical features
S_PSH LEX_STACK = STACK(F,LEX_STACK) :(NRETURN)
* Pop lexical features up to, NOT INCLUDING, F
S_POP NULL(LEX_STACK) :S(NRETURN)
IDENT(F,TOP(LEX_STACK)) :S(NRETURN)
LEX_STACK = REST(LEX_STACK) :(S_POP)
* Attach all stacked features to W
S_LEX LEX_STACK_SAVE = LEX_STACK
S_LEX1 NULL(LEX_STACK) :S(S_LEX2)
LEXICAL_FEATURES<W> = TOP(LEX_STACK) BLANK
+ LEXICAL_FEATURES<W>
LEX_STACK = REST(LEX_STACK) :(S_LEX1)
S_LEX2 PRT(' | ' W ': ' LEXICAL_FEATURES<W>)
LEX_STACK = LEX_STACK_SAVE :(NRETURN)
* Remove all blanks from the formal argument list for a FUNCTION
S_ARG ARG BLANKS = :S(S_ARG)F(NRETURN)
* Remove all blanks from the local variable list for a FUNCTION
S_LOC LOC BLANKS = :S(S_LOC)F(NRETURN)
* Initialize FUNCTION
S_FN DISPLAY(' DEFINE(' Q1 NAME ARG LOC Q1 ') ;')
DEFINE( NAME ARG LOC ) :(NRETURN)
* Compile a FUNCTION
S_F BODY = BODY " ERROR('No return from ' "
+ Q1 NAME Q1 ") :(END) ;"
DISPLAY( NAME BLANK BODY )
CODE( NAME BLANK BODY ) :S(NRETURN)
ERROR('Compilation error') :(FRETURN)
* For EXEC, call MAIN with NAME = name of first network to be called
S_EX ( PRT() PRT() )
PRT( '****** EXECUTION BEGINS WITH ' NAME ' ******') PRT()
MAIN(NAME) :(NRETURN)
S_END
* This routine is triggered by the EXEC statement
DEFINE( 'MAIN(FIRST_PROC)LAST_PARSED,'
+ 'CURRENT_WORD,REMAINING_WORDS,S,PROP' ) :(MAIN_END)
MAIN NULL(SENTENCES) :S(RETURN)
S = TOP(SENTENCES)
SENTENCES = REST(SENTENCES)
( PRT() PRT() )
PRT(DUPL('-',SIZE(S)))
( PRT() PRT(S) PRT() )
PRT(DUPL('-',SIZE(S)))
PRT()
LAST_PARSED = null
CURRENT_WORD = null
REMAINING_WORDS = S BLANK
PROP = TABLE()
TIME_ZERO = TIME()
EVAL(FIRST_PROC) :S(MAIN1)
( PRT() PRT('Parsing failed') PRT() ) :(MAIN)
MAIN1 ( PRT() PRT('Parsing Succeeded') PRT() )
( PRT(TIME() - TIME_ZERO ' milliseconds used') PRT() )
DUMP_PROP() :(MAIN)
MAIN_END
* Dump registers after parse is completed
DEFINE( 'DUMP_PROP()T,N,R,M,TN1,TN2,RM1,RM2' ) :(DUMP_PROP_END)
DUMP_PROP
T = CONVERT(PROP, 'ARRAY') :F(RETURN)
PROP = null
N = 1
DUMP1 TN1 = T<N,1> :F(RETURN)
TN2 = T<N,2>
T<N,1> = null
T<N,2> = null
R = CONVERT(TN2, 'ARRAY') :F(DUMP3)
PRT()
PRT( 'NODE: ' TN1 )
M = 1
DUMP2 RM1 = R<M,1> :F(DUMP3)
RM2 = R<M,2>
PRT( DUPL(' ',10) RM1 ' = ' RM2 )
M = M + 1 :(DUMP2)
DUMP3 N = N + 1 :(DUMP1)
DUMP_PROP_END
* Compile main program starts here
COMPILE() :S(END)
ERROR('****** FATAL ERROR ******')
END