112069Sbaden ; FP interpreter/compiler 212069Sbaden ; Copyright (c) 1982 Scott B. Baden 312069Sbaden ; Berkeley, California 4*21730Sdist ; 5*21730Sdist ; Copyright (c) 1982 Regents of the University of California. 6*21730Sdist ; All rights reserved. The Berkeley software License Agreement 7*21730Sdist ; specifies the terms and conditions for redistribution. 8*21730Sdist ; 9*21730Sdist (setq SCCS-parser.l "@(#)parser.l 5.1 (Berkeley) 05/31/85") 1012069Sbaden 1112069Sbaden (include specials.l) 1212069Sbaden (declare (special flag) 1312069Sbaden (localf get_condit trap_err Push 1412069Sbaden prs_fn get_def get_constr get_while Pop)) 1512069Sbaden 1612069Sbaden (defun parse (a_flag) 1712069Sbaden (let ((flag a_flag)) 1812069Sbaden (do 1912069Sbaden ((tkn (get_tkn) (get_tkn)) 2012069Sbaden (rslt nil) (action nil) (wslen 0) (stk nil)) 2112069Sbaden 2212069Sbaden ((eq tkn 'eof$$) (cond ((eq flag 'top_lev) 'eof$$) 2312069Sbaden (t (*throw 'parse$err '(err$$ eof))))) 2412069Sbaden 2512069Sbaden (cond ((null (plist (prs_fn))) (*throw 'parse$err `(err$$ unknown ,tkn)))) 2612069Sbaden (cond ((find 'badtkn$$ tkn) (*throw 'parse$err `(err$$ badtkn ,(cadr tkn))))) 2712069Sbaden (setq action (get (prs_fn) flag)) 2812069Sbaden (cond ((null action) (*throw 'parse$err `(err$$ illeg ,tkn)))) 2912069Sbaden (setq rslt (funcall action)) 3012069Sbaden (cond ((eq rslt 'cmd$$) (return rslt))) 3112069Sbaden (cond ((not (listp rslt)) (*throw 'parse$err `(err$$ fatal1 ,stk ,tkn ,rslt)))) 3212069Sbaden (cond ((eq (car rslt) 'return) 3312069Sbaden (return 3412069Sbaden (cond ((eq (cadr rslt) 'done) (cdr rslt)) 3512069Sbaden (t (cadr rslt))))) 3612069Sbaden 3712069Sbaden ((eq (car rslt) 'Push) 3812069Sbaden (cond ((eq flag 'while$$) 3912069Sbaden (cond ((or (zerop wslen) (onep wslen)) 4012069Sbaden (Push (cadr rslt))) 4112069Sbaden ((twop wslen) (*throw 'parse$err `(err$$ bad_whl ,stk ,tkn))) 4212069Sbaden (t (*throw 'parse$err '(err$$ bad_while parse))))) 4312069Sbaden (t 4412069Sbaden (cond ((null stk) (Push (cadr rslt))) 4512069Sbaden (t (*throw 'parse$err `(err$$ stk_ful ,stk ,tkn))))))) 4612069Sbaden 4712069Sbaden ((eq (car rslt) 'nothing)) 4812069Sbaden (t (*throw 'parse$err `(err$$ fatal2 ,stk ,tkn ,rslt))))))) 4912069Sbaden 5012069Sbaden 5112069Sbaden ; These are the parse action functions. 5212069Sbaden ; There is one for each token-context combination. 5312069Sbaden ; The contexts are: 5412069Sbaden ; top_lev,constr$$,compos$$,alpha$$,insert$$. 5512069Sbaden ; The name of each function is formed by appending p$ to the 5612069Sbaden ; name of the token just parsed. 5712069Sbaden ; For each function name there is actually a set of functions 5812069Sbaden ; associated by a plist (keyed on the context). 5912069Sbaden 6012069Sbaden (defun (p$lbrace$$ top_lev) nil 6112069Sbaden (cond (in_def (*throw 'parse$err '(err$$ ill_lbrace))) 6212069Sbaden (t (list 'nothing (get_def))))) 6312069Sbaden 6412069Sbaden (defun (p$rbrace$$ top_lev) nil 6512069Sbaden (cond ((not in_def) (*throw 'parse$err '(err$$ ill_rbrace))) 6612069Sbaden (t (progn 6712069Sbaden (cond ((null stk) (*throw 'parse$err '(err$$ stk_emp))) 6812069Sbaden ((null infile) 6912069Sbaden (do 7012069Sbaden ((c (Tyi) (Tyi))) 7112069Sbaden ((eq c 10))))) 7212069Sbaden `(return ,(Pop)))))) 7312069Sbaden 7412069Sbaden (defun (p$rbrace$$ semi$$) nil 7512069Sbaden (cond 7612069Sbaden ((not in_def) (*throw 'parse$err '(err$$ ill_rbrace))) 7712069Sbaden (t (progn 7812069Sbaden (cond ((null stk) (*throw 'parse$err '(err$$ stk_emp))) 7912069Sbaden ((null infile) 8012069Sbaden (do 8112069Sbaden ((c (Tyi) (Tyi))) 8212069Sbaden ((eq c 10))))) 8312069Sbaden `(rbrace$$ ,(Pop)))))) 8412069Sbaden 8512069Sbaden (defun trap_err (p) 8612069Sbaden (cond ((find 'err$$ p) (*throw 'parse$err p)) 8712069Sbaden (t p))) 8812069Sbaden 8912069Sbaden (defun (p$lparen$$ top_lev) nil 9012069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 9112069Sbaden (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 9212069Sbaden 9312069Sbaden (defun (p$lparen$$ constr$$) nil 9412069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 9512069Sbaden (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 9612069Sbaden 9712069Sbaden (defun (p$lparen$$ compos$$) nil 9812069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 9912069Sbaden (t `(return ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 10012069Sbaden 10112069Sbaden (defun (p$lparen$$ alpha$$) nil 10212069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 10312069Sbaden (t `(return ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 10412069Sbaden 10512069Sbaden (defun (p$lparen$$ ti$$) nil 10612069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 10712069Sbaden (t `(return ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 10812069Sbaden 10912069Sbaden (defun (p$lparen$$ insert$$) nil 11012069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 11112069Sbaden (t `(return ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 11212069Sbaden 11312069Sbaden (defun (p$lparen$$ arrow$$) nil 11412069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 11512069Sbaden (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 11612069Sbaden 11712069Sbaden (defun (p$lparen$$ semi$$) nil 11812069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 11912069Sbaden (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 12012069Sbaden 12112069Sbaden (defun (p$lparen$$ lparen$$) nil 12212069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_lpar))) 12312069Sbaden (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 12412069Sbaden 12512069Sbaden (defun (p$lparen$$ while$$) nil 12612069Sbaden (cond ((twop wslen) (*throw 'parse$err '(err$$ ill_lpar))) 12712069Sbaden (t `(Push ,(trap_err (*catch '(parse$err end_while end_condit) (parse tkn))))))) 12812069Sbaden 12912069Sbaden (defun (p$rparen$$ lparen$$) nil 13012069Sbaden `(return ,(Pop))) 13112069Sbaden 13212069Sbaden (defun (p$rparen$$ top_lev) nil ; process commands 13312069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ unbalparen))) 13412069Sbaden (t (cond ((null infile) (get_cmd)) 13512069Sbaden (t (patom "commands may not be issued from a file") 13612069Sbaden (terpri) 13712069Sbaden 'cmd$$))))) 13812069Sbaden 13912069Sbaden (defun (p$rparen$$ semi$$) nil 14012069Sbaden `(return ,(Pop))) 14112069Sbaden 14212069Sbaden (defun (p$rparen$$ while$$) nil 14312069Sbaden `(return ,(nreverse (list (Pop) (Pop))))) 14412069Sbaden 14512069Sbaden (defun (p$alpha$$ top_lev) nil 14612069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 14712069Sbaden (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) 14812069Sbaden 14912069Sbaden (defun (p$alpha$$ compos$$) nil 15012069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 15112069Sbaden (t `(return ,(frm_hnk 'alpha$$ (parse tkn)))))) 15212069Sbaden 15312069Sbaden (defun (p$alpha$$ constr$$) nil 15412069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 15512069Sbaden (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) 15612069Sbaden 15712069Sbaden (defun (p$alpha$$ insert$$) nil 15812069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 15912069Sbaden (t `(return ,(frm_hnk 'alpha$$ (parse tkn)))))) 16012069Sbaden 16112069Sbaden (defun (p$alpha$$ ti$$) nil 16212069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 16312069Sbaden (t `(return ,(frm_hnk 'alpha$$ (parse tkn)))))) 16412069Sbaden 16512069Sbaden (defun (p$alpha$$ alpha$$) nil 16612069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 16712069Sbaden (t `(return ,(frm_hnk 'alpha$$ (parse tkn)))))) 16812069Sbaden 16912069Sbaden (defun (p$alpha$$ lparen$$) nil 17012069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 17112069Sbaden (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) 17212069Sbaden 17312069Sbaden (defun (p$alpha$$ arrow$$) nil 17412069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 17512069Sbaden (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) 17612069Sbaden 17712069Sbaden (defun (p$alpha$$ semi$$) nil 17812069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_alpha))) 17912069Sbaden (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) 18012069Sbaden 18112069Sbaden (defun (p$alpha$$ while$$) nil 18212069Sbaden (cond ((twop wslen) (*throw 'parse$err '(err$$ ill_alpha))) 18312069Sbaden (t `(Push ,(frm_hnk 'alpha$$ (parse tkn)))))) 18412069Sbaden 18512069Sbaden 18612069Sbaden (defun (p$insert$$ top_lev) nil 18712069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 18812069Sbaden (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) 18912069Sbaden 19012069Sbaden (defun (p$insert$$ compos$$) nil 19112069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 19212069Sbaden (t `(return ,(frm_hnk 'insert$$ (parse tkn)))))) 19312069Sbaden 19412069Sbaden (defun (p$insert$$ constr$$) nil 19512069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 19612069Sbaden (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) 19712069Sbaden 19812069Sbaden (defun (p$insert$$ insert$$) nil 19912069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 20012069Sbaden (t `(return ,(frm_hnk 'insert$$ (parse tkn)))))) 20112069Sbaden 20212069Sbaden (defun (p$insert$$ ti$$) nil 20312069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 20412069Sbaden (t `(return ,(frm_hnk 'insert$$ (parse tkn)))))) 20512069Sbaden 20612069Sbaden (defun (p$insert$$ alpha$$) nil 20712069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 20812069Sbaden (t `(return ,(frm_hnk 'insert$$ (parse tkn)))))) 20912069Sbaden 21012069Sbaden (defun (p$insert$$ lparen$$) nil 21112069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 21212069Sbaden (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) 21312069Sbaden 21412069Sbaden (defun (p$insert$$ arrow$$) nil 21512069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 21612069Sbaden (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) 21712069Sbaden 21812069Sbaden (defun (p$insert$$ semi$$) nil 21912069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_insert))) 22012069Sbaden (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) 22112069Sbaden 22212069Sbaden (defun (p$insert$$ while$$) nil 22312069Sbaden (cond ((twop wslen) (*throw 'parse$err '(err$$ ill_insert))) 22412069Sbaden (t `(Push ,(frm_hnk 'insert$$ (parse tkn)))))) 22512069Sbaden 22612069Sbaden 22712069Sbaden (defun (p$ti$$ top_lev) nil 22812069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 22912069Sbaden (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) 23012069Sbaden 23112069Sbaden (defun (p$ti$$ compos$$) nil 23212069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 23312069Sbaden (t `(return ,(frm_hnk 'ti$$ (parse tkn)))))) 23412069Sbaden 23512069Sbaden (defun (p$ti$$ constr$$) nil 23612069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 23712069Sbaden (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) 23812069Sbaden 23912069Sbaden (defun (p$ti$$ insert$$) nil 24012069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 24112069Sbaden (t `(return ,(frm_hnk 'ti$$ (parse tkn)))))) 24212069Sbaden 24312069Sbaden (defun (p$ti$$ ti$$) nil 24412069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 24512069Sbaden (t `(return ,(frm_hnk 'ti$$ (parse tkn)))))) 24612069Sbaden 24712069Sbaden (defun (p$ti$$ alpha$$) nil 24812069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 24912069Sbaden (t `(return ,(frm_hnk 'ti$$ (parse tkn)))))) 25012069Sbaden 25112069Sbaden (defun (p$ti$$ lparen$$) nil 25212069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 25312069Sbaden (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) 25412069Sbaden 25512069Sbaden (defun (p$ti$$ arrow$$) nil 25612069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 25712069Sbaden (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) 25812069Sbaden 25912069Sbaden (defun (p$ti$$ semi$$) nil 26012069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ ill_ai))) 26112069Sbaden (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) 26212069Sbaden 26312069Sbaden (defun (p$ti$$ while$$) nil 26412069Sbaden (cond ((twop wslen) (*throw 'parse$err '(err$$ ill_ai))) 26512069Sbaden (t `(Push ,(frm_hnk 'ti$$ (parse tkn)))))) 26612069Sbaden 26712069Sbaden 26812069Sbaden (defun (p$compos$$ top_lev) nil 26912069Sbaden `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) 27012069Sbaden 27112069Sbaden (defun (p$compos$$ compos$$) nil 27212069Sbaden `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) 27312069Sbaden 27412069Sbaden (defun (p$compos$$ constr$$) nil 27512069Sbaden `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) 27612069Sbaden 27712069Sbaden (defun (p$compos$$ lparen$$) nil 27812069Sbaden `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) 27912069Sbaden 28012069Sbaden (defun (p$compos$$ arrow$$) nil 28112069Sbaden `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) 28212069Sbaden 28312069Sbaden (defun (p$compos$$ semi$$) nil 28412069Sbaden `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) 28512069Sbaden 28612069Sbaden (defun (p$compos$$ while$$) nil 28712069Sbaden `(Push ,(frm_hnk 'compos$$ (Pop) (parse tkn)))) 28812069Sbaden 28912069Sbaden 29012069Sbaden (defun (p$comma$$ constr$$) nil 29112069Sbaden `(return ,(Pop))) 29212069Sbaden 29312069Sbaden (defun (p$comma$$ semi$$) nil 29412069Sbaden `(comma$$ ,(Pop))) 29512069Sbaden 29612069Sbaden 29712069Sbaden (defun (p$lbrack$$ top_lev) nil 29812069Sbaden `(Push ,(get_constr))) 29912069Sbaden 30012069Sbaden (defun (p$lbrack$$ compos$$) nil 30112069Sbaden `(return ,(get_constr))) 30212069Sbaden 30312069Sbaden (defun (p$lbrack$$ constr$$) nil 30412069Sbaden `(Push ,(get_constr))) 30512069Sbaden 30612069Sbaden (defun (p$lbrack$$ lparen$$) nil 30712069Sbaden `(Push ,(get_constr))) 30812069Sbaden 30912069Sbaden (defun (p$lbrack$$ arrow$$) nil 31012069Sbaden `(Push ,(get_constr))) 31112069Sbaden 31212069Sbaden (defun (p$lbrack$$ semi$$) nil 31312069Sbaden `(Push ,(get_constr))) 31412069Sbaden 31512069Sbaden (defun (p$lbrack$$ alpha$$) nil 31612069Sbaden `(return ,(get_constr))) 31712069Sbaden 31812069Sbaden (defun (p$lbrack$$ insert$$) nil 31912069Sbaden `(return ,(get_constr))) 32012069Sbaden 32112069Sbaden (defun (p$lbrack$$ ti$$) nil 32212069Sbaden `(return ,(get_constr))) 32312069Sbaden 32412069Sbaden (defun (p$lbrack$$ while$$) nil 32512069Sbaden `(Push ,(get_constr))) 32612069Sbaden 32712069Sbaden 32812069Sbaden (defun (p$rbrack$$ constr$$) nil 32912069Sbaden `(return done ,(cond ((null stk) nil) 33012069Sbaden (t (Pop))))) 33112069Sbaden 33212069Sbaden (defun (p$rbrack$$ semi$$) nil 33312069Sbaden `(rbrack$$ ,`(done ,(cond ((null stk) nil) 33412069Sbaden (t (Pop)))))) 33512069Sbaden 33612069Sbaden 33712069Sbaden (defun (p$defined$$ top_lev) nil 33812069Sbaden `(Push ,(concat (cadr tkn) '_fp))) 33912069Sbaden 34012069Sbaden (defun (p$defined$$ compos$$) nil 34112069Sbaden `(return ,(concat (cadr tkn) '_fp))) 34212069Sbaden 34312069Sbaden (defun (p$defined$$ constr$$) nil 34412069Sbaden `(Push ,(concat (cadr tkn) '_fp))) 34512069Sbaden 34612069Sbaden (defun (p$defined$$ lparen$$) nil 34712069Sbaden `(Push ,(concat (cadr tkn) '_fp))) 34812069Sbaden 34912069Sbaden (defun (p$defined$$ arrow$$) nil 35012069Sbaden `(Push ,(concat (cadr tkn) '_fp))) 35112069Sbaden 35212069Sbaden (defun (p$defined$$ semi$$) nil 35312069Sbaden `(Push ,(concat (cadr tkn) '_fp))) 35412069Sbaden 35512069Sbaden (defun (p$defined$$ alpha$$) nil 35612069Sbaden `(return ,(concat (cadr tkn) '_fp))) 35712069Sbaden 35812069Sbaden (defun (p$defined$$ insert$$) nil 35912069Sbaden `(return ,(concat (cadr tkn) '_fp))) 36012069Sbaden 36112069Sbaden (defun (p$defined$$ ti$$) nil 36212069Sbaden `(return ,(concat (cadr tkn) '_fp))) 36312069Sbaden 36412069Sbaden (defun (p$defined$$ while$$) nil 36512069Sbaden `(Push ,(concat (cadr tkn) '_fp))) 36612069Sbaden 36712069Sbaden 36812069Sbaden (defun (p$builtin$$ top_lev) nil 36912069Sbaden `(Push ,(concat (cadr tkn) '$fp))) 37012069Sbaden 37112069Sbaden (defun (p$builtin$$ compos$$) nil 37212069Sbaden `(return ,(concat (cadr tkn) '$fp))) 37312069Sbaden 37412069Sbaden (defun (p$builtin$$ constr$$) nil 37512069Sbaden `(Push ,(concat (cadr tkn) '$fp))) 37612069Sbaden 37712069Sbaden (defun (p$builtin$$ lparen$$) nil 37812069Sbaden `(Push ,(concat (cadr tkn) '$fp))) 37912069Sbaden 38012069Sbaden (defun (p$builtin$$ arrow$$) nil 38112069Sbaden `(Push ,(concat (cadr tkn) '$fp))) 38212069Sbaden 38312069Sbaden (defun (p$builtin$$ semi$$) nil 38412069Sbaden `(Push ,(concat (cadr tkn) '$fp))) 38512069Sbaden 38612069Sbaden (defun (p$builtin$$ alpha$$) nil 38712069Sbaden `(return ,(concat (cadr tkn) '$fp))) 38812069Sbaden 38912069Sbaden (defun (p$builtin$$ insert$$) nil 39012069Sbaden `(return ,(concat (cadr tkn) '$fp))) 39112069Sbaden 39212069Sbaden (defun (p$builtin$$ ti$$) nil 39312069Sbaden `(return ,(concat (cadr tkn) '$fp))) 39412069Sbaden 39512069Sbaden (defun (p$builtin$$ while$$) nil 39612069Sbaden `(Push ,(concat (cadr tkn) '$fp))) 39712069Sbaden 39812069Sbaden 39912069Sbaden (defun (p$select$$ top_lev) nil 40012069Sbaden `(Push ,(makhunk tkn))) 40112069Sbaden 40212069Sbaden (defun (p$select$$ compos$$) nil 40312069Sbaden `(return ,(makhunk tkn))) 40412069Sbaden 40512069Sbaden (defun (p$select$$ constr$$) nil 40612069Sbaden `(Push ,(makhunk tkn))) 40712069Sbaden 40812069Sbaden (defun (p$select$$ lparen$$) nil 40912069Sbaden `(Push ,(makhunk tkn))) 41012069Sbaden 41112069Sbaden (defun (p$select$$ arrow$$) nil 41212069Sbaden `(Push ,(makhunk tkn))) 41312069Sbaden 41412069Sbaden (defun (p$select$$ semi$$) nil 41512069Sbaden `(Push ,(makhunk tkn))) 41612069Sbaden 41712069Sbaden (defun (p$select$$ alpha$$) nil 41812069Sbaden `(return ,(makhunk tkn))) 41912069Sbaden 42012069Sbaden (defun (p$select$$ while$$) nil 42112069Sbaden `(Push ,(makhunk tkn))) 42212069Sbaden 42312069Sbaden 42412069Sbaden (defun (p$constant$$ top_lev) nil 42512069Sbaden `(Push ,(makhunk tkn))) 42612069Sbaden 42712069Sbaden (defun (p$constant$$ compos$$) nil 42812069Sbaden `(return ,(makhunk tkn))) 42912069Sbaden 43012069Sbaden (defun (p$constant$$ constr$$) nil 43112069Sbaden `(Push ,(makhunk tkn))) 43212069Sbaden 43312069Sbaden (defun (p$constant$$ lparen$$) nil 43412069Sbaden `(Push ,(makhunk tkn))) 43512069Sbaden 43612069Sbaden (defun (p$constant$$ arrow$$) nil 43712069Sbaden `(Push ,(makhunk tkn))) 43812069Sbaden 43912069Sbaden (defun (p$constant$$ semi$$) nil 44012069Sbaden `(Push ,(makhunk tkn))) 44112069Sbaden 44212069Sbaden (defun (p$constant$$ alpha$$) nil 44312069Sbaden `(return ,(makhunk tkn))) 44412069Sbaden 44512069Sbaden (defun (p$constant$$ while$$) nil 44612069Sbaden `(Push ,(makhunk tkn))) 44712069Sbaden 44812069Sbaden 44912069Sbaden (defun (p$colon$$ top_lev) nil 45012069Sbaden (cond (in_def (*throw 'parse$err '(err$$ ill_appl))) 45112069Sbaden (t `(return ,(Pop))))) 45212069Sbaden 45312069Sbaden (defun (p$colon$$ semi$$) nil 45412069Sbaden (cond (in_def (*throw 'parse$err '(err$$ ill_appl))) 45512069Sbaden (t `(colon$$ ,(Pop))))) 45612069Sbaden 45712069Sbaden 45812069Sbaden (defun (p$arrow$$ lparen$$) nil 45912069Sbaden (get_condit)) 46012069Sbaden 46112069Sbaden 46212069Sbaden (defun (p$semi$$ arrow$$) nil 46312069Sbaden `(return ,(Pop))) 46412069Sbaden 46512069Sbaden (defun (p$while$$ lparen$$) nil 46612069Sbaden (cond ((not (null stk)) (*throw 'parse$err '(err$$ bad_while))) 46712069Sbaden (t (get_while)))) 46812069Sbaden 46912069Sbaden 47012069Sbaden ; parse action support functions 47112069Sbaden 47212069Sbaden (defun get_condit nil 47312069Sbaden (prog (q r) 47412069Sbaden (setq q (parse 'arrow$$)) 47512069Sbaden (cond ((and (listp q) (find 'err$$ q)) (*throw 'parse$err q))) 47612069Sbaden (setq r (parse 'semi$$)) 47712069Sbaden (cond ((and (listp r) (find 'err$$ r)) (*throw 'parse$err r))) 47812069Sbaden (*throw 'end_condit (frm_hnk 'condit$$ (Pop) q r)))) 47912069Sbaden 48012069Sbaden 48112069Sbaden (defun Push (value) 48212069Sbaden (cond ((eq flag 'while$$) 48312069Sbaden (cond 48412069Sbaden ((zerop wslen) (setq stk value) (setq wslen 1)) 48512069Sbaden ((onep wslen) (setq stk (list stk value)) (setq wslen 2)) 48612069Sbaden (t (*throw 'parse$err '(err$$ bad_while Push))))) 48712069Sbaden (t (setq stk value)))) 48812069Sbaden 48912069Sbaden (defun Pop nil 49012069Sbaden (cond 49112069Sbaden ((null stk) (*throw 'parse$err '(err$$ stk_emp))) 49212069Sbaden (t 49312069Sbaden (prog (tmp) 49412069Sbaden (setq tmp stk) 49512069Sbaden (cond ((eq flag 'while$$) 49612069Sbaden (cond ((onep wslen) (setq stk nil) (setq wslen 0) (return tmp)) 49712069Sbaden ((twop wslen) 49812069Sbaden (setq stk (car tmp)) (setq wslen 1) (return (cadr tmp))) 49912069Sbaden (t (*throw 'parse$err '(err$$ bad_while Pop))))) 50012069Sbaden (t (setq stk nil) 50112069Sbaden (return tmp))))))) 50212069Sbaden 50312069Sbaden (defun get_def nil 50412069Sbaden (prog (dummy) 50512069Sbaden (setq in_def t) 50612069Sbaden (setq dummy (get_tkn)) 50712069Sbaden (cond ((find 'builtin$$ dummy) (*throw 'parse$err '(err$$ redef))) 50812069Sbaden ((not (find 'defined$$ dummy)) (*throw 'parse$err '(err$$ bad_nam))) 50912069Sbaden (t (setq fn_name (concat (cadr dummy) '_fp)))))) 51012069Sbaden 51112069Sbaden 51212069Sbaden (defun get_constr nil 51312069Sbaden (cond ((eq flag 'while$$) (cond 51412069Sbaden ((twop wslen) (*throw 'parse$err `(err$$ bad_whl ,stk ,tkn))))) 51512069Sbaden (t (cond ((not (null stk)) (*throw 'parse$err '(err$$ bad_constr parse)))))) 51612069Sbaden (do 51712069Sbaden ((v (parse 'constr$$) (parse 'constr$$)) 51812069Sbaden (temp nil) 51912069Sbaden (fn_lst nil)) 52012069Sbaden 52112069Sbaden ((eq tkn 'eof$$) (*throw 'parse$err '(err$$ eof$$))) 52212069Sbaden 52312069Sbaden (cond 52412069Sbaden ((listp v) 52512069Sbaden (cond ((eq (car v) 'err$$) (*throw 'parse$err v)) 52612069Sbaden ((eq (car v) 'done) 52712069Sbaden (cond ((eq (cadr v) 'err$$) (*throw 'parse$err (cdr v))) 52812069Sbaden (t (return 52912069Sbaden (makhunk (cons 'constr$$ (reverse (cons (cadr v) fn_lst)))))))) 53012069Sbaden (t (setq fn_lst (cons v fn_lst))))) 53112069Sbaden (t (setq fn_lst (cons v fn_lst)))))) 53212069Sbaden 53312069Sbaden (def frm_hnk (lexpr (z) 53412069Sbaden (prog (l bad_one) 53512069Sbaden (setq l (listify z)) 53612069Sbaden (setq bad_one (assq 'err$$ (cdr l))) 53712069Sbaden (cond ((null bad_one) (return (makhunk l))) 53812069Sbaden (t (*throw 'parse$err bad_one)))))) 53912069Sbaden 54012069Sbaden 54112069Sbaden 54212069Sbaden (defun prs_fn nil 54312069Sbaden (concat 'p$ (cond ((atom tkn) tkn) 54412069Sbaden (t (car tkn))))) 54512069Sbaden 54612069Sbaden (defun get_while nil 54712069Sbaden (let ((r (parse 'while$$))) 54812069Sbaden (cond ((and (listp r) (find 'err$$ r)) (*throw 'parse$err r)) 54912069Sbaden (t (*throw 'end_while (frm_hnk 'while$$ (car r) (cadr r))))))) 55012069Sbaden 55112069Sbaden (defun twop (x) 55212069Sbaden (eq 2 x)) 55312069Sbaden 554