;; -*- Mode:Common-Lisp;Package:mma; Base:10 -*-o
;; Mathematica(tm)-like evaluator
;; copyright (c) 2011 Richard J. Fateman;
;;BIG CHANGE FROM EARLIER VERSION of 3/2011 and previous.
;; Use Mathematica "Own Values" idea and memoizing
;;where the memoized value is subject to revision when variables on which a value depends, changes.
#| Here's the idea.
A symbol container in the global symbol table or on a stack becomes a more
complicated object. In particular, any symbol with a binding to anything
other than a constant must have the following properties, or at least
a possibility of having these properties:
* name, sometimes referred to as symbol print name e.g. x
* value, e.g. w^2+7
* function e.g. list of rules from SetDelayed, e.g. x[u_]:= ...
* extra values for arrays e.g. x[0,1]=45, unrelated to the fact that x=w^2+7
* Attributes for x as a function, e.g. {Listable, Flat, NumericFunction}.
apparently all stack-allocaed objects have Attribute Temporary.
* OwnValues.. These are original values when the rhs of a Set is
evaluated at assignment-time.
E.g. x1=x2; x2=x3; x4=x1; x1 has ownvalue x2. x4 has ownvalue x3. Yet
the value of x1 is x3, different from its OwnValue.
Mathematica lists OwnValues as, e.g. {HoldPattern[x1]:> x2}. This provides
a location to store information about x1[0,1] should it exist.
* A TimeStamp or counter: the order in time of the last assignment to x (or x[0,1]?) in the process run.
* Depends: associated with each ownvalue is a bag of every variable on which this depends.
* Thus x1 above depends on x2. x2 depends on x3.
How do to this: some of these attributes are associated with the variable
object and some are associated with the value. The timestamp could be
associated with the value, but there are too many of them. Just associate
with variable object.
To evaluate x1 which was last evaluated at time t=100, and at its
ownvalue, x2. Look at the time at which x2 was last evaluated.
Say it was time t=200. use its current value for x1, thereby updating
x1. Set its timestamp to "now".
Then just use x2222 for x1. and Update the time on x1.
That is, t=200 is more
example..
Module[{x = y, z}, z = x ; OwnValues[z]] == {HoldPattern[z$652] :> y} ....
Changes needed.
To SetDelayed[a, b],
Set T= TimeStamp. Also for a[0] etc. Increment the TimeStamp.
Set the Depends for a
then evaluate b to get expression c.
Set the "current value of b at timestamp T" to c.
Set the Ownvalue for a to b.
Oh, make a[[4]]=10 work, via Part[] on lhs of assignment.
To meval. specifically for meval-atom[q]. Look at q's TimeStamp. It must
be higher than every TimeStamp for q's depends list. If not, say
m in depends has a higher timestamp, then re-evaluate q from its ownvalue
list, and reset q's timestamp. (increment TS.)
what about flags that might affect evaluation?? uh, we lose them.
Mathematica loses them too.
consider
lim=4
q[x_]:= 0 /; x>lim
s={q[1],q[2],q[3],q[4]}
lim=2
s
(* a seemly unrelated assignment *)
q[5]=0
s
|#
(eval-when (compile) (load "mma"))
(in-package :mma)
(eval-when (load) (export '(tl mread1))
;;**********
)
(defvar COUNT 1 "line number for top-level. (same as (meval |$Line|))")
(declaim (special env *expand* *numer*)) ;; environment
;; The Mathematica semantics avoids repeated evaluation by putting a time stamp
;; on each object, as well as dependencies. If the object is newer than any
;; thing it depends on, then it is already "evaluated". Otherwise it
;; has to be re-evaluated and re-time-stamped. We don't do this right now,
;; but we might have to. Mathematica is a little vague and dependencies are
;; not listed explicitly (we think), but approached approximately, e.g.
;; expression x+y+z depends on stuff on some pages (which include the
;; residences of x,y,z. But they might all be on one page. And there
;; may be other things on those pages that change, so x+y+z might be
;; unnecessarily re-evaluated.
(defun |Set| (lhs rhs);; lhs=rhs
;; the value associated with the lhs will be stored
;; in the symbol table symtab, with the key h,
;; which is either the head of the lhs,
;; or the lhs itself. That is f=45 is stored in the
;; hash table for f, under the indicator "f"
;; and f[0]=7 is stored in the hash table for f, under
;; the indicator (0).
(declare (special symtab funnyvars))
(let ((h nil)(fun nil))
(cond ((symbolp lhs);; common case, "x=stuff"
;; 3 possibilities, x is bound on stack or or a funny-var or is global
;; (format t "~%setting symbol ~s" lhs)
(multiple-value-bind (val found)(sfind env lhs)
;; (format t "~%mvb result for symbol ~s is ~s ~s " lhs val found)
(cond (found ;found on stack.
(schange env lhs rhs)) ;;change it there.
((setf fun (gethash lhs funnyvars)) ;one of the vars needing special work
;; (format t "~%~s is in funnyvars"~s)
(funcall fun rhs))
(t ;;global case. Not found on stack
;; (format t "~%symtab is ~s" symtab)
(setf h (gethash lhs symtab)) ;odd. should be there from parser.
;; (format t "~%hashtable for ~s is ~s" lhs h)
(cond((null h)(chash lhs) (setf h (gethash lhs symtab))))
;; set h to the hash table for "x"
(setf (gethash lhs h) rhs))))) ; put value on key "x" in "x" hashtable
;; not not so simple an assignment, e.g., x[i,j]= stuff,
((consp lhs)
(setq h (gethash (car lhs) symtab)) ;symtab for x
(cond((null h)(chash (car lhs)) (setf h (gethash (car lhs) symtab))))
;; (format t "~% Set has non-atom lhs ~s" lhs)
;; (format t "~%hashtable for ~s is ~s" (car lhs) h)
(setq lhs (mevalargs (|Attributes|(car lhs))(cdr lhs))) ; evaluate i,j
(setf (gethash lhs h) rhs))
(t (error "illegal assignment target ~s" lhs)))
rhs)) ;return value
;;(format t "Set ~s to ~s, h=~s~%" lhs rhs h)
;; this stores the material in the hash table.
;; QUESTION: M'ma doesn't do this, but we could, by storing
;; stuff on a local environment... f[x_,y_]:=Block[{},x=y+1];
;; what if (gethash h symtab) is a matrix, and this is a valid matrix
;; setting? Then we should try to store the value in the array.
;; Next, check for special variables which, when set, cause other
;; things to happen. E.g. Precision= number means, in the
;; bigfloat system, (bigfloat-init number) gets executed.
;; there is another file (nmatrix) that defines a matrix type..
;; this should be tied in to the matrix stuff from franz, perhaps.
;; also, we have to decide which bigfloat to use... mpfun or rjf's
;; old bfstuff.
;; or MPFR. 12/2010
(defun |SetQQ|(lhs rhs &aux h);; lhs=rhs, but don't mevaluate either. hardly ever used.
(setq h(cond ((atom lhs) lhs)
(t (prog1 (car lhs) (setq lhs (cdr lhs))))))
(setf (gethash lhs (gethash h symtab))rhs)
(if (setq h (gethash h funnyvars ))(funcall h rhs))
rhs)
(defun |SetDelayed|(lhs rhs) ;; this is the function definition f[x_] := ...
(let* ((visible (ulist '|SetDelayed| lhs rhs))
(hidden (bindfix(fixopts visible))))
(setdelayed1 hidden)
(setf (gethash visible optimruleht) hidden) ;; store the optim rule/def here
'|Null|))
(defun setdelayed1(thedef)
(let* ((lhs (ucons (caadr thedef)
(umapcar #'meval (cdadr thedef)))) ;; see note re eval below
(hh (|Head| lhs)) ;; lets hope the Head is a symbol
(spot (gethash hh symtab)))
; (format t "~%lhs=~s" lhs)
;; should we evaluate the formal arguments? we need to do something, e.g.
;; f[Sqrt[x_]] should be changed to f[x_^(1/2)]
;; this could be merely simplification, not evaluation .. ugh.
;; (setf lhs (ucons (car lhs)(mevalargs nil (cdr lhs))))
;;(args (mevalargs (|Attributes|(|Head| hh)) (cdr lhs-in)))
;(args (cdr lhs-in)) ;; these should not be evaluated; they are like formal params, no?
;; push all but the 'SetDelayed on the list of definitional forms.
(if (null spot)(setf spot (setf (gethash hh symtab) (make-hash-table :test #'equal :size 4)))) ; not needed except bug?
(cond ((null (gethash '|SetDelayed| spot))
(setf (gethash '|SetDelayed| spot) (ulist (ucons lhs (cddr thedef)))))
(t (push (ucons lhs (cddr thedef)) (gethash '|SetDelayed| spot))))))
;; this assumes the value of a mathematica symbol is its lisp value
;; if it is simply a constant or non-hash-table. That means that
;; a lisp dynamically bound variable could be used to block access
;; to the globally bound variable of the same name. Better not
;; use local-variable names like Sin or Cos unless you mean to
;; inhibit access to the global names.
(defun meval-atom(h)
(declare (special env))
(if (constantp h) h
(multiple-value-bind
(val found)
(sfind env h)
(if found val ;; return val
;; if we find it here on the env stack.
;; otherwise
;; val is a symbol, same as h see if it has a value
(let ((r (gethash val symtab)))
(if (hash-table-p r)
(gethash val r val) ;
val))))))
;; look up the value of e on e's hashtable, key e
;; look up the value of e[10] on e's hashtable, key (10)
(defun msymbol-value (h)
(cond
((atom h) (meval-atom h))
(t (let ((tabentry (gethash (|Head| h) symtab)))
(if tabentry (gethash (cdr h) tabentry h)
h)))))
;; this guy looks on the stack; returns if there. looks on global symtab; returns if there.
;; no loop. works, evaluates "once" if that's what you want.
(defun msymbol-function(h)
;; hm, how much work should we do here?
;; it could be that h is just h, and has no binding of any sort.
;; it returns either a non-function or a (global) SetDelayed list or rules
(setf h (cond
;; if we think we should look on the stack for it, then we do this.
;; if the value is yet another name, what then? Do we use that
;; name or continue looking??
((multiple-value-bind
(val found)
(sfind env h)
(if found val nil))) ;; if the function is found on stack, it is val
;; we go on to the next clause if the function is not found
;; on the stack.
((multiple-value-bind
(val found)
(gethash h symtab)
(if found (return-from msymbol-function (gethash '|SetDelayed| val h))
;; if not found return h
h)))))
h)
;; is this going to have the right scope?
(defun mapply (hraw args expr env);; note that args= (cdr expr)
(let* ((fun nil)
(h (meval-to-function hraw))
(msymq (gethash h symtab))) ; is a mma symbol?
;; there are 2 kinds of applications here.
;; (Function ...) which is just held.
;; (w ...) where w is (Function ...)
;; (format t "~% h=~s hraw=~s args=~s" h hraw args)
(cond ((eql h '|Function|)
(return-from mapply (ucons '|Function| (funfix (cdr expr)))))
((and (consp h)(eql (car h) '|Function|))
;; this next line should grab the attributes of this Function, if any
;; (format t "~%before args to function ~s are ~s, with env=~s" h args env)
;; (setf args (mevalargs (cdddr h) args)) will be done in mappfun
;; (format t "~%after args to function ~s are ~s" h args)
(return-from mapply (mappfun h args expr env))))
;; (format t "~%before args.. ~s are ~s, with env=~s" h args env)
;;get info on evaluating arguments and do it to args
(setf args (mevalargs (|Attributes| h) args))
(cond
;; I don't believe the comment below...
((constantp h)
;; (format t "~%h=~s" h)
h) ;; allows any lisp function, almost, to slip through
;; check for constant values pre-stored
((not (symbolp h)) (setq expr(ucons h args)))
;; oo... this makes lisp function go first. not right??
#+ignore
((and ;(not msymq)
(symbolp h)(fboundp h))
;(format t "~% applying a lisp function ~s to args ~s " h args )
(setq expr (apply h args)))
;;((not msymq)(setq expr (ucons h args)))
;; maybe put in a check for array here? Not now.
;; next check for user-defined function
((consp (setq fun (msymbol-function h)))
;;(setq args (mevalargs h args)) ;; not always ..
;; (format t "~%applying a user function ~s to args ~s" fun args)
(setq expr(rulesetapply h fun args)))
;; next check for built-in LISP function
;; (clearly not something that Mathematica does)
((and ;(not msymq)
(symbolp h)(fboundp h))
;(format t "~% applying a lisp function ~s to args ~s " h args )
(setq expr (apply h args )))
(t ;;(format t "~% eval fell through ~s ~s" h args)
(setq expr(ucons fun args))))
;;(format t "~% mapply result: expr=~s" expr)
expr))
(defun meval-to-function(x) (meval x))
(defvar *evalonce* t) ;; should be t to make quote (etc etc) work
(defun meval (e)
(let ((saved e)(hd nil) (ha nil))
(if(atom e)(return-from meval (meval-atom e)))
(cond ((eql (car e) 'lispapply)
;; (format t "~% lispapply found, fun= ~s, args=~s" (cadr e) (cdr (meval (caddr e))))
(return-from meval (apply (cadr e) (cdr (meval (caddr e)))))))
(if (eq (setf ha (msymbol-value e))e) ;didn't find a value
nil (return-from meval ha)) ; DID find a value.
;; check off other constant expressions that don't evaluate.
;; perhaps Messages?
;;((patternobjectp e) e) .. What about Patterns?
;; (mapply (car foo)(cdr foo) foo env) ==> foo with no conses...
(setf e (cons (meval-to-function (|Head| e))(cdr e)))
;; (return-from meval (mapply (car e) (cdr e) e env)) ))
(setf e (mapply (car e) (cdr e) e env))
;; note the 3rd arg to mapply, just in case you want to
;; return the expression as the result without any change.
;; next step --
;;
;; do we keep evaluating until there is no change???
(setf hd (|Head| e))
(setf ha (|Attributes| hd))
;; (format t" ~%ha=~s hd=~s e=~s" ha hd e)
(cond (*evalonce* e)
((eql hd '|Function|) (funfix (cdr e)) e) ;; compute new body
((and (member '|Listable| ha) (some #'|ListQ| (cdr e)))
;; uh, (h a,b,..(List c d) ..) becomes
;; (List (h a b ..c..) (h a b .. d..) ).
(listify e))
((equal e saved) e)
((eql hd '|Hold|) e)
(t (meval e)))
))
;; Each global object X is associated with a hash table
;; and we can, for each,
;; to get the value, do (gethash X X), (gethash 'rules X) etc.
;; Local bindings hide everything.
;;Do we want to do infinite evaluation?
;;How do we keep single copies of items in memory?
;;set up initial symbol-table entries for built-in stuff
;; should also set attributes
(mapc #'chash built-in-syms)
;; All system-level $-stuff can be initialized and stored this way
(defun globinit(name val)
(chash name); just in case it isn't already there
(setf (gethash name (gethash name symtab)) val))
(globinit '|$Line| 1)
;;(globinit '|False| '|False|)
(globinit '|False| nil) ;; maybe, maybe not
(globinit '|$Showtime| nil)
(globinit '|I| #c(0 1)) ;; imaginary unit I^2 = -1.
;; simple debugging tool: examine contents of symtable entry
; |Attributes| that evaluation routines use. maybe
; - Flat [associative, flatten out nested expressions]
; - Orderless [commutative, put args in order]
; - |Hold|First [don't evaluate first arg yet]
; - |Hold|Rest [only evaluate first arg now]
; - |HoldAll| [don't evaluate any args now]
; - Procedure [procedure to call to do actual evaluation]
; - Default [default value for optional variables]
;;[version 3]?
;; the attribute semantics are probably OK as long as only global properties
;; are being recorded.
;; define ClearAttribute similarly
;; mma does not allow setting of |Attributes| other than
;;Protected, ReadProtected, Locked, Temporary, |Hold|First, |Hold|Rest, |HoldAll|, Flat, Orderless, OneIdentity, |List|able, Constant, Stub, N|Hold|First, N|Hold|Rest, N|HoldAll|, NumericFunction, |Sequence||Hold|, and |HoldAll|Complete. [version 7]
;;bunch of additions, 1/2011 RJF
(defun setattribute(h att &optional (val '|True|)) ;; not in mathematica
(if (typep h 'hash-table) nil (setq h (gethash h symtab)));; now its a ht
(setf (gethash att h) val) ;; in h's hashtable, set the attribute att's value to true
(setf(gethash '|Attributes| h);; also in h's hashtable, set its property of |Attributes| to a list
(adjoin att (gethash '|Attributes| h)))
)
(defun |Default|(h)
(gethash '|Default| (gethash h symtab emptyht) '(|Sequence|)))
(defun |SetAttributes|(hi attlist) ;; this is in Mathematica.
(let ((h (gethash hi symtab))) ;; get the hashtable for the symbol h.
(cond ((atom attlist) ;; just one
(setattribute h attlist))
(t (map nil #'(lambda(r)(setattribute h r))(cdr attlist))
(cons '|List| (gethash '|Attributes| h))
;attlist
))
(|Attributes| hi)))
(defun |Attributes|(h)
(cons '|List| (gethash '|Attributes| (gethash h symtab emptyht ) nil)))
;; more notes
;; Sin[x_]/; x>3-> S[x]
;; parses to
;; (Rule (Condition (Sin (Pattern x (Blank))) (Comparison x Greater 3)) (S x))
;; we don't have evaluation of Block implemented.
;;
;; probably should add evaluation of functions and slots.
;; eg #+1&[4] should return 5.
(defvar *vt* 0) ;;virtual time
(defun timestamp()(incf *vt*))
(defvar size 100)
(defstruct (stack (:print-function stackprinter))
(size 100 :type fixnum) ;if no size is specified, how about 100?
;; ptr points to top of stack. 0<=ptr<size : the index in which to
;; store at the next "push".
(ptr 0 :type fixnum)
;;frameptr points to the bottom of current call-frame
;; a pair that looks like <name of function> <next lower frameptr>
;; -1 <= frameptr < ptr
(frameptr -1 :type fixnum)
(vars (make-array size))
(vals (make-array size))
) ;; alternative, with timestamp
;; do we want 3 parallel stacks??
(defun spush(s var val)
(setf (aref (stack-vars s) (stack-ptr s)) var)
(setf (aref (stack-vals s) (stack-ptr s)) (new-obj val)) ;; changed here
;;could check for overflow here
(incf (stack-ptr s))
s)
(defun sfind(s var)
(let ((loc (position var (stack-vars s):from-end t
:start 0 :end (stack-ptr s)))) ;; finds the last one,
(if loc (values (aref (stack-vals s) loc) loc) ; found: 2nd val is index
(values var loc) ;;2nd value will be nil, first will be var itself
)))
(defun schange (s var val)
(let ((loc (position var (stack-vars s)
:start (1+ (stack-frameptr s)) :end (stack-ptr s))))
(if loc (setf (aref (stack-vals s) loc) val)
(spush s var val) ;; arguable alternative: push the value
)))
#| in this infinite-evaluation model, when a variable
is assigned a value, x=z, then x is given its "own value" of z.
Then z is evaluated, to, say, w^2+5. Next, x is given
a "value" of w^2+5 and a unique timestamp.
Complicating this situation is the fact that x can be stack-allocated or heap
allocated. In each case we can store as the value of x a
structure, call it a nob for named object.
It can also be a funny-var in which case , uh, whatever.
|#
(defstruct nob own val depends (ts :type fixnum))
(defun new-obj(rhs)
(make-nob :own rhs :val (meval rhs) :depends (deplist rhs) :ts (timestamp)))
(defun update-obj(nb)
;; updates a new-obj by re-evaluating it
(setf (nob-val nb) (meval (nob-own nb)))
(setf (nob-ts)(timestamp)))
(defun stalep-obj(nb)
(let ((age (nob-ts nb)))
(some #'(lambda(z)(> z (meval-to-age z))) (nob-depends nb))))
(defun re-meval(nb)
(if (stalep-obj nb)(update-obj nb)))
;; that is
(defun deplist(z) ;; dependency list
;; what are the names of symbols that z depends upon?
;; perhaps we should exclude items that are "protected"?
(let ((res nil))
(labels((dp1(z)(cond ((atom z)
(if(or(constantp z)
(member z res)) nil (push z res)))
(t(map nil #'dp1 z)))))
(dp1 z)
res)))
(defun |Set| (lhs rhs) ;; lhs=rhs
;; the value associated with the lhs will be stored
;; in the symbol table symtab, with the key h,
;; which is either the head of the lhs,
;; or the lhs itself. That is f=45 is stored in the
;; hash table for f, under the indicator "f"
;; and f[0]=7 is stored in the hash table for f, under
;; the indicator (0).
(declare (special symtab funnyvars))
(let ((h nil)(fun nil))
(cond ((symbolp lhs) ;; common case, "x=stuff"
;; 3 possibilities, x is bound on stack or or a funny-var or is global
;; (format t "~%setting symbol ~s" lhs)
(multiple-value-bind (val found)(sfind env lhs)
;; (format t "~%mvb result for symbol ~s is ~s ~s " lhs val found)
(declare (ignore val)) ; previous value irrelevant
(cond (found ;found on stack.
(schange env lhs rhs)) ;;change it there.
((setf fun (gethash lhs funnyvars)) ;one of the vars needing special work
;; (format t "~%~s is in funnyvars"~s)
(funcall fun rhs))
(t ;;global case. Not found on stack
;; (format t "~%symtab is ~s" symtab)
(setf h (gethash lhs symtab)) ;odd. should be there from parser.
;; (format t "~%hashtable for ~s is ~s" lhs h)
(cond((null h)(chash lhs) (setf h (gethash lhs symtab))))
;; set h to the hash table for "x"
(setf (gethash lhs h) (new-obj rhs)))))) ; put value on key "x" in "x" hashtable
;; not not so simple an assignment, e.g., x[i,j]= stuff,
;; we could store in (x i j) just the value and put
;; the timestamp and dependencies on x... too slow??
((consp lhs)
(cond ((eql (|Head| lhs) '|Part|)
;; case of m[[3]]=45
;; maybe also mm[[3,4]]=45.
;;IMPORTANT: deviation from Mma spec. We return WHOLE expression
(setf rhs (uniq(setpart (append (meval (cadr lhs))nil) ;fresh copy
(cddr lhs)
rhs))) )
(t ;; it is an assignment like f[1,2]=10
(setq h (gethash (car lhs) symtab)) ;symtab for x
(cond((null h)(chash (car lhs)) (setf h (gethash (car lhs) symtab))))
;; (format t "~% Set has non-atom lhs ~s" lhs)
;; (format t "~%hashtable for ~s is ~s" (car lhs) h)
(setq lhs (mevalargs (|Attributes|(car lhs))(cdr lhs))) ; evaluate i,j
(setf (gethash lhs h) rhs)) )))
rhs))