home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume12 / ops5 / part04 < prev    next >
Encoding:
Internet Message Format  |  1987-10-12  |  50.8 KB
  1. Subject:  v12i019:  OPS5 in Common Lisp, Part04/05
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rs@uunet.UU.NET
  5.  
  6. Submitted-by: eric@dlcdev.UUCP (eric van tassell)
  7. Posting-number: Volume 12, Issue 19
  8. Archive-name: ops5/part04
  9.  
  10. ;;; WM maintaining functions
  11. ;
  12. ; The order of operations in the following two functions is critical.
  13. ; add-to-wm order: (1) change wm (2) record change (3) match 
  14. ; remove-from-wm order: (1) record change (2) match (3) change wm
  15. ; (back will not restore state properly unless wm changes are recorded
  16. ; before the cs changes that they cause)  (match will give errors if 
  17. ; the thing matched is not in wm at the time)
  18.  
  19.  
  20. (defun add-to-wm (wme override)
  21.   (prog (fa z part timetag port)
  22.     (setq *critical* t)
  23.     (setq *current-wm* (1+ *current-wm*))
  24.     (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
  25.     (setq *action-count* (1+ *action-count*))
  26.     (setq fa (wm-hash wme))
  27.     (or (member fa *wmpart-list* :test #'eq)
  28.         (setq *wmpart-list* (cons fa *wmpart-list*)))
  29.     (setq part (get fa 'wmpart*))
  30.     (cond (override (setq timetag override))
  31.           (t (setq timetag *action-count*)))
  32.     (setq z (cons wme timetag))
  33.     (putprop fa (cons z part) 'wmpart*)
  34.     (record-change '=>wm *action-count* wme)
  35.     (match 'new wme)
  36.     (setq *critical* nil)
  37.     (cond ((and *in-rhs* *wtrace*)
  38.            (setq port (trace-file))
  39.            (terpri port)
  40.            (princ '|=>wm: | port)
  41.            (ppelm wme port)))
  42.     (and *in-rhs* *mtrace* (setq *madeby* 
  43.                                  (cons (cons wme *p-name*) *madeby*))))) 
  44.  
  45. ; remove-from-wm uses eq, not equal to determine if wme is present
  46.  
  47. (defun remove-from-wm (wme)
  48.   (prog (fa z part timetag port)
  49.     (setq fa (wm-hash wme))
  50.     (setq part (get fa 'wmpart*))
  51.     (setq z (assoc wme part :test #'eq))
  52.     (or z (return nil))
  53.     (setq timetag (cdr z))
  54.     (cond ((and *wtrace* *in-rhs*)
  55.            (setq port (trace-file))
  56.            (terpri port)
  57.            (princ '|<=wm: | port)
  58.            (ppelm wme port)))
  59.     (setq *action-count* (1+ *action-count*))
  60.     (setq *critical* t)
  61.     (setq *current-wm* (1- *current-wm*))
  62.     (record-change '<=wm timetag wme)
  63.     (match nil wme)
  64.     (putprop fa (delete z part :test #'eq) 'wmpart* )
  65.     (setq *critical* nil))) 
  66.  
  67. ; mapwm maps down the elements of wm, applying fn to each element
  68. ; each element is of form (datum . creation-time)
  69.  
  70. (defun mapwm (fn)
  71.   (prog (wmpl part)
  72.         (setq wmpl *wmpart-list*)
  73.    lab1 (cond ((atom wmpl) (return nil)))
  74.         (setq part (get (car wmpl) 'wmpart*))
  75.         (setq wmpl (cdr wmpl))
  76.         (mapc fn part)
  77.         (go lab1))) 
  78.  
  79. (defmacro wm (&rest a) 
  80.   `(progn
  81.    (mapc (function (lambda (z) (terpri) (ppelm z t))) 
  82.     (get-wm ',a))
  83.   nil) )
  84.  
  85. (defun get-wm (z)
  86.   (setq *wm-filter* z)
  87.   (setq *wm* nil)
  88.   (mapwm (function get-wm2))
  89.   (prog2 nil *wm* (setq *wm* nil))) 
  90.  
  91. (defun get-wm2 (elem) 
  92.  (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
  93.     (setq *wm* (cons (car elem) *wm*)))))
  94.  
  95. (defun wm-hash (x)
  96.   (cond ((not x) '<default>)
  97.         ((not (car x)) (wm-hash (cdr x)))
  98.         ((symbolp (car x)) (car x))
  99.         (t (wm-hash (cdr x))))) 
  100.  
  101. (defun creation-time (wme)
  102.   (cdr (assoc wme (get (wm-hash wme) 'wmpart*) :test #'eq))) 
  103.  
  104. (defun rehearse nil
  105.   (prog nil
  106.     (setq *old-wm* nil)
  107.     (mapwm (function refresh-collect))
  108.     (mapc (function refresh-del) *old-wm*)
  109.     (mapc (function refresh-add) *old-wm*)
  110.     (setq *old-wm* nil))) 
  111.  
  112. (defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) 
  113.  
  114. (defun refresh-del (x) (remove-from-wm (car x))) 
  115.  
  116. (defun refresh-add (x) (add-to-wm (car x) (cdr x))) 
  117.  
  118. (defun trace-file ()
  119.   (prog (port)
  120.         (setq port t)
  121.     (cond (*trace-file*
  122.            (setq port ($ofile *trace-file*))
  123.            (cond ((null port)
  124.                   (%warn '|trace: file has been closed| *trace-file*)
  125.               (setq port t)))))
  126.         (return port)))
  127.  
  128.  
  129. ;;; Basic functions for RHS evaluation
  130.  
  131. (defun eval-rhs (pname data)
  132.   (prog (node port)
  133.     (cond (*ptrace*
  134.            (setq port (trace-file))
  135.            (terpri port)
  136.            (princ *cycle-count* port)
  137.            (princ '|. | port)
  138.            (princ pname port)
  139.            (time-tag-print data port)))
  140.     (setq *data-matched* data)
  141.     (setq *p-name* pname)
  142.     (setq *last* nil)
  143.     (setq node (get pname 'topnode))
  144.     (init-var-mem (var-part node))
  145.     (init-ce-var-mem (ce-var-part node))
  146.     (begin-record pname data)
  147.     (setq *in-rhs* t)
  148.     (eval (rhs-part node))
  149.     (setq *in-rhs* nil)
  150.     (end-record))) 
  151.  
  152. (defun time-tag-print (data port)
  153.   (cond ((not (null data))
  154.          (time-tag-print (cdr data) port)
  155.          (princ '| | port)
  156.          (princ (creation-time (car data)) port))))
  157.  
  158. (defun init-var-mem (vlist)
  159.   (prog (v ind r)
  160.         (setq *variable-memory* nil)
  161.    top  (and (atom vlist) (return nil))
  162.         (setq v (car vlist))
  163.         (setq ind (cadr vlist))
  164.         (setq vlist (cddr vlist))
  165.         (setq r (gelm *data-matched* ind))
  166.         (setq *variable-memory* (cons (cons v r) *variable-memory*))
  167.         (go top))) 
  168.  
  169. (defun init-ce-var-mem (vlist)
  170.   (prog (v ind r)
  171.         (setq *ce-variable-memory* nil)
  172.    top  (and (atom vlist) (return nil))
  173.         (setq v (car vlist))
  174.         (setq ind (cadr vlist))
  175.         (setq vlist (cddr vlist))
  176.         (setq r (ce-gelm *data-matched* ind))
  177.         (setq *ce-variable-memory*
  178.               (cons (cons v r) *ce-variable-memory*))
  179.         (go top))) 
  180.  
  181. (defun make-ce-var-bind (var elem)
  182.   (setq *ce-variable-memory*
  183.         (cons (cons var elem) *ce-variable-memory*))) 
  184.  
  185. (defun make-var-bind (var elem)
  186.   (setq *variable-memory* (cons (cons var elem) *variable-memory*))) 
  187.  
  188. (defun $varbind (x)
  189.   (prog (r)
  190.     (and (not *in-rhs*) (return x))
  191.         (setq r (assoc x *variable-memory* :test #'eq))
  192.         (cond (r (return (cdr r)))
  193.               (t (return x))))) 
  194.  
  195. (defun get-ce-var-bind (x)
  196.   (prog (r)
  197.         (cond ((numberp x) (return (get-num-ce x))))
  198.         (setq r (assoc x *ce-variable-memory* :test #'eq))
  199.         (cond (r (return (cdr r)))
  200.               (t (return nil))))) 
  201.  
  202. (defun get-num-ce (x)
  203.   (prog (r l d)
  204.         (setq r *data-matched*)
  205.         (setq l (length r))
  206.         (setq d (- l x))
  207.         (and (> 0. d) (return nil))
  208.    la   (cond ((null r) (return nil))
  209.               ((> 1. d) (return (car r))))
  210.         (setq d (1- d))
  211.         (setq r (cdr r))
  212.         (go la))) 
  213.  
  214.  
  215. (defun build-collect (z)
  216.   (prog (r)
  217.    la   (and (atom z) (return nil))
  218.         (setq r (car z))
  219.         (setq z (cdr z))
  220.         (cond ((and r (listp r))
  221.                ($value '\()
  222.                (build-collect r)
  223.                ($value '\)))
  224.               ((eq r '\\) ($change (car z)) (setq z (cdr z)))
  225.               (t ($value r)))
  226.         (go la))) 
  227.  
  228. (defun unflat (x) (setq *rest* x) (unflat*)) 
  229.  
  230. (defun unflat* nil
  231.   (prog (c)
  232.         (cond ((atom *rest*) (return nil)))
  233.         (setq c (car *rest*))
  234.         (setq *rest* (cdr *rest*))
  235.         (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
  236.               ((eq c '\)) (return nil))
  237.               (t (return (cons c (unflat*))))))) 
  238.  
  239.  
  240. (defun $change (x)
  241.   (prog nil
  242.         (cond ((and x (listp x)) (eval-function x)) ;modified to check for nil
  243.               (t ($value ($varbind x)))))) 
  244.  
  245. (defun eval-args (z)
  246.   (prog (r)
  247.         (rhs-tab 1.)
  248.    la   (and (atom z) (return nil))
  249.         (setq r (car z))
  250.         (setq z (cdr z))
  251.         (cond ((eq r #\^)
  252.                (rhs-tab (car z))
  253.                (setq r (cadr z))
  254.                (setq z (cddr z))))
  255.         (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
  256.               (t ($change r)))
  257.         (go la))) 
  258.  
  259.  
  260. (defun eval-function (form)
  261.   (cond ((not *in-rhs*)
  262.      (%warn '|functions cannot be used at top level| (car form)))
  263.     (t (eval form))))
  264.  
  265.  
  266. ;;; Functions to manipulate the result array
  267.  
  268.  
  269. (defun $reset nil
  270.   (setq *max-index* 0)
  271.   (setq *next-index* 1)) 
  272.  
  273. ; rhs-tab implements the tab ('^') function in the rhs.  it has
  274. ; four responsibilities:
  275. ;    - to move the array pointers
  276. ;    - to watch for tabbing off the left end of the array
  277. ;      (ie, to watch for pointers less than 1)
  278. ;    - to watch for tabbing off the right end of the array
  279. ;    - to write nil in all the slots that are skipped
  280. ; the last is necessary if the result array is not to be cleared
  281. ; after each use; if rhs-tab did not do this, $reset
  282. ; would be much slower.
  283.  
  284. (defun rhs-tab (z) ($tab ($varbind z)))
  285.  
  286. (defun $tab (z)
  287.   (prog (edge next)
  288.         (setq next ($litbind z))
  289.         (and (floatp next) (setq next (round next)))
  290.         (cond ((or (not (numberp next)) 
  291.            (> next *size-result-array*)
  292.            (> 1. next))
  293.                (%warn '|illegal index after ^| next)
  294.                (return *next-index*)))
  295.         (setq edge (- next 1.))
  296.         (cond ((> *max-index* edge) (go ok)))
  297.    clear (cond ((== *max-index* edge) (go ok)))
  298.         (putvector *result-array* edge nil)
  299.         (setq edge (1- edge))
  300.         (go clear)
  301.    ok   (setq *next-index* next)
  302.         (return next))) 
  303.  
  304. (defun $value (v)
  305.   (cond ((> *next-index* *size-result-array*)
  306.          (%warn '|index too large| *next-index*))
  307.         (t
  308.          (and (> *next-index* *max-index*)
  309.               (setq *max-index* *next-index*))
  310.          (putvector *result-array* *next-index* v)
  311.          (setq *next-index* (1+ *next-index*))))) 
  312.  
  313. (defun use-result-array nil
  314.   (prog (k r)
  315.         (setq k *max-index*)
  316.         (setq r nil)
  317.    top  (and (== k 0.) (return r))
  318.         (setq r (cons (getvector *result-array* k) r))
  319.         (setq k (1- k))
  320.         (go top))) 
  321.  
  322. (defun $assert nil
  323.   (setq *last* (use-result-array))
  324.   (add-to-wm *last* nil))
  325.  
  326. (defun $parametercount nil *max-index*)
  327.  
  328. (defun $parameter (k)
  329.   (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
  330.      (%warn '|illegal parameter number | k)
  331.          nil)
  332.         ((> k *max-index*) nil)
  333.     (t (getvector *result-array* k))))
  334.  
  335.  
  336. ;;; RHS actions
  337.  
  338.  
  339. (defmacro make(&rest z)
  340.   `(prog nil
  341.         ($reset)
  342.         (eval-args ',z)
  343.         ($assert))) 
  344.  
  345. (defmacro modify (&rest z)
  346.   `(prog (old args)
  347.         (setq args ',z)
  348.     (cond ((not *in-rhs*)
  349.            (%warn '|cannot be called at top level| 'modify)
  350.            (return nil)))
  351.         (setq old (get-ce-var-bind (car args)))
  352.         (cond ((null old)
  353.                (%warn '|modify: first argument must be an element variable|
  354.                         (car args))
  355.                (return nil)))
  356.         (remove-from-wm old)
  357.         (setq args (cdr args))
  358.         ($reset)
  359.    copy (and (atom old) (go fin))
  360.         ($change (car old))
  361.         (setq old (cdr old))
  362.         (go copy)
  363.    fin  (eval-args args)
  364.         ($assert))) 
  365.  
  366. (defmacro bind (&rest z)
  367.   `(prog (val)
  368.     (cond ((not *in-rhs*)
  369.            (%warn '|cannot be called at top level| 'bind)
  370.            (return nil)))
  371.     (cond ((< (length z) 1.)
  372.            (%warn '|bind: wrong number of arguments to| ',z)
  373.            (return nil))
  374.           ((not (symbolp (car ',z)))
  375.            (%warn '|bind: illegal argument| (car ',z))
  376.            (return nil))
  377.           ((= (length ',z) 1.) (setq val (gensym)))
  378.           (t ($reset)
  379.              (eval-args (cdr ',z))
  380.              (setq val ($parameter 1.))))
  381.     (make-var-bind (car ',z) val))) 
  382.  
  383. (defmacro cbind (&rest z)
  384.   `(cond ((not *in-rhs*)
  385.      (%warn '|cannot be called at top level| 'cbind))
  386.     ((not (= (length ',z) 1.))
  387.      (%warn '|cbind: wrong number of arguments| ',z))
  388.     ((not (symbolp (car ',z)))
  389.      (%warn '|cbind: illegal argument| (car ',z)))
  390.     ((null *last*)
  391.      (%warn '|cbind: nothing added yet| (car ',z)))
  392.     (t (make-ce-var-bind (car ',z) *last*)))) 
  393.  
  394. (defmacro oremove (&rest z)
  395.   `(prog (old args)
  396.         (setq args ',z)
  397.     (and (not *in-rhs*)(return (top-level-remove args)))
  398.    top  (and (atom args) (return nil))
  399.         (setq old (get-ce-var-bind (car args)))
  400.         (cond ((null old)
  401.                (%warn '|remove: argument not an element variable| (car args))
  402.                (return nil)))
  403.         (remove-from-wm old)
  404.         (setq args (cdr args))
  405.         (go top))) 
  406.  
  407. (defmacro ocall (&rest z)
  408.   `(prog (f)
  409.     (setq f (car ',z))
  410.         ($reset)
  411.         (eval-args (cdr ',z))
  412.         (funcall f))) 
  413.  
  414. (defmacro owrite (&rest z)
  415.  `(prog (port max k x needspace)
  416.     (cond ((not *in-rhs*)
  417.            (%warn '|cannot be called at top level| 'write)
  418.            (return nil)))
  419.     ($reset)
  420.     (eval-args ',z)
  421.     (setq k 1.)
  422.     (setq max ($parametercount))
  423.     (cond ((< max 1.)
  424.            (%warn '|write: nothing to print| ',z)
  425.            (return nil)))
  426.     (setq port (default-write-file))
  427.     (setq x ($parameter 1.))
  428.     (cond ((and (symbolp x) ($ofile x)) 
  429.            (setq port ($ofile x))
  430.            (setq k 2.)))
  431.         (setq needspace t)
  432.    la   (and (> k max) (return nil))
  433.     (setq x ($parameter k))
  434.     (cond ((eq x '|=== C R L F ===|)
  435.            (setq needspace nil)
  436.                (terpri port))
  437.               ((eq x '|=== R J U S T ===|)
  438.            (setq k (+ 2 k))
  439.            (do-rjust ($parameter (1- k)) ($parameter k) port))
  440.           ((eq x '|=== T A B T O ===|)
  441.            (setq needspace nil)
  442.            (setq k (1+ k))
  443.            (do-tabto ($parameter k) port))
  444.           (t 
  445.            (and needspace (princ '| | port))
  446.            (setq needspace t)
  447.            (princ x port)))
  448.     (setq k (1+ k))
  449.     (go la))) 
  450.     
  451. (defun default-write-file ()
  452.   (prog (port)
  453.     (setq port t)
  454.     (cond (*write-file*
  455.            (setq port ($ofile *write-file*))
  456.            (cond ((null port) 
  457.               (%warn '|write: file has been closed| *write-file*)
  458.               (setq port t)))))
  459.         (return port)))
  460.  
  461.                                                                                                                                                                                                          
  462. (defun do-rjust (width value port)
  463.   (prog (size)
  464.     (cond ((eq value '|=== T A B T O ===|)
  465.            (%warn '|rjust cannot precede this function| 'tabto)
  466.                (return nil))
  467.           ((eq value '|=== C R L F ===|)
  468.            (%warn '|rjust cannot precede this function| 'crlf)
  469.                (return nil))
  470.           ((eq value '|=== R J U S T ===|)
  471.            (%warn '|rjust cannot precede this function| 'rjust)
  472.                (return nil)))
  473.         (setq size (length (princ-to-string value )))
  474.     (cond ((> size width)
  475.            (princ '| | port)
  476.            (princ value port)
  477.            (return nil)))
  478.         (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
  479.     (princ value port)))
  480.  
  481. (defun do-tabto (col port)
  482.   (eval `(format ,port (concatenate 'string "~" (princ-to-string ,col) "T"))))
  483.  
  484. ;  (prog (pos)
  485. ;    (setq pos (1+ (nwritn port)))
  486. ;    (cond ((> pos col)
  487. ;           (terpri port)
  488. ;           (setq pos 1)))
  489. ;    (do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
  490. ;    (return nil)))
  491.  
  492.  
  493. (defun halt nil 
  494.   (cond ((not *in-rhs*)
  495.      (%warn '|cannot be called at top level| 'halt))
  496.     (t (setq *halt-flag* t)))) 
  497.  
  498. (defmacro build (&rest z)
  499.   `(prog (r)
  500.     (cond ((not *in-rhs*)
  501.            (%warn '|cannot be called at top level| 'build)
  502.            (return nil)))
  503.         ($reset)
  504.         (build-collect ',z)
  505.         (setq r (unflat (use-result-array)))
  506.         (and *build-trace* (funcall *build-trace* r))
  507.         (compile-production (car r) (cdr r)))) 
  508.  
  509. (defun infile(file)
  510.    (open file :direction :input))
  511.  
  512. (defun outfile(file)
  513.    (open file :direction :output))
  514.  
  515. (defmacro openfile (&rest z)
  516.   `(prog (file mode id)
  517.     ($reset)
  518.     (eval-args ',z)
  519.     (cond ((not (equal ($parametercount) 3.))
  520.            (%warn '|openfile: wrong number of arguments| ',z)
  521.            (return nil)))
  522.     (setq id ($parameter 1))
  523.     (setq file ($parameter 2))
  524.     (setq mode ($parameter 3))
  525.     (cond ((not (symbolp id))
  526.            (%warn '|openfile: file id must be a symbolic atom| id)
  527.            (return nil))
  528.               ((null id)
  529.                (%warn '|openfile: 'nil' is reserved for the terminal| nil)
  530.                (return nil))
  531.           ((or ($ifile id)($ofile id))
  532.            (%warn '|openfile: name already in use| id)
  533.            (return nil)))
  534.     (cond ((eq mode 'in) (putprop id  (infile file) 'inputfile))
  535.           ((eq mode 'out) (putprop id  (outfile file) 'outputfile))
  536.           (t (%warn '|openfile: illegal mode| mode)
  537.          (return nil)))
  538.     (return nil)))
  539.  
  540. (defun $ifile (x) 
  541.   (cond ((and x (symbolp x)) (get x 'inputfile))
  542.         (t *standard-input*)))
  543.  
  544. (defun $ofile (x) 
  545.   (cond ((and x (symbolp x)) (get x 'outputfile))
  546.         (t *standard-output*)))
  547.  
  548.  
  549. (defmacro closefile (&rest z)
  550.   `(progn 
  551.     ($reset)
  552.     (eval-args ',z)
  553.     (mapc (function closefile2) (use-result-array))))
  554.  
  555. (defun closefile2 (file)
  556.   (prog (port)
  557.     (cond ((not (symbolp file))
  558.            (%warn '|closefile: illegal file identifier| file))
  559.           ((setq port ($ifile file))
  560.            (close port)
  561.            (remprop file 'inputfile))
  562.           ((setq port ($ofile file))
  563.            (close port)
  564.            (remprop file 'outputfile)))
  565.     (return nil)))
  566.  
  567. (defmacro default (&rest z)
  568.   `(prog (file use)
  569.     ($reset)
  570.     (eval-args ',z)
  571.     (cond ((not (equal ($parametercount) 2.))
  572.            (%warn '|default: wrong number of arguments| ',z)
  573.            (return nil)))
  574.     (setq file ($parameter 1))
  575.     (setq use ($parameter 2))
  576.     (cond ((not (symbolp file))
  577.            (%warn '|default: illegal file identifier| file)
  578.            (return nil))
  579.           ((not (member use '(write accept trace)))
  580.            (%warn '|default: illegal use for a file| use)
  581.            (return nil))
  582.           ((and (member use '(write trace)) 
  583.             (not (null file))
  584.             (not ($ofile file)))
  585.            (%warn '|default: file has not been opened for output| file)
  586.            (return nil))
  587.           ((and (eq use 'accept) 
  588.             (not (null file))
  589.             (not ($ifile file)))
  590.            (%warn '|default: file has not been opened for input| file)
  591.            (return nil))
  592.           ((eq use 'write) (setq *write-file* file))
  593.           ((eq use 'accept) (setq *accept-file* file))
  594.           ((eq use 'trace) (setq *trace-file* file)))
  595.     (return nil)))
  596.  
  597.  
  598.  
  599. ;;; RHS Functions
  600.  
  601. (defmacro accept (&rest z)
  602.   `(prog (port arg)
  603.     (cond ((> (length ',z) 1.)
  604.            (%warn '|accept: wrong number of arguments| ',z)
  605.            (return nil)))
  606.     (setq port t)
  607.     (cond (*accept-file*
  608.            (setq port ($ifile *accept-file*))
  609.            (cond ((null port) 
  610.               (%warn '|accept: file has been closed| *accept-file*)
  611.               (return nil)))))
  612.     (cond ((= (length ',z) 1)
  613.            (setq arg ($varbind (car ',z)))
  614.            (cond ((not (symbolp arg))
  615.                   (%warn '|accept: illegal file name| arg)
  616.               (return nil)))
  617.            (setq port ($ifile arg))
  618.            (cond ((null port) 
  619.               (%warn '|accept: file not open for input| arg)
  620.               (return nil)))))
  621.         (cond ((= (tyipeek port) -1.)
  622.            ($value 'end-of-file)
  623.            (return nil)))
  624.     (flat-value (read port)))) 
  625.  
  626. (defun flat-value (x)
  627.   (cond ((atom x) ($value x))
  628.         (t (mapc (function flat-value) x)))) 
  629.  
  630. (defun span-chars (x prt)
  631.   (do ((ch (tyipeek prt) (tyipeek prt))) ((not (member ch x #'char-equal))) (read-char prt)))
  632.  
  633. (defmacro acceptline (&rest z)
  634.   `(prog ( def arg port)
  635.     (setq port t)
  636.     (setq def ',z)
  637.     (cond (*accept-file*
  638.            (setq port ($ifile *accept-file*))
  639.            (cond ((null port) 
  640.               (%warn '|acceptline: file has been closed| 
  641.                      *accept-file*)
  642.               (return nil)))))
  643.     (cond ((> (length def) 0)
  644.            (setq arg ($varbind (car def)))
  645.            (cond ((and (symbolp arg) ($ifile arg))
  646.                   (setq port ($ifile arg))
  647.               (setq def (cdr def))))))
  648.         (span-chars '(9. 41.) port)
  649.     (cond ((member (tyipeek port) '(-1. 10.))
  650.            (mapc (function $change) def)
  651.            (return nil)))
  652.    lp1    (flat-value (read port))
  653.         (span-chars '(9. 41.) port)
  654.     (cond ((not (member (tyipeek port) '(-1. 10.))) (go lp1)))))
  655.  
  656. (defmacro substr (&rest l)
  657.   `(prog (k elm start end)
  658.         (cond ((not (= (length ',l) 3.))
  659.                (%warn '|substr: wrong number of arguments| ',l)
  660.                (return nil)))
  661.         (setq elm (get-ce-var-bind (car ',l)))
  662.         (cond ((null elm)
  663.                (%warn '|first argument to substr must be a ce var|
  664.                         ',l)
  665.                (return nil)))
  666.         (setq start ($varbind (cadr ',l)))
  667.     (setq start ($litbind start))
  668.         (cond ((not (numberp start))
  669.                (%warn '|second argument to substr must be a number|
  670.                         ',l)
  671.                (return nil)))
  672.     ;if a variable is bound to INF, the following
  673.     ;will get the binding and treat it as INF is
  674.     ;always treated.  that may not be good
  675.         (setq end ($varbind (caddr ',l)))
  676.         (cond ((eq end 'inf) (setq end (length elm))))
  677.     (setq end ($litbind end))
  678.         (cond ((not (numberp end))
  679.                (%warn '|third argument to substr must be a number|
  680.                         ',l)
  681.                (return nil)))
  682.         ;this loop does not check for the end of elm
  683.         ;instead it relies on cdr of nil being nil
  684.         ;this may not work in all versions of lisp
  685.         (setq k 1.)
  686.    la   (cond ((> k end) (return nil))
  687.               ((not (< k start)) ($value (car elm))))
  688.         (setq elm (cdr elm))
  689.         (setq k (1+ k))
  690.         (go la))) 
  691.  
  692.  
  693. (defmacro compute (&rest z) `($value (ari ',z))) 
  694.  
  695. ; arith is the obsolete form of compute
  696. (defmacro arith (&rest z) `($value (ari ',z))) 
  697.  
  698. (defun ari (x)
  699.   (cond ((atom x)
  700.          (%warn '|bad syntax in arithmetic expression | x)
  701.      0.)
  702.         ((atom (cdr x)) (ari-unit (car x)))
  703.         ((eq (cadr x) '+)
  704.          (+ (ari-unit (car x)) (ari (cddr x))))
  705.         ((eq (cadr x) '-)
  706.          (difference (ari-unit (car x)) (ari (cddr x))))
  707.         ((eq (cadr x) '*)
  708.          (times (ari-unit (car x)) (ari (cddr x))))
  709.         ((eq (cadr x) '//)
  710.          (/ (ari-unit (car x)) (ari (cddr x))))
  711.         ((eq (cadr x) '\\)
  712.          (mod (round (ari-unit (car x))) (round (ari (cddr x)))))
  713.         (t (%warn '|bad syntax in arithmetic expression | x) 0.))) 
  714.  
  715. (defun ari-unit (a)
  716.   (prog (r)
  717.         (cond ((listp a) (setq r (ari a)))
  718.               (t (setq r ($varbind a))))
  719.         (cond ((not (numberp r))
  720.                (%warn '|bad value in arithmetic expression| a)
  721.                (return 0.))
  722.               (t (return r))))) 
  723.  
  724. (defun genatom nil ($value (gensym))) 
  725.  
  726. (defmacro litval (&rest z)
  727.   `(prog (r)
  728.     (cond ((not (= (length ',z) 1.))
  729.            (%warn '|litval: wrong number of arguments| ',z)
  730.            ($value 0) 
  731.            (return nil))
  732.           ((numberp (car ',z)) ($value (car ',z)) (return nil)))
  733.     (setq r ($litbind ($varbind (car ',z))))
  734.     (cond ((numberp r) ($value r) (return nil)))
  735.     (%warn '|litval: argument has no literal binding| (car ',z))
  736.     ($value 0)))
  737.  
  738.  
  739. (defmacro rjust (&rest z)
  740.   `(prog (val)
  741.         (cond ((not (= (length ',z) 1.))
  742.            (%warn '|rjust: wrong number of arguments| ',z)
  743.                (return nil)))
  744.         (setq val ($varbind (car ',z)))
  745.     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
  746.            (%warn '|rjust: illegal value for field width| val)
  747.            (return nil)))
  748.         ($value '|=== R J U S T ===|)
  749.     ($value val)))
  750.  
  751.  
  752. (defmacro crlf()
  753.      ($value '|=== C R L F ===|))
  754.  
  755. (defmacro tabto (&rest z)
  756.   `(prog (val)
  757.         (cond ((not (= (length ',z) 1.))
  758.            (%warn '|tabto: wrong number of arguments| ',z)
  759.            (return nil)))
  760.         (setq val ($varbind (car ',z)))
  761.     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
  762.            (%warn '|tabto: illegal column number| ',z)
  763.            (return nil)))
  764.         ($value '|=== T A B T O ===|)
  765.     ($value val)))
  766.  
  767.  
  768.  
  769. ;;; Printing WM
  770.  
  771. (defmacro ppwm (&rest z)
  772.   `(prog (next a avlist)
  773.         (setq avlist ',z)
  774.         (setq *filters* nil)
  775.         (setq next 1.)
  776.    l   (and (atom avlist) (go print))
  777.         (setq a (car avlist))
  778.         (setq avlist (cdr avlist))
  779.         (cond ((eq a #\^)
  780.                (setq next (car avlist))
  781.                (setq avlist (cdr avlist))
  782.                (setq next ($litbind next))
  783.                (and (floatp next) (setq next (round next)))
  784.                (cond ((or (not (numberp next))
  785.                           (> next *size-result-array*)
  786.                           (> 1. next))
  787.                       (%warn '|illegal index after ^| next)
  788.                       (return nil))))
  789.               ((variablep a)
  790.                (%warn '|ppwm does not take variables| a)
  791.                (return nil))
  792.               (t (setq *filters* (cons next (cons a *filters*)))
  793.                  (setq next (1+ next))))
  794.         (go l)
  795.    print (mapwm (function ppwm2))
  796.         (terpri)
  797.         (return nil))) 
  798.  
  799. (defun ppwm2 (elm-tag)
  800.   (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) t)))) 
  801.  
  802. (defun filter (elm)
  803.   (prog (fl indx val)
  804.         (setq fl *filters*)
  805.    top  (and (atom fl) (return t))
  806.         (setq indx (car fl))
  807.         (setq val (cadr fl))
  808.         (setq fl (cddr fl))
  809.         (and (ident (nth (1- indx) elm) val) (go top))
  810.         (return nil))) 
  811.  
  812. (defun ident (x y)
  813.   (cond ((eq x y) t)
  814.         ((not (numberp x)) nil)
  815.         ((not (numberp y)) nil)
  816.         ((=alg x y) t)
  817.         (t nil))) 
  818.  
  819. ; the new ppelm is designed especially to handle literalize format
  820. ; however, it will do as well as the old ppelm on other formats
  821.  
  822. (defun ppelm (elm port)
  823.   (prog (ppdat sep val att mode lastpos)
  824.     (princ (creation-time elm) port)
  825.     (princ '|:  | port)
  826.         (setq mode 'vector)
  827.     (setq ppdat (get (car elm) 'ppdat))
  828.     (and ppdat (setq mode 'a-v))
  829.     (setq sep '|(|)
  830.         (setq lastpos 0)
  831.     (do
  832.      ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
  833.      ((atom vlist) nil)
  834.      (setq val (car vlist))
  835.      (setq att (assoc curpos ppdat))
  836.      (cond (att (setq att (cdr att)))
  837.            (t (setq att curpos)))
  838.          (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
  839.      (cond ((or (not (null val)) (eq mode 'vector))
  840.         (princ sep port)
  841.         (ppval val att lastpos port)
  842.         (setq sep '|    |)
  843.         (setq lastpos curpos))))
  844.     (princ '|)| port)))
  845.  
  846. (defun ppval (val att lastpos port)
  847.   (cond ((not (equal att (1+ lastpos)))
  848.          (princ '^ port)
  849.          (princ att port)
  850.          (princ '| | port)))
  851.   (princ val port))
  852.  
  853.  
  854.  
  855.  
  856.  
  857. 1,filed,,
  858. >From RELAY.CS.NET!cdaf%indiana.csnet  Tue Mar 17 23:37:15 1987 remote from mit-eddie
  859. Received: by EDDIE.MIT.EDU (5.31/4.7) id AA21258; Tue, 17 Mar 87 23:36:18 EST
  860. Message-Id: <8703180436.AA21258@EDDIE.MIT.EDU>
  861. Received: from relay2.cs.net by RELAY.CS.NET id aa16041; 17 Mar 87 23:35 EST
  862. Received: from indiana by RELAY.CS.NET id aa06643; 17 Mar 87 23:30 EST
  863. Date: Tue, 17 Mar 87 19:20:14 est
  864. From: "Charles A. Daffinger" <cdaf%indiana.csnet@RELAY.CS.NET>
  865. To: dlcdev!eric@EDDIE.MIT.EDU
  866. Subject: common lisp ops5 part 3
  867.  
  868. *** EOOH ***
  869. >From RELAY.CS.NET!cdaf%indiana.csnet  Tue Mar 17 23:37:15 1987 remote from mit-eddie
  870. Date: Tue, 17 Mar 87 19:20:14 est
  871. From: "Charles A. Daffinger" <cdaf%indiana.csnet@RELAY.CS.NET>
  872. To: dlcdev!eric@EDDIE.MIT.EDU
  873. Subject: common lisp ops5 part 3
  874.  
  875. ; File OPS5.common.3.lsp: part 3 of OPS5 in Common Lisp
  876. ; ----------
  877.  
  878.  
  879. ;;; WM maintaining functions
  880. ;
  881. ; The order of operations in the following two functions is critical.
  882. ; add-to-wm order: (1) change wm (2) record change (3) match 
  883. ; remove-from-wm order: (1) record change (2) match (3) change wm
  884. ; (back will not restore state properly unless wm changes are recorded
  885. ; before the cs changes that they cause)  (match will give errors if 
  886. ; the thing matched is not in wm at the time)
  887.  
  888.  
  889. (defun add-to-wm (wme override)
  890.   (prog (fa z part timetag port)
  891.     (setq *critical* t)
  892.     (setq *current-wm* (1+ *current-wm*))
  893.     (and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
  894.     (setq *action-count* (1+ *action-count*))
  895.     (setq fa (wm-hash wme))
  896.     (or (member fa *wmpart-list* :test #'eq)
  897.         (setq *wmpart-list* (cons fa *wmpart-list*)))
  898.     (setq part (get fa 'wmpart*))
  899.     (cond (override (setq timetag override))
  900.           (t (setq timetag *action-count*)))
  901.     (setq z (cons wme timetag))
  902.     (putprop fa (cons z part) 'wmpart*)
  903.     (record-change '=>wm *action-count* wme)
  904.     (match 'new wme)
  905.     (setq *critical* nil)
  906.     (cond ((and *in-rhs* *wtrace*)
  907.            (setq port (trace-file))
  908.            (terpri port)
  909.            (princ '|=>wm: | port)
  910.            (ppelm wme port)))
  911.     (and *in-rhs* *mtrace* (setq *madeby* 
  912.                                  (cons (cons wme *p-name*) *madeby*))))) 
  913.  
  914. ; remove-from-wm uses eq, not equal to determine if wme is present
  915.  
  916. (defun remove-from-wm (wme)
  917.   (prog (fa z part timetag port)
  918.     (setq fa (wm-hash wme))
  919.     (setq part (get fa 'wmpart*))
  920.     (setq z (assoc wme part :test #'eq))
  921.     (or z (return nil))
  922.     (setq timetag (cdr z))
  923.     (cond ((and *wtrace* *in-rhs*)
  924.            (setq port (trace-file))
  925.            (terpri port)
  926.            (princ '|<=wm: | port)
  927.            (ppelm wme port)))
  928.     (setq *action-count* (1+ *action-count*))
  929.     (setq *critical* t)
  930.     (setq *current-wm* (1- *current-wm*))
  931.     (record-change '<=wm timetag wme)
  932.     (match nil wme)
  933.     (putprop fa (delete z part :test #'eq) 'wmpart* )
  934.     (setq *critical* nil))) 
  935.  
  936. ; mapwm maps down the elements of wm, applying fn to each element
  937. ; each element is of form (datum . creation-time)
  938.  
  939. (defun mapwm (fn)
  940.   (prog (wmpl part)
  941.         (setq wmpl *wmpart-list*)
  942.    lab1 (cond ((atom wmpl) (return nil)))
  943.         (setq part (get (car wmpl) 'wmpart*))
  944.         (setq wmpl (cdr wmpl))
  945.         (mapc fn part)
  946.         (go lab1))) 
  947.  
  948. (defmacro wm (&rest a) 
  949.   `(progn
  950.    (mapc (function (lambda (z) (terpri) (ppelm z t))) 
  951.     (get-wm ',a))
  952.   nil) )
  953.  
  954. (defun get-wm (z)
  955.   (setq *wm-filter* z)
  956.   (setq *wm* nil)
  957.   (mapwm (function get-wm2))
  958.   (prog2 nil *wm* (setq *wm* nil))) 
  959.  
  960. (defun get-wm2 (elem) 
  961.  (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
  962.     (setq *wm* (cons (car elem) *wm*)))))
  963.  
  964. (defun wm-hash (x)
  965.   (cond ((not x) '<default>)
  966.         ((not (car x)) (wm-hash (cdr x)))
  967.         ((symbolp (car x)) (car x))
  968.         (t (wm-hash (cdr x))))) 
  969.  
  970. (defun creation-time (wme)
  971.   (cdr (assoc wme (get (wm-hash wme) 'wmpart*) :test #'eq))) 
  972.  
  973. (defun rehearse nil
  974.   (prog nil
  975.     (setq *old-wm* nil)
  976.     (mapwm (function refresh-collect))
  977.     (mapc (function refresh-del) *old-wm*)
  978.     (mapc (function refresh-add) *old-wm*)
  979.     (setq *old-wm* nil))) 
  980.  
  981. (defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*))) 
  982.  
  983. (defun refresh-del (x) (remove-from-wm (car x))) 
  984.  
  985. (defun refresh-add (x) (add-to-wm (car x) (cdr x))) 
  986.  
  987. (defun trace-file ()
  988.   (prog (port)
  989.         (setq port t)
  990.     (cond (*trace-file*
  991.            (setq port ($ofile *trace-file*))
  992.            (cond ((null port)
  993.                   (%warn '|trace: file has been closed| *trace-file*)
  994.               (setq port t)))))
  995.         (return port)))
  996.  
  997.  
  998. ;;; Basic functions for RHS evaluation
  999.  
  1000. (defun eval-rhs (pname data)
  1001.   (prog (node port)
  1002.     (cond (*ptrace*
  1003.            (setq port (trace-file))
  1004.            (terpri port)
  1005.            (princ *cycle-count* port)
  1006.            (princ '|. | port)
  1007.            (princ pname port)
  1008.            (time-tag-print data port)))
  1009.     (setq *data-matched* data)
  1010.     (setq *p-name* pname)
  1011.     (setq *last* nil)
  1012.     (setq node (get pname 'topnode))
  1013.     (init-var-mem (var-part node))
  1014.     (init-ce-var-mem (ce-var-part node))
  1015.     (begin-record pname data)
  1016.     (setq *in-rhs* t)
  1017.     (eval (rhs-part node))
  1018.     (setq *in-rhs* nil)
  1019.     (end-record))) 
  1020.  
  1021. (defun time-tag-print (data port)
  1022.   (cond ((not (null data))
  1023.          (time-tag-print (cdr data) port)
  1024.          (princ '| | port)
  1025.          (princ (creation-time (car data)) port))))
  1026.  
  1027. (defun init-var-mem (vlist)
  1028.   (prog (v ind r)
  1029.         (setq *variable-memory* nil)
  1030.    top  (and (atom vlist) (return nil))
  1031.         (setq v (car vlist))
  1032.         (setq ind (cadr vlist))
  1033.         (setq vlist (cddr vlist))
  1034.         (setq r (gelm *data-matched* ind))
  1035.         (setq *variable-memory* (cons (cons v r) *variable-memory*))
  1036.         (go top))) 
  1037.  
  1038. (defun init-ce-var-mem (vlist)
  1039.   (prog (v ind r)
  1040.         (setq *ce-variable-memory* nil)
  1041.    top  (and (atom vlist) (return nil))
  1042.         (setq v (car vlist))
  1043.         (setq ind (cadr vlist))
  1044.         (setq vlist (cddr vlist))
  1045.         (setq r (ce-gelm *data-matched* ind))
  1046.         (setq *ce-variable-memory*
  1047.               (cons (cons v r) *ce-variable-memory*))
  1048.         (go top))) 
  1049.  
  1050. (defun make-ce-var-bind (var elem)
  1051.   (setq *ce-variable-memory*
  1052.         (cons (cons var elem) *ce-variable-memory*))) 
  1053.  
  1054. (defun make-var-bind (var elem)
  1055.   (setq *variable-memory* (cons (cons var elem) *variable-memory*))) 
  1056.  
  1057. (defun $varbind (x)
  1058.   (prog (r)
  1059.     (and (not *in-rhs*) (return x))
  1060.         (setq r (assoc x *variable-memory* :test #'eq))
  1061.         (cond (r (return (cdr r)))
  1062.               (t (return x))))) 
  1063.  
  1064. (defun get-ce-var-bind (x)
  1065.   (prog (r)
  1066.         (cond ((numberp x) (return (get-num-ce x))))
  1067.         (setq r (assoc x *ce-variable-memory* :test #'eq))
  1068.         (cond (r (return (cdr r)))
  1069.               (t (return nil))))) 
  1070.  
  1071. (defun get-num-ce (x)
  1072.   (prog (r l d)
  1073.         (setq r *data-matched*)
  1074.         (setq l (length r))
  1075.         (setq d (- l x))
  1076.         (and (> 0. d) (return nil))
  1077.    la   (cond ((null r) (return nil))
  1078.               ((> 1. d) (return (car r))))
  1079.         (setq d (1- d))
  1080.         (setq r (cdr r))
  1081.         (go la))) 
  1082.  
  1083.  
  1084. (defun build-collect (z)
  1085.   (prog (r)
  1086.    la   (and (atom z) (return nil))
  1087.         (setq r (car z))
  1088.         (setq z (cdr z))
  1089.         (cond ((and r (listp r))
  1090.                ($value '\()
  1091.                (build-collect r)
  1092.                ($value '\)))
  1093.               ((eq r '\\) ($change (car z)) (setq z (cdr z)))
  1094.               (t ($value r)))
  1095.         (go la))) 
  1096.  
  1097. (defun unflat (x) (setq *rest* x) (unflat*)) 
  1098.  
  1099. (defun unflat* nil
  1100.   (prog (c)
  1101.         (cond ((atom *rest*) (return nil)))
  1102.         (setq c (car *rest*))
  1103.         (setq *rest* (cdr *rest*))
  1104.         (cond ((eq c '\() (return (cons (unflat*) (unflat*))))
  1105.               ((eq c '\)) (return nil))
  1106.               (t (return (cons c (unflat*))))))) 
  1107.  
  1108.  
  1109. (defun $change (x)
  1110.   (prog nil
  1111.         (cond ((and x (listp x)) (eval-function x)) ;modified to check for nil
  1112.               (t ($value ($varbind x)))))) 
  1113.  
  1114. (defun eval-args (z)
  1115.   (prog (r)
  1116.         (rhs-tab 1.)
  1117.    la   (and (atom z) (return nil))
  1118.         (setq r (car z))
  1119.         (setq z (cdr z))
  1120.         (cond ((eq r #\^)
  1121.                (rhs-tab (car z))
  1122.                (setq r (cadr z))
  1123.                (setq z (cddr z))))
  1124.         (cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
  1125.               (t ($change r)))
  1126.         (go la))) 
  1127.  
  1128.  
  1129. (defun eval-function (form)
  1130.   (cond ((not *in-rhs*)
  1131.      (%warn '|functions cannot be used at top level| (car form)))
  1132.     (t (eval form))))
  1133.  
  1134.  
  1135. ;;; Functions to manipulate the result array
  1136.  
  1137.  
  1138. (defun $reset nil
  1139.   (setq *max-index* 0)
  1140.   (setq *next-index* 1)) 
  1141.  
  1142. ; rhs-tab implements the tab ('^') function in the rhs.  it has
  1143. ; four responsibilities:
  1144. ;    - to move the array pointers
  1145. ;    - to watch for tabbing off the left end of the array
  1146. ;      (ie, to watch for pointers less than 1)
  1147. ;    - to watch for tabbing off the right end of the array
  1148. ;    - to write nil in all the slots that are skipped
  1149. ; the last is necessary if the result array is not to be cleared
  1150. ; after each use; if rhs-tab did not do this, $reset
  1151. ; would be much slower.
  1152.  
  1153. (defun rhs-tab (z) ($tab ($varbind z)))
  1154.  
  1155. (defun $tab (z)
  1156.   (prog (edge next)
  1157.         (setq next ($litbind z))
  1158.         (and (floatp next) (setq next (round next)))
  1159.         (cond ((or (not (numberp next)) 
  1160.            (> next *size-result-array*)
  1161.            (> 1. next))
  1162.                (%warn '|illegal index after ^| next)
  1163.                (return *next-index*)))
  1164.         (setq edge (- next 1.))
  1165.         (cond ((> *max-index* edge) (go ok)))
  1166.    clear (cond ((== *max-index* edge) (go ok)))
  1167.         (putvector *result-array* edge nil)
  1168.         (setq edge (1- edge))
  1169.         (go clear)
  1170.    ok   (setq *next-index* next)
  1171.         (return next))) 
  1172.  
  1173. (defun $value (v)
  1174.   (cond ((> *next-index* *size-result-array*)
  1175.          (%warn '|index too large| *next-index*))
  1176.         (t
  1177.          (and (> *next-index* *max-index*)
  1178.               (setq *max-index* *next-index*))
  1179.          (putvector *result-array* *next-index* v)
  1180.          (setq *next-index* (1+ *next-index*))))) 
  1181.  
  1182. (defun use-result-array nil
  1183.   (prog (k r)
  1184.         (setq k *max-index*)
  1185.         (setq r nil)
  1186.    top  (and (== k 0.) (return r))
  1187.         (setq r (cons (getvector *result-array* k) r))
  1188.         (setq k (1- k))
  1189.         (go top))) 
  1190.  
  1191. (defun $assert nil
  1192.   (setq *last* (use-result-array))
  1193.   (add-to-wm *last* nil))
  1194.  
  1195. (defun $parametercount nil *max-index*)
  1196.  
  1197. (defun $parameter (k)
  1198.   (cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
  1199.      (%warn '|illegal parameter number | k)
  1200.          nil)
  1201.         ((> k *max-index*) nil)
  1202.     (t (getvector *result-array* k))))
  1203.  
  1204.  
  1205. ;;; RHS actions
  1206.  
  1207.  
  1208. (defmacro make(&rest z)
  1209.   `(prog nil
  1210.         ($reset)
  1211.         (eval-args ',z)
  1212.         ($assert))) 
  1213.  
  1214. (defmacro modify (&rest z)
  1215.   `(prog (old args)
  1216.         (setq args ',z)
  1217.     (cond ((not *in-rhs*)
  1218.            (%warn '|cannot be called at top level| 'modify)
  1219.            (return nil)))
  1220.         (setq old (get-ce-var-bind (car args)))
  1221.         (cond ((null old)
  1222.                (%warn '|modify: first argument must be an element variable|
  1223.                         (car args))
  1224.                (return nil)))
  1225.         (remove-from-wm old)
  1226.         (setq args (cdr args))
  1227.         ($reset)
  1228.    copy (and (atom old) (go fin))
  1229.         ($change (car old))
  1230.         (setq old (cdr old))
  1231.         (go copy)
  1232.    fin  (eval-args args)
  1233.         ($assert))) 
  1234.  
  1235. (defmacro bind (&rest z)
  1236.   `(prog (val)
  1237.     (cond ((not *in-rhs*)
  1238.            (%warn '|cannot be called at top level| 'bind)
  1239.            (return nil)))
  1240.     (cond ((< (length z) 1.)
  1241.            (%warn '|bind: wrong number of arguments to| ',z)
  1242.            (return nil))
  1243.           ((not (symbolp (car ',z)))
  1244.            (%warn '|bind: illegal argument| (car ',z))
  1245.            (return nil))
  1246.           ((= (length ',z) 1.) (setq val (gensym)))
  1247.           (t ($reset)
  1248.              (eval-args (cdr ',z))
  1249.              (setq val ($parameter 1.))))
  1250.     (make-var-bind (car ',z) val))) 
  1251.  
  1252. (defmacro cbind (&rest z)
  1253.   `(cond ((not *in-rhs*)
  1254.      (%warn '|cannot be called at top level| 'cbind))
  1255.     ((not (= (length ',z) 1.))
  1256.      (%warn '|cbind: wrong number of arguments| ',z))
  1257.     ((not (symbolp (car ',z)))
  1258.      (%warn '|cbind: illegal argument| (car ',z)))
  1259.     ((null *last*)
  1260.      (%warn '|cbind: nothing added yet| (car ',z)))
  1261.     (t (make-ce-var-bind (car ',z) *last*)))) 
  1262.  
  1263. (defmacro oremove (&rest z)
  1264.   `(prog (old args)
  1265.         (setq args ',z)
  1266.     (and (not *in-rhs*)(return (top-level-remove args)))
  1267.    top  (and (atom args) (return nil))
  1268.         (setq old (get-ce-var-bind (car args)))
  1269.         (cond ((null old)
  1270.                (%warn '|remove: argument not an element variable| (car args))
  1271.                (return nil)))
  1272.         (remove-from-wm old)
  1273.         (setq args (cdr args))
  1274.         (go top))) 
  1275.  
  1276. (defmacro ocall (&rest z)
  1277.   `(prog (f)
  1278.     (setq f (car ',z))
  1279.         ($reset)
  1280.         (eval-args (cdr ',z))
  1281.         (funcall f))) 
  1282.  
  1283. (defmacro owrite (&rest z)
  1284.  `(prog (port max k x needspace)
  1285.     (cond ((not *in-rhs*)
  1286.            (%warn '|cannot be called at top level| 'write)
  1287.            (return nil)))
  1288.     ($reset)
  1289.     (eval-args ',z)
  1290.     (setq k 1.)
  1291.     (setq max ($parametercount))
  1292.     (cond ((< max 1.)
  1293.            (%warn '|write: nothing to print| ',z)
  1294.            (return nil)))
  1295.     (setq port (default-write-file))
  1296.     (setq x ($parameter 1.))
  1297.     (cond ((and (symbolp x) ($ofile x)) 
  1298.            (setq port ($ofile x))
  1299.            (setq k 2.)))
  1300.         (setq needspace t)
  1301.    la   (and (> k max) (return nil))
  1302.     (setq x ($parameter k))
  1303.     (cond ((eq x '|=== C R L F ===|)
  1304.            (setq needspace nil)
  1305.                (terpri port))
  1306.               ((eq x '|=== R J U S T ===|)
  1307.            (setq k (+ 2 k))
  1308.            (do-rjust ($parameter (1- k)) ($parameter k) port))
  1309.           ((eq x '|=== T A B T O ===|)
  1310.            (setq needspace nil)
  1311.            (setq k (1+ k))
  1312.            (do-tabto ($parameter k) port))
  1313.           (t 
  1314.            (and needspace (princ '| | port))
  1315.            (setq needspace t)
  1316.            (princ x port)))
  1317.     (setq k (1+ k))
  1318.     (go la))) 
  1319.     
  1320. (defun default-write-file ()
  1321.   (prog (port)
  1322.     (setq port t)
  1323.     (cond (*write-file*
  1324.            (setq port ($ofile *write-file*))
  1325.            (cond ((null port) 
  1326.               (%warn '|write: file has been closed| *write-file*)
  1327.               (setq port t)))))
  1328.         (return port)))
  1329.  
  1330.                                                                                                                                                                                                          
  1331. (defun do-rjust (width value port)
  1332.   (prog (size)
  1333.     (cond ((eq value '|=== T A B T O ===|)
  1334.            (%warn '|rjust cannot precede this function| 'tabto)
  1335.                (return nil))
  1336.           ((eq value '|=== C R L F ===|)
  1337.            (%warn '|rjust cannot precede this function| 'crlf)
  1338.                (return nil))
  1339.           ((eq value '|=== R J U S T ===|)
  1340.            (%warn '|rjust cannot precede this function| 'rjust)
  1341.                (return nil)))
  1342.         (setq size (length (princ-to-string value )))
  1343.     (cond ((> size width)
  1344.            (princ '| | port)
  1345.            (princ value port)
  1346.            (return nil)))
  1347.         (do k (- width size) (1- k) (not (> k 0)) (princ '| | port))
  1348.     (princ value port)))
  1349.  
  1350. (defun do-tabto (col port)
  1351.   (eval `(format ,port (concatenate 'string "~" (princ-to-string ,col) "T"))))
  1352.  
  1353. ;  (prog (pos)
  1354. ;    (setq pos (1+ (nwritn port)))
  1355. ;    (cond ((> pos col)
  1356. ;           (terpri port)
  1357. ;           (setq pos 1)))
  1358. ;    (do k (- col pos) (1- k) (not (> k 0)) (princ '| | port))
  1359. ;    (return nil)))
  1360.  
  1361.  
  1362. (defun halt nil 
  1363.   (cond ((not *in-rhs*)
  1364.      (%warn '|cannot be called at top level| 'halt))
  1365.     (t (setq *halt-flag* t)))) 
  1366.  
  1367. (defmacro build (&rest z)
  1368.   `(prog (r)
  1369.     (cond ((not *in-rhs*)
  1370.            (%warn '|cannot be called at top level| 'build)
  1371.            (return nil)))
  1372.         ($reset)
  1373.         (build-collect ',z)
  1374.         (setq r (unflat (use-result-array)))
  1375.         (and *build-trace* (funcall *build-trace* r))
  1376.         (compile-production (car r) (cdr r)))) 
  1377.  
  1378. (defun infile(file)
  1379.    (open file :direction :input))
  1380.  
  1381. (defun outfile(file)
  1382.    (open file :direction :output))
  1383.  
  1384. (defmacro openfile (&rest z)
  1385.   `(prog (file mode id)
  1386.     ($reset)
  1387.     (eval-args ',z)
  1388.     (cond ((not (equal ($parametercount) 3.))
  1389.            (%warn '|openfile: wrong number of arguments| ',z)
  1390.            (return nil)))
  1391.     (setq id ($parameter 1))
  1392.     (setq file ($parameter 2))
  1393.     (setq mode ($parameter 3))
  1394.     (cond ((not (symbolp id))
  1395.            (%warn '|openfile: file id must be a symbolic atom| id)
  1396.            (return nil))
  1397.               ((null id)
  1398.                (%warn '|openfile: 'nil' is reserved for the terminal| nil)
  1399.                (return nil))
  1400.           ((or ($ifile id)($ofile id))
  1401.            (%warn '|openfile: name already in use| id)
  1402.            (return nil)))
  1403.     (cond ((eq mode 'in) (putprop id  (infile file) 'inputfile))
  1404.           ((eq mode 'out) (putprop id  (outfile file) 'outputfile))
  1405.           (t (%warn '|openfile: illegal mode| mode)
  1406.          (return nil)))
  1407.     (return nil)))
  1408.  
  1409. (defun $ifile (x) 
  1410.   (cond ((and x (symbolp x)) (get x 'inputfile))
  1411.         (t *standard-input*)))
  1412.  
  1413. (defun $ofile (x) 
  1414.   (cond ((and x (symbolp x)) (get x 'outputfile))
  1415.         (t *standard-output*)))
  1416.  
  1417.  
  1418. (defmacro closefile (&rest z)
  1419.   `(progn 
  1420.     ($reset)
  1421.     (eval-args ',z)
  1422.     (mapc (function closefile2) (use-result-array))))
  1423.  
  1424. (defun closefile2 (file)
  1425.   (prog (port)
  1426.     (cond ((not (symbolp file))
  1427.            (%warn '|closefile: illegal file identifier| file))
  1428.           ((setq port ($ifile file))
  1429.            (close port)
  1430.            (remprop file 'inputfile))
  1431.           ((setq port ($ofile file))
  1432.            (close port)
  1433.            (remprop file 'outputfile)))
  1434.     (return nil)))
  1435.  
  1436. (defmacro default (&rest z)
  1437.   `(prog (file use)
  1438.     ($reset)
  1439.     (eval-args ',z)
  1440.     (cond ((not (equal ($parametercount) 2.))
  1441.            (%warn '|default: wrong number of arguments| ',z)
  1442.            (return nil)))
  1443.     (setq file ($parameter 1))
  1444.     (setq use ($parameter 2))
  1445.     (cond ((not (symbolp file))
  1446.            (%warn '|default: illegal file identifier| file)
  1447.            (return nil))
  1448.           ((not (member use '(write accept trace)))
  1449.            (%warn '|default: illegal use for a file| use)
  1450.            (return nil))
  1451.           ((and (member use '(write trace)) 
  1452.             (not (null file))
  1453.             (not ($ofile file)))
  1454.            (%warn '|default: file has not been opened for output| file)
  1455.            (return nil))
  1456.           ((and (eq use 'accept) 
  1457.             (not (null file))
  1458.             (not ($ifile file)))
  1459.            (%warn '|default: file has not been opened for input| file)
  1460.            (return nil))
  1461.           ((eq use 'write) (setq *write-file* file))
  1462.           ((eq use 'accept) (setq *accept-file* file))
  1463.           ((eq use 'trace) (setq *trace-file* file)))
  1464.     (return nil)))
  1465.  
  1466.  
  1467.  
  1468. ;;; RHS Functions
  1469.  
  1470. (defmacro accept (&rest z)
  1471.   `(prog (port arg)
  1472.     (cond ((> (length ',z) 1.)
  1473.            (%warn '|accept: wrong number of arguments| ',z)
  1474.            (return nil)))
  1475.     (setq port t)
  1476.     (cond (*accept-file*
  1477.            (setq port ($ifile *accept-file*))
  1478.            (cond ((null port) 
  1479.               (%warn '|accept: file has been closed| *accept-file*)
  1480.               (return nil)))))
  1481.     (cond ((= (length ',z) 1)
  1482.            (setq arg ($varbind (car ',z)))
  1483.            (cond ((not (symbolp arg))
  1484.                   (%warn '|accept: illegal file name| arg)
  1485.               (return nil)))
  1486.            (setq port ($ifile arg))
  1487.            (cond ((null port) 
  1488.               (%warn '|accept: file not open for input| arg)
  1489.               (return nil)))))
  1490.         (cond ((= (tyipeek port) -1.)
  1491.            ($value 'end-of-file)
  1492.            (return nil)))
  1493.     (flat-value (read port)))) 
  1494.  
  1495. (defun flat-value (x)
  1496.   (cond ((atom x) ($value x))
  1497.         (t (mapc (function flat-value) x)))) 
  1498.  
  1499. (defun span-chars (x prt)
  1500.   (do ((ch (tyipeek prt) (tyipeek prt))) ((not (member ch x #'char-equal))) (read-char prt)))
  1501.  
  1502. (defmacro acceptline (&rest z)
  1503.   `(prog ( def arg port)
  1504.     (setq port t)
  1505.     (setq def ',z)
  1506.     (cond (*accept-file*
  1507.            (setq port ($ifile *accept-file*))
  1508.            (cond ((null port) 
  1509.               (%warn '|acceptline: file has been closed| 
  1510.                      *accept-file*)
  1511.               (return nil)))))
  1512.     (cond ((> (length def) 0)
  1513.            (setq arg ($varbind (car def)))
  1514.            (cond ((and (symbolp arg) ($ifile arg))
  1515.                   (setq port ($ifile arg))
  1516.               (setq def (cdr def))))))
  1517.         (span-chars '(9. 41.) port)
  1518.     (cond ((member (tyipeek port) '(-1. 10.))
  1519.            (mapc (function $change) def)
  1520.            (return nil)))
  1521.    lp1    (flat-value (read port))
  1522.         (span-chars '(9. 41.) port)
  1523.     (cond ((not (member (tyipeek port) '(-1. 10.))) (go lp1)))))
  1524.  
  1525. (defmacro substr (&rest l)
  1526.   `(prog (k elm start end)
  1527.         (cond ((not (= (length ',l) 3.))
  1528.                (%warn '|substr: wrong number of arguments| ',l)
  1529.                (return nil)))
  1530.         (setq elm (get-ce-var-bind (car ',l)))
  1531.         (cond ((null elm)
  1532.                (%warn '|first argument to substr must be a ce var|
  1533.                         ',l)
  1534.                (return nil)))
  1535.         (setq start ($varbind (cadr ',l)))
  1536.     (setq start ($litbind start))
  1537.         (cond ((not (numberp start))
  1538.                (%warn '|second argument to substr must be a number|
  1539.                         ',l)
  1540.                (return nil)))
  1541.     ;if a variable is bound to INF, the following
  1542.     ;will get the binding and treat it as INF is
  1543.     ;always treated.  that may not be good
  1544.         (setq end ($varbind (caddr ',l)))
  1545.         (cond ((eq end 'inf) (setq end (length elm))))
  1546.     (setq end ($litbind end))
  1547.         (cond ((not (numberp end))
  1548.                (%warn '|third argument to substr must be a number|
  1549.                         ',l)
  1550.                (return nil)))
  1551.         ;this loop does not check for the end of elm
  1552.         ;instead it relies on cdr of nil being nil
  1553.         ;this may not work in all versions of lisp
  1554.         (setq k 1.)
  1555.    la   (cond ((> k end) (return nil))
  1556.               ((not (< k start)) ($value (car elm))))
  1557.         (setq elm (cdr elm))
  1558.         (setq k (1+ k))
  1559.         (go la))) 
  1560.  
  1561.  
  1562. (defmacro compute (&rest z) `($value (ari ',z))) 
  1563.  
  1564. ; arith is the obsolete form of compute
  1565. (defmacro arith (&rest z) `($value (ari ',z))) 
  1566.  
  1567. (defun ari (x)
  1568.   (cond ((atom x)
  1569.          (%warn '|bad syntax in arithmetic expression | x)
  1570.      0.)
  1571.         ((atom (cdr x)) (ari-unit (car x)))
  1572.         ((eq (cadr x) '+)
  1573.          (+ (ari-unit (car x)) (ari (cddr x))))
  1574.         ((eq (cadr x) '-)
  1575.          (difference (ari-unit (car x)) (ari (cddr x))))
  1576.         ((eq (cadr x) '*)
  1577.          (times (ari-unit (car x)) (ari (cddr x))))
  1578.         ((eq (cadr x) '//)
  1579.          (/ (ari-unit (car x)) (ari (cddr x))))
  1580.         ((eq (cadr x) '\\)
  1581.          (mod (round (ari-unit (car x))) (round (ari (cddr x)))))
  1582.         (t (%warn '|bad syntax in arithmetic expression | x) 0.))) 
  1583.  
  1584. (defun ari-unit (a)
  1585.   (prog (r)
  1586.         (cond ((listp a) (setq r (ari a)))
  1587.               (t (setq r ($varbind a))))
  1588.         (cond ((not (numberp r))
  1589.                (%warn '|bad value in arithmetic expression| a)
  1590.                (return 0.))
  1591.               (t (return r))))) 
  1592.  
  1593. (defun genatom nil ($value (gensym))) 
  1594.  
  1595. (defmacro litval (&rest z)
  1596.   `(prog (r)
  1597.     (cond ((not (= (length ',z) 1.))
  1598.            (%warn '|litval: wrong number of arguments| ',z)
  1599.            ($value 0) 
  1600.            (return nil))
  1601.           ((numberp (car ',z)) ($value (car ',z)) (return nil)))
  1602.     (setq r ($litbind ($varbind (car ',z))))
  1603.     (cond ((numberp r) ($value r) (return nil)))
  1604.     (%warn '|litval: argument has no literal binding| (car ',z))
  1605.     ($value 0)))
  1606.  
  1607.  
  1608. (defmacro rjust (&rest z)
  1609.   `(prog (val)
  1610.         (cond ((not (= (length ',z) 1.))
  1611.            (%warn '|rjust: wrong number of arguments| ',z)
  1612.                (return nil)))
  1613.         (setq val ($varbind (car ',z)))
  1614.     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
  1615.            (%warn '|rjust: illegal value for field width| val)
  1616.            (return nil)))
  1617.         ($value '|=== R J U S T ===|)
  1618.     ($value val)))
  1619.  
  1620.  
  1621. (defmacro crlf()
  1622.      ($value '|=== C R L F ===|))
  1623.  
  1624. (defmacro tabto (&rest z)
  1625.   `(prog (val)
  1626.         (cond ((not (= (length ',z) 1.))
  1627.            (%warn '|tabto: wrong number of arguments| ',z)
  1628.            (return nil)))
  1629.         (setq val ($varbind (car ',z)))
  1630.     (cond ((or (not (numberp val)) (< val 1.) (> val 127.))
  1631.            (%warn '|tabto: illegal column number| ',z)
  1632.            (return nil)))
  1633.         ($value '|=== T A B T O ===|)
  1634.     ($value val)))
  1635.  
  1636.  
  1637.  
  1638. ;;; Printing WM
  1639.  
  1640. (defmacro ppwm (&rest z)
  1641.   `(prog (next a avlist)
  1642.         (setq avlist ',z)
  1643.         (setq *filters* nil)
  1644.         (setq next 1.)
  1645.    l   (and (atom avlist) (go print))
  1646.         (setq a (car avlist))
  1647.         (setq avlist (cdr avlist))
  1648.         (cond ((eq a #\^)
  1649.                (setq next (car avlist))
  1650.                (setq avlist (cdr avlist))
  1651.                (setq next ($litbind next))
  1652.                (and (floatp next) (setq next (round next)))
  1653.                (cond ((or (not (numberp next))
  1654.                           (> next *size-result-array*)
  1655.                           (> 1. next))
  1656.                       (%warn '|illegal index after ^| next)
  1657.                       (return nil))))
  1658.               ((variablep a)
  1659.                (%warn '|ppwm does not take variables| a)
  1660.                (return nil))
  1661.               (t (setq *filters* (cons next (cons a *filters*)))
  1662.                  (setq next (1+ next))))
  1663.         (go l)
  1664.    print (mapwm (function ppwm2))
  1665.         (terpri)
  1666.         (return nil))) 
  1667.  
  1668. (defun ppwm2 (elm-tag)
  1669.   (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) t)))) 
  1670.  
  1671. (defun filter (elm)
  1672.   (prog (fl indx val)
  1673.         (setq fl *filters*)
  1674.    top  (and (atom fl) (return t))
  1675.         (setq indx (car fl))
  1676.         (setq val (cadr fl))
  1677.         (setq fl (cddr fl))
  1678.         (and (ident (nth (1- indx) elm) val) (go top))
  1679.         (return nil))) 
  1680.  
  1681. (defun ident (x y)
  1682.   (cond ((eq x y) t)
  1683.         ((not (numberp x)) nil)
  1684.         ((not (numberp y)) nil)
  1685.         ((=alg x y) t)
  1686.         (t nil))) 
  1687.  
  1688. ; the new ppelm is designed especially to handle literalize format
  1689. ; however, it will do as well as the old ppelm on other formats
  1690.  
  1691. (defun ppelm (elm port)
  1692.   (prog (ppdat sep val att mode lastpos)
  1693.     (princ (creation-time elm) port)
  1694.     (princ '|:  | port)
  1695.         (setq mode 'vector)
  1696.     (setq ppdat (get (car elm) 'ppdat))
  1697.     (and ppdat (setq mode 'a-v))
  1698.     (setq sep '|(|)
  1699.         (setq lastpos 0)
  1700.     (do
  1701.      ((curpos 1 (1+ curpos)) (vlist elm (cdr vlist)))
  1702.      ((atom vlist) nil)
  1703.      (setq val (car vlist))
  1704.      (setq att (assoc curpos ppdat))
  1705.      (cond (att (setq att (cdr att)))
  1706.            (t (setq att curpos)))
  1707.          (and (symbolp att) (is-vector-attribute att) (setq mode 'vector))
  1708.      (cond ((or (not (null val)) (eq mode 'vector))
  1709.         (princ sep port)
  1710.         (ppval val att lastpos port)
  1711.         (setq sep '|    |)
  1712.         (setq lastpos curpos))))
  1713.     (princ '|)| port)))
  1714.  
  1715. (defun ppval (val att lastpos port)
  1716.   (cond ((not (equal att (1+ lastpos)))
  1717.          (princ '^ port)
  1718.          (princ att port)
  1719.          (princ '| | port)))
  1720.   (princ val port))
  1721.  
  1722.