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