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-RHS.LIS
< prev
next >
Wrap
Lisp/Scheme
|
1992-03-06
|
17KB
|
647 lines
;
;************************************************************************
;
; VPS2 -- Interpreter for OPS5
;
;
;
; This Common Lisp version of OPS5 is in the public domain. It is based
; in part on based on a Franz Lisp implementation done by Charles L. Forgy
; at Carnegie-Mellon University, which was placed in the public domain by
; the author in accordance with CMU policies. This version has been
; modified by George Wood, Dario Giuse, Skef Wholey, Michael Parzen,
; and Dan Kuokka.
;
; This code is made available is, and without warranty of any kind by the
; authors or by Carnegie-Mellon University.
;
;;;; This file contains all the functions necessary for RHS actions
;;;; including $actions.
(in-package "OPS")
(shadow '(remove write))
(export '(remove write make modify crlf))
(proclaim '(special *ptrace* *cycle-count* *halt-flag* *wtrace*))
;;; External global variables
(defvar *size-result-array*)
(defvar *in-rhs*)
(defvar *current-wm*)
(defvar *max-wm*)
(defvar *action-count*)
(defvar *critical*)
;;; Internal global variables
(defvar *wmpart-list*)
(defvar *wm-filter*)
(defvar *wm*)
(defvar *old-wm*)
(defvar *result-array*)
(defvar *variable-memory*)
(defvar *last*)
(defvar *max-index*)
(defvar *next-index*)
(defvar *data-matched*)
(defvar *ce-variable-memory*)
(defvar *rest*)
(defvar *build-trace*)
;;;; Functions for RHS evaluation
(defun rhs-init ()
; if the size of result-array changes, change the line in i-g-v which
; sets the value of *size-result-array*
(setq *size-result-array* 255.) ;255 /256 set by gdw
(setq *result-array* (make-array 256 :initial-element nil)) ;jgk
(setq *in-rhs* nil)
(setq *build-trace* nil)
(setq *max-wm* (setq *current-wm* 0.))
(setq *action-count* 0.)
(setq *critical* nil)
(setq *wmpart-list* nil))
(defun eval-rhs (pname data)
(prog (node port)
(cond (*ptrace*
(setq port (trace-file))
(terpri port)
(princ *cycle-count* port)
(princ '|. | port)
(princ pname port)
(time-tag-print data port)))
(setq *data-matched* data)
(setq *p-name* pname)
(setq *last* nil)
(setq node (get pname 'topnode))
(init-var-mem (var-part node))
(init-ce-var-mem (ce-var-part node))
(begin-record pname data)
(setq *in-rhs* t)
(eval (rhs-part node))
(setq *in-rhs* nil)
(end-record)))
(defun eval-args (z)
(prog (r)
(rhs-tab 1.)
la (and (atom z) (return nil))
(setq r (car z))
(setq z (cdr z))
(cond ((EQ R '^)
(RHS-tab (car z))
(setq r (cadr z))
(setq z (cddr z))))
(cond ((eq r '//) ($value (car z)) (setq z (cdr z)))
(t ($change r)))
(go la)))
;;;; RHS actions
;;;; Some of these can be called at the top level.
(defmacro make (&body z)
`(ops-make ',z))
(defmacro remove (&body z)
`(ops-remove ',z))
(defmacro modify (&body z)
`(ops-modify ',z))
(defmacro openfile (&body z)
`(ops-openfile ',z))
(defmacro closefile (&body z)
`(ops-closefile ',z))
(defmacro default (&body z)
`(ops-default ',z))
(defmacro write (&body z)
`(ops-write ',z))
(defmacro crlf (&body z)
`(ops-crlf ',z))
(defmacro tabto (&body z)
`(ops-tabto ',z))
(defmacro rjust (&body z)
`(ops-rjust ',z))
(defmacro call (&body z)
`(ops-call ',z))
(defmacro bind (&body z)
`(ops-bind ',z))
(defmacro cbind (&body z)
`(ops-cbind ',z))
(defmacro build (&body z)
`(ops-build ',z))
(defmacro substr (&body l)
`(ops-substr ',l))
(defmacro compute (&body z)
`(ops-compute ',z))
(defmacro litval (&body z)
`(ops-litval ',z))
(defmacro accept (&body z)
`(ops-accept ',z))
(defmacro acceptline (&body z)
`(ops-acceptline ',z))
(defmacro arith (&body z)
`(ops-arith ',z))
(defun ops-make (z)
(prog nil
($reset)
(eval-args z)
($assert)))
(defun ops-remove (z)
(prog (old)
(and (not *in-rhs*)(return (top-level-remove z)))
top (and (atom z) (return nil))
(setq old (get-ce-var-bind (car z)))
(cond ((null old)
(%warn '|remove: argument not an element variable| (car z))
(return nil)))
(remove-from-wm old)
(setq z (cdr z))
(go top)))
(defun ops-modify (z)
(prog (old)
(cond ((not *in-rhs*)
(%warn '|cannot be called at top level| 'modify)
(return nil)))
(setq old (get-ce-var-bind (car z)))
(cond ((null old)
(%warn '|modify: first argument must be an element variable|
(car z))
(return nil)))
(remove-from-wm old)
(setq z (cdr z))
($reset)
copy (and (atom old) (go fin))
($change (car old))
(setq old (cdr old))
(go copy)
fin (eval-args z)
($assert)))
(defun ops-bind (z)
(prog (val)
(cond ((not *in-rhs*)
(%warn '|cannot be called at top level| 'bind)
(return nil)))
(cond ((< (length z) 1.)
(%warn '|bind: wrong number of arguments to| z)
(return nil))
((not (symbolp (car z)))
(%warn '|bind: illegal argument| (car z))
(return nil))
((= (length z) 1.) (setq val (gensym)))
(t ($reset)
(eval-args (cdr z))
(setq val ($parameter 1.))))
(make-var-bind (car z) val)))
(defun ops-cbind (z)
(cond ((not *in-rhs*)
(%warn '|cannot be called at top level| 'cbind))
((not (= (length z) 1.))
(%warn '|cbind: wrong number of arguments| z))
((not (symbolp (car z)))
(%warn '|cbind: illegal argument| (car z)))
((null *last*)
(%warn '|cbind: nothing added yet| (car z)))
(t (make-ce-var-bind (car z) *last*))))
(defun ops-call (z)
(prog (f)
(setq f (car z))
($reset)
(eval-args (cdr z))
(funcall f)))
(defun halt nil
(cond ((not *in-rhs*)
(%warn '|cannot be called at top level| 'halt))
(t (setq *halt-flag* t))))
(defun ops-build (z)
(prog (r)
(cond ((not *in-rhs*)
(%warn '|cannot be called at top level| 'build)
(return nil)))
($reset)
(build-collect z)
(setq r (unflat (use-result-array)))
(and *build-trace* (funcall *build-trace* r))
(compile-production (car r) (cdr r))))
(defun ops-compute (z) ($value (ari z)))
; arith is the obsolete form of compute
(defun ops-arith (z) ($value (ari z)))
(defun ari (x)
(cond ((atom x)
(%warn '|bad syntax in arithmetic expression | x)
0.)
((atom (cdr x)) (ari-unit (car x)))
((eq (cadr x) '+)
(+ (ari-unit (car x)) (ari (cddr x))))
;"plus" changed to "+" by gdw
((eq (cadr x) '-)
(- (ari-unit (car x)) (ari (cddr x))))
((eq (cadr x) '*)
(* (ari-unit (car x)) (ari (cddr x))))
((eq (cadr x) '//)
(floor (ari-unit (car x)) (ari (cddr x)))) ;@@@ quotient? /
;@@@ kluge only works for integers
;@@@ changed to floor by jcp (from round)
((eq (cadr x) '\\)
(mod (fix (ari-unit (car x))) (fix (ari (cddr x)))))
(t (%warn '|bad syntax in arithmetic expression | x) 0.)))
(defun ari-unit (a)
(prog (r)
(cond ((consp a) (setq r (ari a))) ;dtpr\consp gdw
(t (setq r ($varbind a))))
(cond ((not (numberp r))
(%warn '|bad value in arithmetic expression| a)
(return 0.))
(t (return r)))))
(defun ops-substr (l)
(prog (k elm start end)
(cond ((not (= (length l) 3.))
(%warn '|substr: wrong number of arguments| l)
(return nil)))
(setq elm (get-ce-var-bind (car l)))
(cond ((null elm)
(%warn '|first argument to substr must be a ce var|
l)
(return nil)))
(setq start ($varbind (cadr l)))
(setq start ($litbind start))
(cond ((not (numberp start))
(%warn '|second argument to substr must be a number|
l)
(return nil)))
;### (comment |if a variable is bound to INF, the following|
; |will get the binding and treat it as INF is|
; |always treated. that may not be good|)
(setq end ($varbind (caddr l)))
(cond ((eq end 'inf) (setq end (length elm))))
(setq end ($litbind end))
(cond ((not (numberp end))
(%warn '|third argument to substr must be a number|
l)
(return nil)))
;### (comment |this loop does not check for the end of elm|
; |instead it relies on cdr of nil being nil|
; |this may not work in all versions of lisp|)
(setq k 1.)
la (cond ((> k end) (return nil))
((not (< k start)) ($value (car elm))))
(setq elm (cdr elm))
(setq k (1+ k))
(go la)))
(defun genatom nil ($value (gensym)))
(defun ops-litval (z)
(prog (r)
(cond ((not (= (length z) 1.))
(%warn '|litval: wrong number of arguments| z)
($value 0)
(return nil))
((numberp (car z)) ($value (car z)) (return nil)))
(setq r ($litbind ($varbind (car z))))
(cond ((numberp r) ($value r) (return nil)))
(%warn '|litval: argument has no literal binding| (car z))
($value 0)))
; rhs-tab implements the tab ('^') function in the rhs. it has
; four responsibilities:
; - to move the array pointers
; - to watch for tabbing off the left end of the array
; (ie, to watch for pointers less than 1)
; - to watch for tabbing off the right end of the array
; - to write nil in all the slots that are skipped
; the last is necessary if the result array is not to be cleared
; after each use; if rhs-tab did not do this, $reset
; would be much slower.
(defun rhs-tab (z) ($tab ($varbind z)))
(defun time-tag-print (data port)
(cond ((not (null data))
(time-tag-print (cdr data) port)
(princ '| | port)
(princ (creation-time (car data)) port))))
(defun init-var-mem (vlist)
(prog (v ind r)
(setq *variable-memory* nil)
top (and (atom vlist) (return nil))
(setq v (car vlist))
(setq ind (cadr vlist))
(setq vlist (cddr vlist))
(setq r (gelm *data-matched* ind))
(setq *variable-memory* (cons (cons v r) *variable-memory*))
(go top)))
(defun init-ce-var-mem (vlist)
(prog (v ind r)
(setq *ce-variable-memory* nil)
top (and (atom vlist) (return nil))
(setq v (car vlist))
(setq ind (cadr vlist))
(setq vlist (cddr vlist))
(setq r (ce-gelm *data-matched* ind))
(setq *ce-variable-memory*
(cons (cons v r) *ce-variable-memory*))
(go top)))
(defun make-ce-var-bind (var elem)
(setq *ce-variable-memory*
(cons (cons var elem) *ce-variable-memory*)))
(defun make-var-bind (var elem)
(setq *variable-memory* (cons (cons var elem) *variable-memory*)))
(defun get-ce-var-bind (x)
(prog (r)
(cond ((numberp x) (return (get-num-ce x))))
(setq r (assq x *ce-variable-memory*))
(cond (r (return (cdr r)))
(t (return nil)))))
(defun get-num-ce (x)
(prog (r l d)
(setq r *data-matched*)
(setq l (length r))
(setq d (- l x))
(and (> 0. d) (return nil))
la (cond ((null r) (return nil))
((> 1. d) (return (car r))))
(setq d (1- d))
(setq r (cdr r))
(go la)))
(defun build-collect (z)
(prog (r)
la (and (atom z) (return nil))
(setq r (car z))
(setq z (cdr z))
(cond ((consp r) ;dtpr\consp gdw
($value '\()
(build-collect r)
($value '\)))
((eq r '\\) ($change (car z)) (setq z (cdr z)))
(t ($value r)))
(go la)))
(defun unflat (x) (setq *rest* x) (unflat*))
(defun unflat* nil
(prog (c)
(cond ((atom *rest*) (return nil)))
(setq c (car *rest*))
(setq *rest* (cdr *rest*))
(cond ((eq c '\() (return (cons (unflat*) (unflat*))))
((eq c '\)) (return nil))
(t (return (cons c (unflat*)))))))
;;;; $Functions.
;;;; These functions provide an interface to the result array.
;;;; The result array is used to organize attribute values into their
;;;; correct slot.
(defun $litbind (x)
(prog (r)
(cond ((and (symbolp x) (setq r (literal-binding-of x)))
(return r))
(t (return x)))))
(defun $varbind (x)
(prog (r)
(and (not *in-rhs*) (return x))
(setq r (assq x *variable-memory*))
(cond (r (return (cdr r)))
(t (return x)))))
(defun $change (x)
(prog nil
(cond ((consp x) (eval-function x)) ;dtpr\consp gdw
(t ($value ($varbind x))))))
(defun $reset nil
(setq *max-index* 0.)
(setq *next-index* 1.))
(defun $tab (z)
(prog (edge next)
(setq next ($litbind z))
(and (floatp next) (setq next (fix next)))
(cond ((or (not (numberp next))
(> next *size-result-array*)
(> 1. next)) ; ( '| |)
(%warn '|illegal index after ^| next)
(return *next-index*)))
(setq edge (- next 1.))
(cond ((> *max-index* edge) (go ok)))
clear (cond ((== *max-index* edge) (go ok)))
(putvector *result-array* edge nil)
(setq edge (1- edge))
(go clear)
ok (setq *next-index* next)
(return next)))
(defun $value (v)
(cond ((> *next-index* *size-result-array*)
(%warn '|index too large| *next-index*))
(t
(and (> *next-index* *max-index*)
(setq *max-index* *next-index*))
(putvector *result-array* *next-index* v)
(setq *next-index* (1+ *next-index*)))))
(defun $assert nil
(setq *last* (use-result-array))
(add-to-wm *last* nil))
(defun $parametercount nil *max-index*)
(defun $parameter (k)
(cond ((or (not (numberp k)) (> k *size-result-array*) (< k 1.))
(%warn '|illegal parameter number | k)
nil)
((> k *max-index*) nil)
(t (getvector *result-array* k))))
(defun $ifile (x)
(cond ((symbolp x) (get x 'inputfile))
(t nil)))
(defun $ofile (x)
(cond ((symbolp x) (get x 'outputfile))
(t nil)))
;;; Use-result-array returns the contents of the result array as a list.
(defun use-result-array nil
(prog (k r)
(setq k *max-index*)
(setq r nil)
top (and (== k 0.) (return r))
(setq r (cons (getvector *result-array* k) r))
(setq k (1- k))
(go top)))
(defun eval-function (form)
(cond ((not *in-rhs*)
(%warn '|functions cannot be used at top level| (car form)))
(t (eval form))))
;;;; WM maintaining functions
;;; The order of operations in the following two functions is critical.
;;; add-to-wm order: (1) change wm (2) record change (3) match
;;; remove-from-wm order: (1) record change (2) match (3) change wm
;;; (back will not restore state properly unless wm changes are recorded
;;; before the cs changes that they cause) (match will give errors if
;;; the thing matched is not in wm at the time)
(defun add-to-wm (wme override)
(prog (fa z part timetag port)
(setq *critical* t)
(setq *current-wm* (1+ *current-wm*))
(and (> *current-wm* *max-wm*) (setq *max-wm* *current-wm*))
(setq *action-count* (1+ *action-count*))
(setq fa (wm-hash wme))
(or (member fa *wmpart-list*)
(setq *wmpart-list* (cons fa *wmpart-list*)))
(setq part (get fa 'wmpart*))
(cond (override (setq timetag override))
(t (setq timetag *action-count*)))
(setq z (cons wme timetag))
(putprop fa (cons z part) 'wmpart*)
(record-change '=>wm *action-count* wme)
(match 'new wme)
(setq *critical* nil)
(cond ((and *in-rhs* *wtrace*)
(setq port (trace-file))
(terpri port)
(princ '|=>wm: | port)
(ppelm wme port)))))
;;; remove-from-wm uses eq, not equal to determine if wme is present
(defun remove-from-wm (wme)
(prog (fa z part timetag port)
(setq fa (wm-hash wme))
(setq part (get fa 'wmpart*))
(setq z (assq wme part))
(or z (return nil))
(setq timetag (cdr z))
(cond ((and *wtrace* *in-rhs*)
(setq port (trace-file))
(terpri port)
(princ '|<=wm: | port)
(ppelm wme port)))
(setq *action-count* (1+ *action-count*))
(setq *critical* t)
(setq *current-wm* (1- *current-wm*))
(record-change '<=wm timetag wme)
(match nil wme)
(putprop fa (delq z part) 'wmpart*)
(setq *critical* nil)))
;;; mapwm maps down the elements of wm, applying fn to each element
;;; each element is of form (datum . creation-time)
(defun mapwm (fn)
(prog (wmpl part)
(setq wmpl *wmpart-list*)
lab1 (cond ((atom wmpl) (return nil)))
(setq part (get (car wmpl) 'wmpart*))
(setq wmpl (cdr wmpl))
(mapc fn part)
(go lab1)))
(defun ops-wm (a)
(mapc (function (lambda (z) (terpri) (ppelm z *standard-output*)))
(get-wm a))
nil)
(defun creation-time (wme)
(cdr (assq wme (get (wm-hash wme) 'wmpart*))))
(defun get-wm (z)
(setq *wm-filter* z)
(setq *wm* nil)
(mapwm (function get-wm2))
(prog2 nil *wm* (setq *wm* nil)))
(defun get-wm2 (elem)
; (cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*) :test #'equal)))
(cond ((or (null *wm-filter*) (member (cdr elem) *wm-filter*)) ;test #'equal)
(setq *wm* (cons (car elem) *wm*)))))
(defun wm-hash (x)
(cond ((not x) '<default>)
((not (car x)) (wm-hash (cdr x)))
((symbolp (car x)) (car x))
(t (wm-hash (cdr x)))))
(defun refresh nil
(prog nil
(setq *old-wm* nil)
(mapwm (function refresh-collect))
(mapc (function refresh-del) *old-wm*)
(mapc (function refresh-add) *old-wm*)
(setq *old-wm* nil)))
(defun refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
(defun refresh-del (x) (remove-from-wm (car x)))
(defun refresh-add (x) (add-to-wm (car x) (cdr x)))