home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / snobol / aisnobol / atn.sno < prev    next >
Text File  |  1987-10-18  |  13KB  |  502 lines
  1. * ATN.SNO
  2. * SNOBOL4 program to implement a compiler for an
  3. *        Augmented Transition Network Language.
  4. *
  5. *    This program is slightly modified from the version in the report
  6. *    to provide faster compilation of the network.
  7. *
  8. *    Sample input in the ATN source language is contained in file ATN.IN.
  9. *
  10. *    Run the program by typing:
  11. *
  12. *        SNOBOL4 ATN /I:ATN /1:SLIST
  13. *
  14. *    where /1 specifies an optional listing file for the ATN compiler, and
  15. *    may be omitted.  The program requires a minimum of 192K bytes.
  16.  
  17. -PLUSOPS 1
  18. -CASE 0
  19.  
  20. * Keyword settings
  21.  
  22.     &ANCHOR = 0
  23.     &DUMP    = 0
  24.     &FTRACE    = 0
  25.     &FULLSCAN = 0
  26.     &MAXLNGTH = 32767
  27.     &STLIMIT  = -1
  28.     &TRACE    = 0
  29.     &TRIM    = 1
  30.  
  31. *
  32. * Set CODE_PRINT to 1 to get listing of generated code
  33. *
  34.     CODE_PRINT = 0
  35.  
  36. * I/O Associations
  37.  
  38.     INPUT(.ATNSOURCE)
  39.     OUTPUT(.SLIST, 1)
  40.  
  41. * Defined data types
  42.  
  43.     DATA( 'STACK(TOP,REST)' )
  44.  
  45. * Global constants
  46.  
  47.     null = ''
  48.     nil  = STACK()
  49.     TOP(nil)  = nil
  50.     REST(nil) = nil
  51.  
  52.     SENTENCES = nil
  53.     LEX_STACK = nil
  54.     LEXICAL_FEATURES = TABLE()
  55.  
  56. * Utility patterns
  57.  
  58.     BLANK    = ' '
  59.     SC    = ';'
  60.     Q1    = "'"
  61.     Q2    = '"'
  62.     COMMA    = ','
  63.     STAR    = '*'
  64.     LP    = '('
  65.     RP    = ')'
  66.     UL    = '_'
  67.     PUSHER    = '>'
  68.     POPPER    = '<'
  69.     TAB    = CHAR(9)
  70.  
  71.     LEFT_END  = POS(0)
  72.     RIGHT_END = RPOS(0)
  73.  
  74.     BLANKS    = SPAN(BLANK)
  75.     OPT_BLANKS = BLANKS | null
  76.     BB    = BREAK(BLANK)
  77.     BXB    = BREAKX(BLANK)
  78.  
  79.     BBSC    = BREAK(BLANK SC)
  80.     SPSC    = SPAN(SC)
  81.     SPBSC    = SPAN(BLANK SC)
  82.     SPBSCN    = SPBSC | null
  83.     BSC    = BREAK(SC)
  84.  
  85.     LEN1    = LEN(1)
  86.     L1REM    = LEN1 REM
  87.  
  88.     BRP    = BREAK(RP)
  89.     BRPN    = BRP | null
  90.  
  91. * Utility functions
  92.  
  93. * Print X to the source listing file and output file
  94.  
  95.     DEFINE('PRT(X)')                    :(PRT_END)
  96. PRT    OUTPUT = SLIST = X                     :(RETURN)
  97. PRT_END
  98.  
  99. * Error MSG to source listing file and output file
  100.  
  101.     DEFINE('ERROR(MSG)')                    :(ERROR_END)
  102. ERROR    ( PRT() PRT(MSG) PRT() )                :(RETURN)
  103. ERROR_END
  104.  
  105. * Readable display of SNOBOL4 code
  106.  
  107.     DEFINE( 'DISPLAY(SNOCODE)S,L' )                :(DISPLAY_END)
  108. DISPLAY    EQ(CODE_PRINT,0)                    :S(RETURN)
  109.     (PRT() PRT('------ Code ------') PRT())
  110. DISPLAY1
  111.     SNOCODE LEFT_END (BSC $ S) SPSC =            :F(DISPLAY3)
  112.     S LEFT_END (NOTANY(BLANK) (BB | null)) $ L =        :F(DISPLAY2)
  113.     PRT('     | ' L)
  114. DISPLAY2
  115.     S LEFT_END BLANKS =
  116.     S = TRIM(S)
  117.     NULL(S)                            :S(DISPLAY1)
  118.     PRT('     |  ' S)                    :(DISPLAY1)
  119. DISPLAY3
  120.     (PRT() PRT('------ End of Code ------') PRT())        :(RETURN)
  121. DISPLAY_END
  122.  
  123. * Succeeds if X is nil, null, or zero
  124.  
  125.     DEFINE('NULL(X)')                    :(NULL_END)
  126. NULL    (IDENT(X,nil),
  127. +     IDENT(X,null),
  128. +      INTEGER(X) EQ(X,0))                :S(RETURN) F(FRETURN)
  129. NULL_END
  130.  
  131. * Put COAT on RACK using HANGER
  132.  
  133.     DEFINE( 'PUT(RACK,COAT,HANGER)' )            :(PUT_END)
  134. PUT    PROP<RACK> =
  135. +        DIFFER('TABLE',DATATYPE(PROP<RACK>)) TABLE()
  136.     ITEM(PROP<RACK>,HANGER) = COAT                :(RETURN)
  137. PUT_END
  138.  
  139. * Get contents of HANGER off RACK
  140.  
  141.     DEFINE( 'GET(RACK,HANGER)' )                :(GET_END)
  142. GET    PROP<RACK> =
  143. +        DIFFER('TABLE',DATATYPE(PROP<RACK>)) TABLE()    :S(RETURN)
  144.     GET = ITEM(PROP<RACK>,HANGER)                :(RETURN)
  145. GET_END
  146.  
  147. * Program text semi-constants used in code generation
  148.  
  149.     &ALPHABET POS(1) (LEN1 $ MAGIC_CHAR)
  150.  
  151.     REPLACE_LIT = MAGIC_CHAR 'RePlAcE' MAGIC_CHAR
  152.  
  153.     BEGIN_TEXT =
  154. +        ' HOLD = REMAINING_WORDS ;'
  155. +        ' REMAINING_WORDS (BREAK(" ") $ CURRENT_WORD) ;'
  156. +        ' THIS_NODE = GENNAME("' REPLACE_LIT '") ;'
  157. +        ' :(' REPLACE_LIT '_START) ;'
  158.  
  159.     WIN_TEXT =
  160. +        REPLACE_LIT '_WIN'
  161. +        ' TESTF(THIS_NODE,FEATS) :F(' REPLACE_LIT '_LOSE) ;'
  162. +        ' ATTACH(THIS_NODE,PARENT) ;'
  163. +        ' LAST_PARSED = THIS_NODE :(RETURN) ;'
  164.  
  165.     LOSE_TEXT =
  166. +        REPLACE_LIT '_LOSE'
  167. +        ' REMAINING_WORDS = HOLD ;'
  168. +        ' REMAINING_WORDS (BREAK(" ") $ CURRENT_WORD) :(FRETURN) ;'
  169.  
  170.     INITIAL_ROUTINE =
  171. +        REPLACE_LIT BEGIN_TEXT
  172. +        WIN_TEXT LOSE_TEXT REPLACE_LIT '_START ;'
  173.  
  174. * Patterns used in COMPILE routine
  175.  
  176.     COMMENT_PAT = (LEFT_END OPT_BLANKS STAR) | (LEFT_END RIGHT_END)
  177.  
  178.     KEYWORD_PAT = 'NETWORK' | 'FUNCTION' | 'LEXICON'
  179. +        | 'SENTENCES' | 'EXEC'
  180.  
  181.     NAME_PAT    = (BB $ NAME) BLANKS FENCE
  182.  
  183.     LEGAL_PAT   = LEFT_END KEYWORD_PAT . KEYTYPE BLANKS (BB | REM) . TNAME
  184.  
  185.     COMPLETE_PAT = LEFT_END OPT_BLANKS 'END' OPT_BLANKS *TNAME RIGHT_END
  186.  
  187. * Definitions of semantic (code-generating) functions
  188.  
  189.     DEFINE( 'S(NA)' )
  190.     DEFINE( 'S_(NA)T' )
  191.  
  192. * Recognizer/compiler patterns for the five types of blocks:
  193. *  EXEC, SENTENCES, LEXICON, FUNCTION, and NETWORK
  194.  
  195. * Recognizer for EXEC statement
  196.  
  197.     EXEC_PAT = LEFT_END 'EXEC' BLANKS (REM $ NAME) S('EX')
  198.  
  199. * Recognizer/Compiler for SENTENCES block
  200.  
  201.     SENTENCES_LIT = 'SENTENCES' BLANKS FENCE
  202.     SENTENCES_HEADER = LEFT_END SENTENCES_LIT NAME_PAT
  203.     SENTENCE_PAT   = (BSC $ SENT) SPBSC S('SENT')
  204.     SENTENCES_BODY = ARBNO(SENTENCE_PAT)
  205.     SENTENCES_ENDER = 'END' OPT_BLANKS *NAME RIGHT_END
  206.     SENTENCES_PAT = SENTENCES_HEADER SENTENCES_BODY SENTENCES_ENDER
  207.  
  208. * Recognizer/Compiler for LEXICON block
  209.  
  210.     LEXICON_LIT = 'LEXICON' BLANKS FENCE
  211.     LEXICON_HEADER = LEFT_END LEXICON_LIT NAME_PAT
  212.     LEX_PUSH_PAT = PUSHER (BB $ F) BLANKS S('PSH')
  213.     LEX_POP_PAT = POPPER (BB $ F) BLANKS S('POP')
  214.     WORD_PAT = NOTANY(PUSHER POPPER) (BB | null)
  215.     LEX_W_PAT = (WORD_PAT $ W) BLANKS S('LEX')
  216.     ENTRY_PAT = LEX_W_PAT | LEX_PUSH_PAT | LEX_POP_PAT
  217.     ENTRIES_PAT = ARBNO(ENTRY_PAT)
  218.     LEXICON_ENDER = SENTENCES_ENDER
  219.     LEXICON_PAT = LEXICON_HEADER ENTRIES_PAT LEXICON_ENDER
  220.  
  221. * Recognizer/Compiler for FUNCTION block
  222.  
  223.     FUNCTION_LIT = 'FUNCTION' BLANKS FENCE
  224.     FUNCTION_HEADER = LEFT_END FUNCTION_LIT NAME_PAT
  225.     ARG_PAT = (( LP BRPN RP ) $ ARG ) BLANKS S('ARG')
  226.     LOC_PAT = LP (BRPN $ LOC) RP BLANKS S('LOC')
  227.     FUNCTION_HEADER = FUNCTION_HEADER ARG_PAT LOC_PAT
  228.     STATEMENT_PAT = BSC SPSC
  229.     STATEMENTS_PAT = ARBNO(STATEMENT_PAT) $ BODY BLANKS
  230.     FUNCTION_ENDER = SENTENCES_ENDER
  231.     FUNCTION_PAT = FUNCTION_HEADER S('FN') STATEMENTS_PAT
  232. +        FUNCTION_ENDER S('F')
  233.  
  234. * Recongnizer/Compiler for NETWORK block
  235.  
  236. * The IF part
  237.  
  238.     IF_LIT = 'IF' BLANKS FENCE
  239.  
  240. * The conditional clause
  241.  
  242.     CLAUSE_PAT = BXB
  243.     COND_PAT = (CLAUSE_PAT $ COND) BLANKS
  244.  
  245. * The GOTO clause
  246.  
  247.     GOTO_LIT = 'GO' OPT_BLANKS 'TO' BLANKS FENCE
  248.     GOTO_LABEL_PAT = (BB $ GOTO_LABEL) BLANKS FENCE
  249.     GOTO_PAT = GOTO_LIT GOTO_LABEL_PAT
  250.  
  251. * The AFTER clause (which may be null)
  252.  
  253.     AFTER_LIT = 'AFTER' BLANKS FENCE
  254.     SIDE_PAT = (CLAUSE_PAT $ SIDE) BLANKS
  255.     ENDIF_PAT = 'END' OPT_BLANKS 'IF' BLANKS FENCE
  256.     AFTER_PAT =
  257. +        ((null $ SIDE) ENDIF_PAT)
  258. +        | (AFTER_LIT SIDE_PAT ENDIF_PAT)
  259.     IF_PAT = IF_LIT COND_PAT GOTO_PAT AFTER_PAT S('IF')
  260.  
  261. * The labelled set of IF statments (the RULE)
  262.  
  263.     LABEL_PAT = (BB $ LABEL) BLANKS FENCE
  264.     IFS_PAT = ARBNO(IF_PAT)
  265.     END_LABEL_PAT = 'END' OPT_BLANKS *LABEL BLANKS FENCE
  266.     RULE_PAT = LABEL_PAT S('LAB') IFS_PAT END_LABEL_PAT S('ELB')
  267.  
  268. * The set of RULEs (the NETWORK)
  269.  
  270.     NETWORK_LIT = 'NETWORK' BLANKS FENCE
  271.     NETWORK_HEADER = LEFT_END NETWORK_LIT NAME_PAT
  272.     RULES_PAT = ARBNO(RULE_PAT)
  273.     NETWORK_ENDER = SENTENCES_ENDER
  274.  
  275. * Defer compilation of network to COMPILE code, where each labelled IF block
  276. *  will be compiled separately.  This prevents the stack overflow which
  277. *  occurs if RULES_PAT were used here directly.
  278. *
  279.     NETWORK_PAT = NETWORK_HEADER 
  280. +            ARB
  281. +            NETWORK_ENDER 
  282.  
  283. * Grand pattern for compiling any legal block
  284.  
  285.     COMPILE_PAT = NETWORK_PAT
  286. +            | FUNCTION_PAT
  287. +            | LEXICON_PAT
  288. +            | SENTENCES_PAT
  289. +            | EXEC_PAT
  290.  
  291. * Read and compile all text from ATNSOURCE
  292. *   (source listing with comments goes to SLIST)
  293.  
  294.     DEFINE( 'COMPILE()NEXT,TEXT' )                :(COMPILE_END)
  295.  
  296. * Comment or first line of block
  297.  
  298. COMPILE    TEXT = ATNSOURCE                    :F(RETURN)
  299.  
  300. * List the record, trim leading blanks, and check for legal syntax
  301.  
  302. COMPILE1
  303.     PRT( TEXT )
  304. COMP6    TEXT TAB = BLANK                    :S(COMP6)
  305.     TEXT COMMENT_PAT                    :S(COMPILE)
  306.     TEXT LEFT_END BLANKS = null
  307.     TEXT LEGAL_PAT                        :S(COMPILE2A)
  308.     ERROR('Illegal record')                    :(FRETURN)
  309. COMPILE2A
  310.     IDENT(KEYTYPE,'EXEC')                    :S(COMPILE4)
  311.  
  312. COMPILE2
  313.     NEXT = ATNSOURCE                    :S(COMPILE3)
  314.     ERROR('Unexpected end of file on ATNSOURCE')        :(FRETURN)
  315.  
  316. * List the record, convert leading blanks to a single blank,
  317. *  and concatenate with TEXT
  318.  
  319. COMPILE3
  320.     PRT( NEXT )
  321. COMP7    TEXT TAB = BLANK                    :S(COMP7)
  322.     NEXT COMMENT_PAT                    :S(COMPILE2)
  323.     NEXT LEFT_END BLANKS = BLANK
  324.     TEXT = TEXT NEXT
  325.  
  326. * Check for a complete block.  If block is incomplete, keep reading
  327.     NEXT COMPLETE_PAT                    :F(COMPILE2)
  328.  
  329. * Use COMPILE_PAT to compile TEXT
  330.  
  331. COMPILE4
  332.     TIME_ZERO = TIME()
  333.     IDENT(KEYTYPE,'NETWORK')                :F(COMP8)
  334. * Handle networks special:
  335.     TEXT NETWORK_HEADER S('NTW') =                :F(COMPILE5)
  336. * Do network by repeatedly applying RULE_PAT:
  337. COMP9    TEXT RULE_PAT =                        :S(COMP9)
  338.     TEXT NETWORK_ENDER S('ENW')                :F(COMPILE5)S(COMP10)
  339.  
  340. COMP8    TEXT COMPILE_PAT                    :F(COMPILE5)
  341. COMP10    PRT()
  342.     PRT(TIME() - TIME_ZERO ' milliseconds compile time')
  343.     PRT()                            :(COMPILE)
  344.  
  345. COMPILE5
  346.     ERROR('Compilation failed')                :(FRETURN)
  347. COMPILE_END
  348.  
  349. * Semantic (code-generation) functions
  350.  
  351.     :(S_END)
  352.  
  353. * For immediate code generation
  354. *    The code is generated after a part of a syntactic
  355. *    pattern has successfully matched
  356.  
  357. S    S = EVAL( "(NULL $ *S_('"  NA  "')) FENCE " )        :(RETURN)
  358.  
  359. * This is a big computed GOTO with a branch for every
  360. *    semantic contigency.
  361.  
  362. S_    S_ = .DUMMY                        :($( 'S_' NA ))
  363.  
  364. * Initialize the code for a network
  365.  
  366. S_NTW    DEFINE( NAME '(PARENT,FEATS)THIS_NODE,HOLD' )
  367.     DISPLAY(' DEFINE(' Q1 NAME '(PARENT,FEATS)THIS_NODE,HOLD' Q1 ') ;')
  368.     ROUTINE = INITIAL_ROUTINE                :(NRETURN)
  369.  
  370. * The label for a rule
  371.  
  372. S_LAB    ROUTINE = ROUTINE REPLACE_LIT UL LABEL BLANK        :(NRETURN)
  373.  
  374. * One IF statement is a network
  375.  
  376. S_IF    ROUTINE = ROUTINE
  377. +        ' ?( ' COND BLANK SIDE ' ) '
  378. +        ':S(' REPLACE_LIT UL GOTO_LABEL ') ;'        :(NRETURN)
  379.  
  380. * The end of a labelled rule:  If none of the IF statements
  381. *    has been satisfied, then the LOSE branch is take
  382.  
  383. S_ELB    ROUTINE = ROUTINE ' :(' REPLACE_LIT '_LOSE) ;'        :(NRETURN)
  384.  
  385. * Wrap-up network:  (1) insert NAME in all the right places;
  386. *    (2) translate into machine language via CODE.
  387.  
  388. S_ENW    ROUTINE REPLACE_LIT = NAME                :S(S_ENW)
  389.     DISPLAY( ROUTINE )
  390.     CODE( ROUTINE )                        :S(NRETURN)
  391.     ERROR('Compilation error')                :(FRETURN)
  392.  
  393. * Push a sentence onto the stack of sentences
  394.  
  395. S_SENT    SENTENCES = STACK(SENT,SENTENCES)            :(NRETURN)
  396.  
  397. * Push F onto the stack of lexical features
  398.  
  399. S_PSH    LEX_STACK = STACK(F,LEX_STACK)                :(NRETURN)
  400.  
  401. * Pop lexical features up to, NOT INCLUDING, F
  402.  
  403. S_POP    NULL(LEX_STACK)                        :S(NRETURN)
  404.     IDENT(F,TOP(LEX_STACK))                    :S(NRETURN)
  405.     LEX_STACK = REST(LEX_STACK)                :(S_POP)
  406.  
  407. * Attach all stacked features to W
  408.  
  409. S_LEX    LEX_STACK_SAVE = LEX_STACK
  410. S_LEX1    NULL(LEX_STACK)                        :S(S_LEX2)
  411.     LEXICAL_FEATURES<W> = TOP(LEX_STACK) BLANK
  412. +            LEXICAL_FEATURES<W>
  413.     LEX_STACK = REST(LEX_STACK)                :(S_LEX1)
  414. S_LEX2    PRT('     | ' W ':  ' LEXICAL_FEATURES<W>)
  415.     LEX_STACK = LEX_STACK_SAVE                :(NRETURN)
  416.  
  417. * Remove all blanks from the formal argument list for a FUNCTION
  418.  
  419. S_ARG    ARG BLANKS =                    :S(S_ARG)F(NRETURN)
  420.  
  421. * Remove all blanks from the local variable list for a FUNCTION
  422.  
  423. S_LOC    LOC BLANKS =                     :S(S_LOC)F(NRETURN)
  424.  
  425. * Initialize FUNCTION
  426.  
  427. S_FN    DISPLAY(' DEFINE(' Q1 NAME ARG LOC Q1 ') ;')
  428.     DEFINE( NAME ARG LOC )                    :(NRETURN)
  429.  
  430. * Compile a FUNCTION
  431.  
  432. S_F    BODY = BODY " ERROR('No return from ' "
  433. +        Q1 NAME Q1 ") :(END) ;"
  434.     DISPLAY( NAME BLANK BODY )
  435.     CODE( NAME BLANK BODY )                    :S(NRETURN)
  436.     ERROR('Compilation error')                :(FRETURN)
  437.  
  438. * For EXEC, call MAIN with NAME = name of first network to be called
  439.  
  440. S_EX    ( PRT() PRT() )
  441.     PRT( '****** EXECUTION BEGINS WITH ' NAME ' ******') PRT()
  442.     MAIN(NAME)                        :(NRETURN)
  443. S_END
  444.  
  445.  
  446. * This routine is triggered by the EXEC statement
  447.  
  448.     DEFINE( 'MAIN(FIRST_PROC)LAST_PARSED,'
  449. +    'CURRENT_WORD,REMAINING_WORDS,S,PROP' )            :(MAIN_END)
  450. MAIN    NULL(SENTENCES)                        :S(RETURN)
  451.     S = TOP(SENTENCES)
  452.     SENTENCES = REST(SENTENCES)
  453.     ( PRT() PRT() )
  454.     PRT(DUPL('-',SIZE(S)))
  455.     ( PRT() PRT(S) PRT() )
  456.     PRT(DUPL('-',SIZE(S)))
  457.     PRT()
  458.     LAST_PARSED = null
  459.     CURRENT_WORD = null
  460.     REMAINING_WORDS = S BLANK
  461.     PROP = TABLE()
  462.     TIME_ZERO = TIME()
  463.     EVAL(FIRST_PROC)                    :S(MAIN1)
  464.     ( PRT() PRT('Parsing failed') PRT() )            :(MAIN)
  465.  
  466. MAIN1    ( PRT() PRT('Parsing Succeeded') PRT() )
  467.     ( PRT(TIME() - TIME_ZERO ' milliseconds used') PRT() )
  468.     DUMP_PROP()                        :(MAIN)
  469. MAIN_END
  470.  
  471. * Dump registers after parse is completed
  472.  
  473.     DEFINE( 'DUMP_PROP()T,N,R,M,TN1,TN2,RM1,RM2' )        :(DUMP_PROP_END)
  474. DUMP_PROP
  475.     T = CONVERT(PROP, 'ARRAY')                :F(RETURN)
  476.     PROP = null
  477.     N = 1
  478.  
  479. DUMP1    TN1 = T<N,1>                        :F(RETURN)
  480.     TN2 = T<N,2>
  481.     T<N,1> = null
  482.     T<N,2> = null
  483.     R = CONVERT(TN2, 'ARRAY')                :F(DUMP3)
  484.     PRT()
  485.     PRT( 'NODE: ' TN1 )
  486.     M = 1
  487.  
  488. DUMP2        RM1 = R<M,1>                    :F(DUMP3)
  489.         RM2 = R<M,2>
  490.         PRT( DUPL(' ',10) RM1 ' = ' RM2 )
  491.         M = M + 1                    :(DUMP2)
  492.  
  493. DUMP3    N = N + 1                        :(DUMP1)
  494. DUMP_PROP_END
  495.  
  496.  
  497. * Compile main program starts here
  498.  
  499.     COMPILE()                        :S(END)
  500.     ERROR('****** FATAL ERROR ******')
  501. END
  502.