home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / o / ops5.zip / OPS-COMP.LI < prev    next >
Lisp/Scheme  |  1992-05-31  |  23KB  |  806 lines
  1. ;
  2. ;************************************************************************
  3. ;
  4. ;    VPS2 -- Interpreter for OPS5
  5. ;
  6. ;
  7. ;
  8. ; This Common Lisp version of OPS5 is in the public domain.  It is based
  9. ; in part on based on a Franz Lisp implementation done by Charles L. Forgy
  10. ; at Carnegie-Mellon University, which was placed in the public domain by
  11. ; the author in accordance with CMU policies.  This version has been
  12. ; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
  13. ; and Dan Kuokka.
  14. ;
  15. ; This code is made available is, and without warranty of any kind by the
  16. ; authors or by Carnegie-Mellon University.
  17. ;
  18.  
  19. ;;;; This file contains functions compile productions.
  20.  
  21. (in-package "OPS")
  22. (shadow '(remove write))    ; Should get this by requiring ops-rhs
  23. (export '--> )
  24.  
  25.  
  26. ;;; External global variables
  27.  
  28. (defvar *real-cnt*)
  29. (defvar *virtual-cnt*)
  30. (defvar *last-node*)
  31. (defvar *first-node*)
  32. (defvar *pcount*)
  33.  
  34.  
  35. ;;; Internal global variables
  36.  
  37. (defvar *matrix*)
  38. (defvar *curcond*)
  39. (defvar *feature-count*)
  40. (defvar *ce-count*)
  41. (defvar *vars*)
  42. (defvar *ce-vars*)
  43. (defvar *rhs-bound-vars*)
  44. (defvar *rhs-bound-ce-vars*)
  45. (defvar *last-branch*)
  46. (defvar *subnum*)
  47. (defvar *cur-vars*)
  48. (defvar *action-type*)
  49.  
  50.  
  51.  
  52. (defun compile-init ()
  53.   (setq *real-cnt* (setq *virtual-cnt* 0.))
  54.   (setq *pcount* 0.)
  55.   (make-bottom-node))
  56.  
  57.  
  58. ;;; LHS Compiler
  59.  
  60. (defun ops-p (z) 
  61.   (finish-literalize)
  62.   (princ '*) 
  63.   ;(drain) commented out temporarily
  64.   (force-output)            ;@@@ clisp drain?
  65.   (compile-production (car z) (cdr z))) 
  66.  
  67.  
  68. (defun compile-production (name matrix) ;jgk inverted args to catch and quoted tag
  69.   (setq *p-name* name)
  70.   (catch '!error! (cmp-p name matrix))
  71.   (setq *p-name* nil))
  72. #|
  73. (defun compile-production (name matrix) ;jgk inverted args to catch 
  74.   (prog (erm)                ;and quoted tag
  75.     (setq *p-name* name)
  76.     (setq erm (catch '!error! (cmp-p name matrix)))
  77.     (setq *p-name* nil)))
  78. |#
  79.  
  80. (defun peek-lex nil (car *matrix*)) 
  81.  
  82. (defun lex nil
  83.   (prog2 nil (car *matrix*) (setq *matrix* (cdr *matrix*)))) 
  84.  
  85. (defun end-of-p nil (atom *matrix*)) 
  86.  
  87. (defun rest-of-p nil *matrix*) 
  88.  
  89. (defun prepare-lex (prod) (setq *matrix* prod)) 
  90.  
  91.  
  92. (defun peek-sublex nil (car *curcond*)) 
  93.  
  94. (defun sublex nil
  95.   (prog2 nil (car *curcond*) (setq *curcond* (cdr *curcond*)))) 
  96.  
  97. (defun end-of-ce nil (atom *curcond*)) 
  98.  
  99. (defun rest-of-ce nil *curcond*) 
  100.  
  101. (defun prepare-sublex (ce) (setq *curcond* ce)) 
  102.  
  103. (defun make-bottom-node nil (setq *first-node* (list '&bus nil))) 
  104.  
  105. (defun cmp-p (name matrix)
  106.   (prog (m bakptrs)
  107.     (cond ((or (null name) (consp  name))    ;dtpr\consp gdw
  108.        (%error '|illegal production name| name))
  109.       ((equal (get name 'production) matrix)
  110.        (return nil)))
  111.     (prepare-lex matrix)
  112.     (excise-p name)
  113.     (setq bakptrs nil)
  114.     (setq *pcount* (1+ *pcount*))        ;"plus" changed to "+" by gdw
  115.     (setq *feature-count* 0.)
  116.     (setq *ce-count* 0)
  117.     (setq *vars* nil)
  118.     (setq *ce-vars* nil)
  119.     (setq *rhs-bound-vars* nil)
  120.     (setq *rhs-bound-ce-vars* nil)
  121.     (setq *last-branch* nil)
  122.     (setq m (rest-of-p))
  123.     l1   (and (end-of-p) (%error '|no '-->' in production| m))
  124.     (cmp-prin)
  125.     (setq bakptrs (cons *last-branch* bakptrs))
  126.     (or (eq '--> (peek-lex)) (go l1))
  127.     (lex)
  128.     (check-rhs (rest-of-p))
  129.     (link-new-node (list '&p
  130.              *feature-count*
  131.              name
  132.              (encode-dope)
  133.              (encode-ce-dope)
  134.              (cons 'progn (rest-of-p))))
  135.     (putprop name (cdr (nreverse bakptrs)) 'backpointers)
  136.     (putprop name matrix 'production)
  137.     (putprop name *last-node* 'topnode))) 
  138.  
  139. (defun rating-part (pnode) (cadr pnode)) 
  140.  
  141. (defun var-part (pnode) (car (cdddr pnode))) 
  142.  
  143. (defun ce-var-part (pnode) (cadr (cdddr pnode))) 
  144.  
  145. (defun rhs-part (pnode) (caddr (cdddr pnode))) 
  146.  
  147. (defun cmp-prin nil
  148.   (prog nil
  149.     (setq *last-node* *first-node*)
  150.     (cond ((null *last-branch*) (cmp-posce) (cmp-nobeta))
  151.       ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
  152.       (t (cmp-posce) (cmp-and))))) 
  153.  
  154. (defun cmp-negce nil (lex) (cmp-ce)) 
  155.  
  156. (defun cmp-posce nil
  157.   (setq *ce-count* (1+ *ce-count*))        ;"plus" changed to "+" by gdw
  158.   (cond ((eq (peek-lex) '\{) (cmp-ce+cevar))    ;"plus" changed to "+" by gdw
  159.     (t (cmp-ce)))) 
  160.  
  161. (defun cmp-ce+cevar nil
  162.   (prog (z)
  163.     (lex)
  164.     (cond ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
  165.       (t (cmp-ce) (cmp-cevar)))
  166.     (setq z (lex))
  167.     (or (eq z '\}) (%error '|missing '}'| z)))) 
  168.  
  169. (defun new-subnum (k)
  170.   (or (numberp k) (%error '|tab must be a number| k))
  171.   (setq *subnum* (fix k))) 
  172.  
  173. (defun incr-subnum nil (setq *subnum* (1+ *subnum*))) 
  174.  
  175. (defun cmp-ce nil
  176.   (prog (z)
  177.     (new-subnum 0.)
  178.     (setq *cur-vars* nil)
  179.     (setq z (lex))
  180.     (and (atom z)
  181.      (%error '|atomic conditions are not allowed| z))
  182.     (prepare-sublex z)
  183.     la   (and (end-of-ce) (return nil))
  184.     (incr-subnum)
  185.     (cmp-element)
  186.     (go la))) 
  187.  
  188. (defun cmp-element nil
  189.   (and (eq (peek-sublex) '^) (cmp-tab))
  190.   (cond ((eq (peek-sublex) '\{) (cmp-product))
  191.     (t (cmp-atomic-or-any))))
  192.  
  193. (defun cmp-atomic-or-any nil
  194.   (cond ((eq (peek-sublex) '<<) (cmp-any))
  195.     (t (cmp-atomic))))
  196.  
  197. (defun cmp-any nil
  198.   (prog (a z)
  199.     (sublex)
  200.     (setq z nil)
  201.     la   (cond ((end-of-ce) (%error '|missing '>>'| a)))
  202.     (setq a (sublex))
  203.     (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
  204.     (link-new-node (list '&any nil (current-field) z)))) 
  205.  
  206.  
  207. (defun cmp-tab nil
  208.   (prog (r)
  209.     (sublex)
  210.     (setq r (sublex))
  211.     (setq r ($litbind r))
  212.     (new-subnum r))) 
  213.  
  214. (defun get-bind (x)
  215.   (prog (r)
  216.     (cond ((and (symbolp x) (setq r (literal-binding-of x)))
  217.        (return r))
  218.       (t (return nil))))) 
  219.  
  220. (defun cmp-atomic nil
  221.   (prog (test x)
  222.     (setq x (peek-sublex))
  223.     (cond ((eq x '= ) (setq test 'eq) (sublex))
  224.       ((eq x '<>) (setq test 'ne) (sublex))
  225.       ((eq x '<) (setq test 'lt) (sublex))
  226.       ((eq x '<=) (setq test 'le) (sublex))
  227.       ((eq x '>) (setq test 'gt) (sublex))
  228.       ((eq x '>=) (setq test 'ge) (sublex))
  229.       ((eq x '<=>) (setq test 'xx) (sublex))
  230.       (t (setq test 'eq)))
  231.     (cmp-symbol test))) 
  232.  
  233. (defun cmp-product nil
  234.   (prog (save)
  235.     (setq save (rest-of-ce))
  236.     (sublex)
  237.     la   (cond ((end-of-ce)
  238.         (cond ((member '\} save :test #'equal) 
  239.                (%error '|wrong contex for '}'| save))
  240.               (t (%error '|missing '}'| save))))
  241.            ((eq (peek-sublex) '\}) (sublex) (return nil)))
  242.     (cmp-atomic-or-any)
  243.     (go la))) 
  244.  
  245. (defun cmp-symbol (test)
  246.   (prog (flag)
  247.     (setq flag t)
  248.     (cond ((eq (peek-sublex) '//) (sublex) (setq flag nil)))
  249.     (cond ((and flag (variablep (peek-sublex)))
  250.        (cmp-var test))
  251.       ((numberp (peek-sublex)) (cmp-number test))
  252.       ((symbolp (peek-sublex)) (cmp-constant test))
  253.       (t (%error '|unrecognized symbol| (sublex)))))) 
  254.  
  255. (defun cmp-constant (test)   ;jgk inserted concatenate form
  256.   (or (member test '(eq ne xx))
  257.       (%error '|non-numeric constant after numeric predicate| (sublex)))
  258.   (link-new-node (list (intern (concatenate 'string
  259.                         "T"
  260.                         (symbol-name  test)
  261.                         "A"))
  262.                nil
  263.                (current-field)
  264.                (sublex)))) 
  265.  
  266. (defun cmp-number (test)   ;jgk inserted concatenate form
  267.   (link-new-node (list (intern (concatenate 'string
  268.                         "T"
  269.                         (symbol-name  test)
  270. ;@@@ error? reported by laird fix\        "A"))
  271.                "N"))
  272.   nil
  273.   (current-field)
  274.   (sublex)))) 
  275.  
  276. (defun current-field nil (field-name *subnum*)) 
  277.  
  278. (defun field-name (num)
  279.   (if (< 0 num 127)
  280.       (svref '#(nil *c1* *c2* *c3* *c4* *c5* *c6* *c7* *c8* *c9* *c10* *c11*
  281.             *c12* *c13* *c14* *c15* *c16* *c17* *c18* *c19* *c20* *c21*
  282.             *c22* *c23* *c24* *c25* *c26* *c27* *c28* *c29* *c30* *c31*
  283.             *c32* *c33* *c34* *c35* *c36* *c37* *c38* *c39* *c40* *c41*
  284.             *c42* *c43* *c44* *c45* *c46* *c47* *c48* *c49* *c50* *c51*
  285.             *c52* *c53* *c54* *c55* *c56* *c57* *c58* *c59* *c60* *c61*
  286.             *c62* *c63* *c64* *c65* *c66* *c67* *c68* *c69* *c70* *c71*
  287.             *c72* *c73* *c74* *c75* *c76* *c77* *c78* *c79* *c80* *c81*
  288.             *c82* *c83* *c84* *c85* *c86* *c87* *c88* *c89* *c90* *c91*
  289.             *c92* *c93* *c94* *c95* *c96* *c97* *c98* *c99* *c100*
  290.             *c101* *c102* *c103* *c104* *c105* *c106* *c107* *c108*
  291.             *c109* *c110* *c111* *c112* *c113* *c114* *c115* *c116*
  292.             *c117* *c118* *c119* *c120* *c121* *c122* *c123* *c124*
  293.             *c125* *c126* *c127*)
  294.          num)
  295.       (%error '|condition is too long| (rest-of-ce))))
  296.  
  297. ;;; Compiling variables
  298. ;
  299. ;
  300. ;
  301. ; *cur-vars* are the variables in the condition element currently 
  302. ; being compiled.  *vars* are the variables in the earlier condition
  303. ; elements.  *ce-vars* are the condition element variables.  note
  304. ; that the interpreter will not confuse condition element and regular
  305. ; variables even if they have the same name.
  306. ;
  307. ; *cur-vars* is a list of triples: (name predicate subelement-number)
  308. ; eg:        ( (<x> eq 3)
  309. ;          (<y> ne 1)
  310. ;          . . . )
  311. ;
  312. ; *vars* is a list of triples: (name ce-number subelement-number)
  313. ; eg:        ( (<x> 3 3)
  314. ;          (<y> 1 1)
  315. ;          . . . )
  316. ;
  317. ; *ce-vars* is a list of pairs: (name ce-number)
  318. ; eg:        ( (ce1 1)
  319. ;          (<c3> 3)
  320. ;          . . . )
  321.  
  322. (defmacro var-dope (var) `(assq ,var *vars*))
  323.  
  324. (defmacro ce-var-dope (var) `(assq ,var *ce-vars*))
  325.  
  326. (defun cmp-var (test)
  327.   (prog (old name)
  328.     (setq name (sublex))
  329.     (setq old (assq name *cur-vars*))
  330.     (cond ((and old (eq (cadr old) 'eq))
  331.        (cmp-old-eq-var test old))
  332.       ((and old (eq test 'eq)) (cmp-new-eq-var name old))
  333.       (t (cmp-new-var name test))))) 
  334.  
  335. (defun cmp-new-var (name test)
  336.   (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*))) 
  337.  
  338. (defun cmp-old-eq-var (test old)  ; jgk inserted concatenate form
  339.   (link-new-node (list (intern (concatenate 'string
  340.                         "T"
  341.                         (symbol-name  test)
  342.                         "S"))
  343.                nil
  344.                (current-field)
  345.                (field-name (caddr old))))) 
  346.  
  347.  
  348.  
  349. (defun cmp-new-eq-var (name old)  ;jgk inserted concatenate form
  350.   (prog (pred next)
  351.     (setq *cur-vars* (delq old *cur-vars*))
  352.     (setq next (assq name *cur-vars*))
  353.     (cond (next (cmp-new-eq-var name next))
  354.       (t (cmp-new-var name 'eq)))
  355.     (setq pred (cadr old))
  356.     (link-new-node (list (intern (concatenate 'string
  357.                           "T"
  358.                           (symbol-name  pred)
  359.                           "S"))
  360.              nil
  361.              (field-name (caddr old))
  362.              (current-field))))) 
  363.  
  364. (defun cmp-cevar nil
  365.   (prog (name old)
  366.     (setq name (lex))
  367.     (setq old (assq name *ce-vars*))
  368.     (and old
  369.      (%error '|condition element variable used twice| name))
  370.     (setq *ce-vars* (cons (list name 0.) *ce-vars*)))) 
  371.  
  372. (defun cmp-not nil (cmp-beta '¬)) 
  373.  
  374. (defun cmp-nobeta nil (cmp-beta nil)) 
  375.  
  376. (defun cmp-and nil (cmp-beta '&and)) 
  377.  
  378. (defun cmp-beta (kind)
  379.   (prog (tlist vdope vname #|vpred vpos|# old)
  380.     (setq tlist nil)
  381.     la   (and (atom *cur-vars*) (go lb))
  382.     (setq vdope (car *cur-vars*))
  383.     (setq *cur-vars* (cdr *cur-vars*))
  384.     (setq vname (car vdope))
  385.     ;;  (setq vpred (cadr vdope))    Dario - commented out (unused)
  386.     ;;  (setq vpos (caddr vdope))
  387.     (setq old (assq vname *vars*))
  388.     (cond (old (setq tlist (add-test tlist vdope old)))
  389.       ((not (eq kind '¬)) (promote-var vdope)))
  390.     (go la)
  391.     lb   (and kind (build-beta kind tlist))
  392.     (or (eq kind '¬) (fudge))
  393.     (setq *last-branch* *last-node*))) 
  394.  
  395. (defun add-test (list new old) ; jgk inserted concatenate form
  396.   (prog (ttype lloc rloc)
  397.     (setq *feature-count* (1+ *feature-count*))
  398.     (setq ttype (intern (concatenate 'string "T"
  399.                      (symbol-name (cadr new))
  400.                      "B")))
  401.     (setq rloc (encode-singleton (caddr new)))
  402.     (setq lloc (encode-pair (cadr old) (caddr old)))
  403.     (return (cons ttype (cons lloc (cons rloc list)))))) 
  404.  
  405. ; the following two functions encode indices so that gelm can
  406. ; decode them as fast as possible
  407.  
  408. (defun encode-pair (a b)
  409.   (logior (ash (1- a) encode-pair-shift) (1- b))) 
  410.  
  411. (defun encode-singleton (a) (1- a)) 
  412.  
  413. (defun promote-var (dope)
  414.   (prog (vname vpred vpos new)
  415.     (setq vname (car dope))
  416.     (setq vpred (cadr dope))
  417.     (setq vpos (caddr dope))
  418.     (or (eq 'eq vpred)
  419.     (%error '|illegal predicate for first occurrence|
  420.         (list vname vpred)))
  421.     (setq new (list vname 0. vpos))
  422.     (setq *vars* (cons new *vars*)))) 
  423.  
  424. (defun fudge nil
  425.   (mapc (function fudge*) *vars*)
  426.   (mapc (function fudge*) *ce-vars*)) 
  427.  
  428. (defun fudge* (z)
  429.   (prog (a) (setq a (cdr z)) (rplaca a (1+ (car a))))) 
  430.  
  431. (defun build-beta (type tests)
  432.   (prog (rpred lpred lnode lef)
  433.     (link-new-node (list '&mem nil nil (protomem)))
  434.     (setq rpred *last-node*)
  435.     (cond ((eq type '&and)
  436.        (setq lnode (list '&mem nil nil (protomem))))
  437.       (t (setq lnode (list '&two nil nil))))
  438.     (setq lpred (link-to-branch lnode))
  439.     (cond ((eq type '&and) (setq lef lpred))
  440.       (t (setq lef (protomem))))
  441.     (link-new-beta-node (list type nil lef rpred tests)))) 
  442.  
  443. (defun protomem nil (list nil)) 
  444.  
  445. (defun memory-part (mem-node) (car (cadddr mem-node))) 
  446.  
  447. (defun encode-dope nil
  448.   (prog (r all z k)
  449.     (setq r nil)
  450.     (setq all *vars*)
  451.     la   (and (atom all) (return r))
  452.     (setq z (car all))
  453.     (setq all (cdr all))
  454.     (setq k (encode-pair (cadr z) (caddr z)))
  455.     (setq r (cons (car z) (cons k r)))
  456.     (go la))) 
  457.  
  458. (defun encode-ce-dope nil
  459.   (prog (r all z k)
  460.     (setq r nil)
  461.     (setq all *ce-vars*)
  462.     la   (and (atom all) (return r))
  463.     (setq z (car all))
  464.     (setq all (cdr all))
  465.     (setq k (cadr z))
  466.     (setq r (cons (car z) (cons k r)))
  467.     (go la))) 
  468.  
  469.  
  470.  
  471. ;;; Linking the nodes
  472.  
  473. (defun link-new-node (r)
  474.   (cond ((not (member (car r) '(&p &mem &two &and ¬) :test #'equal))
  475.      (setq *feature-count* (1+ *feature-count*))))
  476.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  477.   (setq *last-node* (link-left *last-node* r))) 
  478.  
  479. (defun link-to-branch (r)
  480.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  481.   (setq *last-branch* (link-left *last-branch* r))) 
  482.  
  483. (defun link-new-beta-node (r)
  484.   (setq *virtual-cnt* (1+ *virtual-cnt*))
  485.   (setq *last-node* (link-both *last-branch* *last-node* r))
  486.   (setq *last-branch* *last-node*)) 
  487.  
  488. (defun link-left (pred succ)
  489.   (prog (a r)
  490.     (setq a (left-outs pred))
  491.     (setq r (find-equiv-node succ a))
  492.     (and r (return r))
  493.     (setq *real-cnt* (1+ *real-cnt*))
  494.     (attach-left pred succ)
  495.     (return succ))) 
  496.  
  497. (defun link-both (left right succ)
  498.   (prog (a r)
  499.     (setq a (interq (left-outs left) (right-outs right)))
  500.     (setq r (find-equiv-beta-node succ a))
  501.     (and r (return r))
  502.     (setq *real-cnt* (1+ *real-cnt*))
  503.     (attach-left left succ)
  504.     (attach-right right succ)
  505.     (return succ))) 
  506.  
  507. (defun attach-right (old new)
  508.   (rplaca (cddr old) (cons new (caddr old)))) 
  509.  
  510. (defun attach-left (old new)
  511.   (rplaca (cdr old) (cons new (cadr old)))) 
  512.  
  513. (defun right-outs (node) (caddr node)) 
  514.  
  515. (defun left-outs (node) (cadr node)) 
  516.  
  517. (defun find-equiv-node (node list)
  518.   (prog (a)
  519.     (setq a list)
  520.     l1   (cond ((atom a) (return nil))
  521.            ((equiv node (car a)) (return (car a))))
  522.     (setq a (cdr a))
  523.     (go l1))) 
  524.  
  525. (defun find-equiv-beta-node (node list)
  526.   (prog (a)
  527.     (setq a list)
  528.     l1   (cond ((atom a) (return nil))
  529.            ((beta-equiv node (car a)) (return (car a))))
  530.     (setq a (cdr a))
  531.     (go l1))) 
  532.  
  533. ; do not look at the predecessor fields of beta nodes; they have to be
  534. ; identical because of the way the candidate nodes were found
  535.  
  536. (defun equiv (a b)
  537.   (and (eq (car a) (car b))
  538.        (or (eq (car a) '&mem)
  539.        (eq (car a) '&two)
  540.        (equal (caddr a) (caddr b)))
  541.        (equal (cdddr a) (cdddr b)))) 
  542.  
  543. (defun beta-equiv (a b)
  544.   (and (eq (car a) (car b))
  545.        (equal (cddddr a) (cddddr b))
  546.        (or (eq (car a) '&and) (equal (caddr a) (caddr b))))) 
  547.  
  548. ; the equivalence tests are set up to consider the contents of
  549. ; node memories, so they are ready for the build action
  550.  
  551.  
  552.  
  553. ;;; Check the RHSs of productions 
  554.  
  555.  
  556. (defun check-rhs (rhs) (mapc (function check-action) rhs))
  557.  
  558. (defun check-action (x)
  559.   (prog (a)
  560.     (cond ((atom x)
  561.        (%warn '|atomic action| x)
  562.        (return nil)))
  563.     (setq a (setq *action-type* (car x)))
  564.     (case a
  565.       (bind (check-bind x))
  566.       (cbind (check-cbind x))
  567.       (make (check-make x))
  568.       (modify (check-modify x))
  569.       (remove (check-remove x))
  570.       (write (check-write x))    
  571.       (call (check-call x))        
  572.       (halt (check-halt x))
  573.       (openfile (check-openfile x))
  574.       (closefile (check-closefile x))
  575.       (default (check-default x))
  576.       (build (check-build x))
  577.       (t (%warn '|undefined rhs action| a)))))
  578.  
  579.  
  580. ;(defun chg-to-write (x)
  581. ;    (setq x (cons 'write (cdr x))))
  582.  
  583. (defun check-build (z)
  584.   (and (null (cdr z)) (%warn '|needs arguments| z))
  585.   (check-build-collect (cdr z)))
  586.  
  587. (defun check-build-collect (args)
  588.   (prog (r)
  589.     top    (and (null args) (return nil))
  590.     (setq r (car args))
  591.     (setq args (cdr args))
  592.     (cond ((consp  r) (check-build-collect r))    ;dtpr\consp gdw
  593.       ((eq r '\\)
  594.        (and (null args) (%warn '|nothing to evaluate| r))
  595.        (check-rhs-value (car args))
  596.        (setq args (cdr args))))
  597.     (go top)))
  598.  
  599. (defun check-remove (z)                 ;@@@ kluge by gdw
  600.   (and (null (cdr z)) (%warn '|needs arguments| z))
  601.   (mapc (function check-rhs-ce-var) (cdr z))) 
  602.  
  603. ;(defun check-remove (z)                     ;original
  604.    ; (and (null (cdr z)) (%warn '|needs arguments| z))
  605.    ;(mapc (function check-rhs-ce-var) (cdr z))) 
  606.  
  607. (defun check-make (z)
  608.   (and (null (cdr z)) (%warn '|needs arguments| z))
  609.   (check-change& (cdr z))) 
  610.  
  611. (defun check-openfile (z)
  612.   (and (null (cdr z)) (%warn '|needs arguments| z))
  613.   (check-change& (cdr z))) 
  614.  
  615. (defun check-closefile (z)
  616.   (and (null (cdr z)) (%warn '|needs arguments| z))
  617.   (check-change& (cdr z))) 
  618.  
  619. (defun check-default (z)
  620.   (and (null (cdr z)) (%warn '|needs arguments| z))
  621.   (check-change& (cdr z))) 
  622.  
  623. (defun check-modify (z)
  624.   (and (null (cdr z)) (%warn '|needs arguments| z))
  625.   (check-rhs-ce-var (cadr z))
  626.   (and (null (cddr z)) (%warn '|no changes to make| z))
  627.   (check-change& (cddr z))) 
  628.  
  629. (defun check-write (z)                ;note this works w/write
  630.   (and (null (cdr z)) (%warn '|needs arguments| z))
  631.   (check-change& (cdr z))) 
  632.  
  633. (defun check-call (z)
  634.   (prog (f)
  635.     (and (null (cdr z)) (%warn '|needs arguments| z))
  636.     (setq f (cadr z))
  637.     (and (variablep f)
  638.      (%warn '|function name must be a constant| z))
  639.     (or (symbolp f)
  640.     (%warn '|function name must be a symbolic atom| f))
  641.     (or (externalp f)
  642.     (%warn '|function name not declared external| f))
  643.     (check-change& (cddr z)))) 
  644.  
  645. (defun check-halt (z)
  646.   (or (null (cdr z)) (%warn '|does not take arguments| z))) 
  647.  
  648. (defun check-cbind (z)
  649.   (prog (v)
  650.     (or (= (length z) 2.) (%warn '|takes only one argument| z))
  651.     (setq v (cadr z))
  652.     (or (variablep v) (%warn '|takes variable as argument| z))
  653.     (note-ce-variable v))) 
  654.  
  655. (defun check-bind (z)
  656.   (prog (v)
  657.     (or (> (length z) 1.) (%warn '|needs arguments| z))
  658.     (setq v (cadr z))
  659.     (or (variablep v) (%warn '|takes variable as argument| z))
  660.     (note-variable v)
  661.     (check-change& (cddr z)))) 
  662.  
  663.  
  664. (defun check-change& (z)
  665.   (prog (r tab-flag)
  666.     (setq tab-flag nil)
  667.     la   (and (atom z) (return nil))
  668.     (setq r (car z))
  669.     (setq z (cdr z))
  670.     (cond ((eq r '^)
  671.        (and tab-flag
  672.         (%warn '|no value before this tab| (car z)))
  673.        (setq tab-flag t)
  674.        (check-tab-index (car z))
  675.        (setq z (cdr z)))
  676.       ((eq r '//) (setq tab-flag nil) (setq z (cdr z)))
  677.       (t (setq tab-flag nil) (check-rhs-value r)))
  678.     (go la))) 
  679.  
  680. (defun check-rhs-ce-var (v)
  681.   (cond ((and (not (numberp v)) (not (ce-bound? v)))
  682.      (%warn '|unbound element variable| v))
  683.     ((and (numberp v) (or (< v 1.) (> v *ce-count*)))
  684.      (%warn '|numeric element designator out of bounds| v)))) 
  685.  
  686. (defun check-rhs-value (x)
  687.   (cond ((consp  x) (check-rhs-function x))    ;dtpr\consp gdw
  688.     (t (check-rhs-atomic x)))) 
  689.  
  690. (defun check-rhs-atomic (x)
  691.   (and (variablep x) 
  692.        (not (bound? x)) 
  693.        (%warn '|unbound variable| x)))
  694.  
  695. (defun check-rhs-function (x)
  696.   (prog (a)
  697.     (setq a (car x))
  698.     (cond ((eq a 'compute) (check-compute x))
  699.       ((eq a 'arith) (check-compute x))
  700.       ((eq a 'substr) (check-substr x))
  701.       ((eq a 'accept) (check-accept x))
  702.       ((eq a 'acceptline) (check-acceptline x))
  703.       ((eq a 'crlf) (check-crlf x))
  704.       ((eq a 'genatom) (check-genatom x))
  705.       ((eq a 'litval) (check-litval x))
  706.       ((eq a 'tabto) (check-tabto x))
  707.       ((eq a 'rjust) (check-rjust x))
  708.       ((not (externalp a))
  709.        (%warn '"rhs function not declared external" a)))))
  710.  
  711. (defun externalp (x)
  712.   ;  (cond ((symbolp x) (get x 'external-routine))     ;) @@@
  713.   ;ok, I'm eliminating this temporarily @@@@
  714.   (cond ((symbolp x) t)
  715.     (t (%warn '|not a legal function name| x) nil)))
  716.  
  717.  
  718. (defun check-litval (x) 
  719.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  720.   (check-rhs-atomic (cadr x)))
  721.  
  722. (defun check-accept (x)
  723.   (cond ((= (length x) 1) nil)
  724.     ((= (length x) 2) (check-rhs-atomic (cadr x)))
  725.     (t (%warn '|too many arguments| x))))
  726.  
  727. (defun check-acceptline (x)
  728.   (mapc (function check-rhs-atomic) (cdr x)))
  729.  
  730. (defun check-crlf (x) 
  731.   (check-0-args x)) 
  732.  
  733. (defun check-genatom (x) (check-0-args x)) 
  734.  
  735. (defun check-tabto (x)
  736.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  737.   (check-print-control (cadr x)))
  738.  
  739. (defun check-rjust (x)
  740.   (or (= (length x) 2) (%warn '|wrong number of arguments| x))
  741.   (check-print-control (cadr x)))
  742.  
  743. (defun check-0-args (x)
  744.   (or (= (length x) 1.) (%warn '|should not have arguments| x))) 
  745.  
  746. (defun check-substr (x)
  747.   (or (= (length x) 4.) (%warn '|wrong number of arguments| x))
  748.   (check-rhs-ce-var (cadr x))
  749.   (check-substr-index (caddr x))
  750.   (check-last-substr-index (cadddr x))) 
  751.  
  752. (defun check-compute (x) (check-arithmetic (cdr x))) 
  753.  
  754. (defun check-arithmetic (l)
  755.   (cond ((atom l)
  756.      (%warn '|syntax error in arithmetic expression| l))
  757.     ((atom (cdr l)) (check-term (car l)))
  758.     ((not (member (cadr l) '(+ - * // \\)))    ;"plus" changed to "+" by gdw
  759.      (%warn '|unknown operator| l))
  760.     (t (check-term (car l)) (check-arithmetic (cddr l))))) 
  761.  
  762. (defun check-term (x)
  763.   (cond ((consp  x) (check-arithmetic x))    ;dtpr\consp gdw
  764.     (t (check-rhs-atomic x)))) 
  765.  
  766. (defun check-last-substr-index (x)
  767.   (or (eq x 'inf) (check-substr-index x))) 
  768.  
  769. (defun check-substr-index (x)
  770.   (prog (v)
  771.     (cond ((bound? x) (return x)))
  772.     (setq v ($litbind x))
  773.     (cond ((not (numberp v))
  774.        (%warn '|unbound symbol used as index in substr| x))
  775.       ((or (< v 1.) (> v 127.))
  776.        (%warn '|index out of bounds in tab| x))))) 
  777.  
  778. (defun check-print-control (x)
  779.   (prog ()
  780.     (cond ((bound? x) (return x)))
  781.     (cond ((or (not (numberp x)) (< x 1.) (> x 127.))
  782.        (%warn '|illegal value for printer control| x))))) 
  783.  
  784. (defun check-tab-index (x)
  785.   (prog (v)
  786.     (cond ((bound? x) (return x)))
  787.     (setq v ($litbind x))
  788.     (cond ((not (numberp v))
  789.        (%warn '|unbound symbol occurs after ^| x))
  790.       ((or (< v 1.) (> v 127.))
  791.        (%warn '|index out of bounds after ^| x))))) 
  792.  
  793. (defun note-variable (var)
  794.   (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
  795.  
  796. (defun bound? (var)
  797.   (or (member var *rhs-bound-vars*)
  798.       (var-dope var)))
  799.  
  800. (defun note-ce-variable (ce-var)
  801.   (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
  802.  
  803. (defun ce-bound? (ce-var)
  804.   (or (member ce-var *rhs-bound-ce-vars*)
  805.       (ce-var-dope ce-var)))
  806.