;; -*- Mode:Common-Lisp;Package:mma; Base:10 -*-o ;; Mathematica(tm)-like evaluator ;; copyright (c) 1990 Richard J. Fateman; pieces by Tak Yan, Derek Lai ;; hacked more 2/2011 to make it work in GCL, not complete. Need to put ;; two-case symbols within | |. ;;BIG CHANGE FROM EARLIER VERSION. Use Mathematica "Own Values" and memoizing ;;subject to review 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: * value, e.g. x * function e.g. list of rules from x[u_]:= ... * extra values like x[0,1]:=45 * Attributes like Listable, Flat, NumericFunction. All stack objects have attribute Temporary. * OwnValues.. This are apparently the values when evaluated at assignment-time value from assignment. That is, x1=x2; x2=x3; x4=x1; x1 has ownvalue x2. x4 has ownvalue x3. * A TimeStamp or counter: the order of the assignment 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. 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. (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 ;; -1 <= frameptr < ptr (frameptr -1 :type fixnum) (vars (make-array size)) (vals (make-array size)) (time (make-array size))) ;; alternative, with timestamp (defun spush(s var val) (setf (aref (stack-vars s) (stack-ptr s)) var) (setf (aref (stack-vals s) (stack-ptr s)) val) (setf (aref (stack-time s) (stack-ptr s)) (timestamp) ;;could check for overflow here (incf (stack-ptr s)) s) (defun sfind(s var) (let ((loc (position var (stack-vars s) :start (1+(stack-frameptr s)) :end (stack-ptr s)))) (if loc (values (aref (stack-vals s) loc) loc ; found: 2nd val is index (aref (stack-time s))); 3rd val is timestamp ) (values var loc) ;;2nd value will be nil, first will be var itself )))