;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; ;;;;;;;; ;;;;;; All files in this directory or any subdirectories are ;;;;;;;; ;;;;;; copyright 1997, 1998, 1999, 2000, 2002, 2003. ;;;;;;;; ;;;;;; by Rafael D. Sorkin. All rights reserved. ;;;;;;;; ;;;;;; ;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; bibliotek.macros Time-stamp:<2003-Dec-06 23:19:43 16338.43615> ;: NOTES ; CAUTION Don't invoke herein fcns that are defined in other biblioteks! ; Macros are segregated here because they are needed by many other ; biblioteks, hence are best loaded first. ; Macros specific to elisp are in bibliotek.elisp.coda.el or bibliotek.elisp.el ; ; Macros specific to TCL are in bibliotek.TCL.l or similarly named files ; Advice on compiling biblioteks ; ; In compiling biblioteks from scratch, by far the best policy seems to be to ; LOAD the files FIRST and only THEN COMPILE them. ; If you compile without first loading, the functions and macros seem not to ; know about each other, even about ones occurring earlier in the file. ; Probably this can be overcome by use of `eval-when' (there would be no harm ; in wrapping everything in it, in fact), but experience shows that it's far ; easier and better just to load before compiling. ;: Roster of macros and functions defined herein ;| ;| ===================================================== ;| The csynf family (csynf = clearer-syntax-facilitator) ;| ===================================================== ;| ;| deff (extends `defun' to accept csynf syntax and provide ;| variable localization) ;| ;| csynf + helpers ;| ;| toggle-csynf-debugging (helps in debugging functions defined with `deff') ;| ;| localize-using-name/LUN (makes variables local by creating new symbols ;| for them) ;| replace-using-name (auxiliary function for the previous) ;| ;| ============ ;| Other macros ;| ============ ;| ;| compose/o (composition of functions acting on SINGLE arg) ;| ;| image (a more convenient syntax than `mapcar') ;| ;| ewe (a more convenient syntax than `mapc') ;| ;| kwa (a simple looping macro largely superseded by `loop') ;| ;| the-set-of/set-of ;| ;| setqq (like setq but second arg is also not evalled) ;| ;| arith-to-lisp/atl (Allows the use of normal infix syntax in arithmetic ;| expressions) ;| ;| tcl-or-elisp (to use different code depending on TCL or elisp) ;| ;| compiled-eval (evals after compiling) ;| ;| time-occupied ;| time-evaluation (cmucl version) ;| ;| Time/time (defined elsewhere) ;| ;| ================================================================= ;| Some aliases which are defined elsewhere for elisp (namely in ;| bibliotek.elisp.patch.el or bibliotek.elisp.el or preparations.el) ;| ================================================================= ;| Defun (an alias for defun* in elisp's CL package) ;| Let (an alias for lexical-let in elisp's CL package) ;| ;| Labels (in elisp, it's an alias for flet for now) ;| ;|======================================================================== ;: Package info could go here, see { ~/lisp/bibliotek.TCL.l } for a sample. ;: The macro `setqq' (defmacro setqq (symbol object) " Like setq but *neither* arg is evaluated. Takes only one arg pair" `(setq ,symbol (quote ,object))) ; ; NOTES ; We don't use `set', since in TCL it will act on the GLOBAL ; binding of symbol, whereas we want `setqq' to be like `setq', which acts on ; the local binding. ; There's no point in complicating it to accept arbitrary numbers of pairs ; like setq and setf do (such a version was warehoused) ;: The macro `tcl-or-elisp' (defmacro tcl-or-elisp (tcl-form elisp-form) " The first form if in TCL, the second if in elisp" (declare (ignore elisp-form)) (cond (*TCL* tcl-form) (*elisp* elisp-form))) ; ; The `ignore' declaration stops compiler warning that `elisp-form' not used ;: The macro `compose' (defmacro compose (&rest H) "\ A macro to write more simply the composition of a string of functions acting on a single argument, eg: `(compose sin cos tan sqrt 5)' or, using the convenient alias `o': `(o sin cos tan sqrt 5)'. \ " (assert (< 1 (length H)) nil "Too few arguments to `compose'") (Labels ((inner (H) (if (= 2 (length H)) H (list (car H) (inner(cdr H)))))) (inner H))) (defalias 'o 'compose) ;:---------------------------------------------------------------------- ;: A macro for localizing symbols used within functions (defun replace-using-name (name sym-list vitu) "\ An auxiliary function for `localize-using-name'. Arguments are: name (a string), sym-list (a list of symbols), and vitu. We return vitu unchanged except that occurrences of the elements of sym-list are replaced with uninterned symbols whose names are formed from those of the originals using name. BEWARE In some implementations, the replacement symbols can get interned during reading in compiled code. \ " (declare (optimize (safety 3) (speed 0))) (if (null sym-list) vitu (subst (make-symbol (concatenate 'string "-<" (symbol-name (car sym-list)) ">-@-" name)) (car sym-list) (replace-using-name name (cdr sym-list) vitu)))) (defmacro localize-using-name (--@-{LUN} --@-{LUN} &rest --@-{LUN}) "\ The arguments are: NAME LIST-OF-SYMBOLS FORMS. Replaces the symbols with new, *uninterned* ones whose names are made from the given name, the purpose being to make them effectively local. EXAMPLE: (localize-using-name \"t-close\" (x y j k) FORMS) CAUTION: This replaces ALL instances of the symbol (including quoted ones, since something like 'x is just short for (quote x)). So be sure not to give your local symbols names which collide with ``external'' (or ``special'' or whatever) variables which you want to refer to by name in the function body, or with symbols you want to use in a quoted context (as plist indicators for example). Finally, of course, don't localize symbols which are names of external functions you want to invoke, like `sqrt'. REMARK: The renaming of the symbol is only a precaution, given that it is already effectively localized by being uninterned. However, in some implementations, putatively uninterned symbols can get interned when read in from a compiled file. Hence the extra precaution. \ " (cons 'progn (replace-using-name --@-{LUN} --@-{LUN} --@-{LUN}))) (defalias 'LUN 'localize-using-name) ;:: Notes on above ; `replace-using-name' doesn't really need to be separate from ; `localize-using-name' ; The auxiliary function `replace-using-name' uses a name given to it to ; deterministically construct new symbol names from the old ones, the new name ; being so peculiar that no user could employ it by accident (we hope!). We ; also let the newly created homonymous symbol be uninterned, but ; unfortunately, this doesn't help much with compiled functions in certain ; implementations, since when they are reloaded, the symbols become interned! ; If not for this worry, we really wouldn't have to change the names at all: ; the substitution of uninterned symbols would suffice! ; We do NOT localize the variables used in `replace-using-name' itself, since ; it appears to be unnecessary. If this is wrong then just do it by hand, ; either changing eg "vitu" to "--@-replace-using-name" etc., or ; wrapping the whole thing in a `sublis'.) Symbols to be localized would be: ; name sym-list vitu ; Do other forms of the names look nicer? ; ; --@-t-close (current) ; --%-{t-close} ; --@-{t-close} ;:------------------------------------------------------ ;: The csynf family ; Notes on this family (See ~/lisp/developing/csynf.l for more) ; ; The name csynf stands for "clearer-syntax-facilitator". ; ; `deff' is a macro for incorporating both `csynf' and `localize-using-name' ; into the function definition itself, so they don't have to be invoked ; explicitly. (defun csynf-kweli (H) "\ This function is the guts of the macro `csynf', kept separate from the latter only for legibility. (This separation would not be necessary if we could use `fbind' syntax within `csynf' itself!) \ " (cond ((atom H) H) ((eq (car H) 'quote) H) ((o atom car H) (cons (car H) (o csynf-kweli cdr H))) (t (case (caar H) ((quote) (cons (car H) (o csynf-kweli cdr H))) ((varbind vbind) `((let* ,(csynf-process-vbind-list (cdar H)) ,@(o csynf-kweli cdr H)))) ((fbind) `((Labels (,(csynf-process-fbind-list (cdar H))) ,@(o csynf-kweli cdr H)))) ((macrobind mbind) `((macrolet (,(csynf-process-fbind-list (cdar H))) ,@(o csynf-kweli cdr H)))) (otherwise (cons (o csynf-kweli car H) (o csynf-kweli cdr H))))))) (defun csynf-process-vbind-list (B) (assert (o evenp length B) nil "Bad varbind list") (block nil (if (null B) (return nil)) (setq B (csynf-kweli B)) ; to allow `varbind' etc within varbind (cons (subseq B 0 2) (csynf-process-vbind-list (cddr B))))) (defun csynf-process-fbind-list (B) (block nil (if (null B) (return nil)) (setf (cadr B) (csynf-kweli (cadr B))) (setf (cddr B) (csynf-kweli (cddr B))) B)) ; ; The separate processing of (cadr B) attempts to allow csynf within the ; lambda list, without trouble when `varbind' etc are used as parameters (defmacro csynf (&rest H) "\ A macro whose name means {c}learer{syn}tax{f}acilitator, and which allows you to write, for example (FORMS (vbind x 1 y 2 z 3) FORMS) as an alternative to (FORMS (let* ((x 1) (y 2) (z 3)) FORMS)) This syntax demands fewer parentheses and the vbind ``form'' doesn't need to be wrapped around the forms in its scope. Thus `vbind' (synonym `varbind') offers an alternative to `let*. Similarly, `fbind' and `mbind' (synonym `macrobind') offer alternatives to `labels' and `macrolet' respectively. [However `mbind' is not well checked and might still not be working well.] A ``pseudoform'' like `(varbind x 3)' establishes a binding for `x' which automatically extends until the end of the enclosing form in which it occurs, much like a local declaration in other languages. (In this sense every form acts as a ``block'', as far as csynf is concerned.) USAGE (csynf FORM FORM...FORM) => value of final form EXAMPLES (csynf (varbind x 1 y 2 z y) (+ x y z)) => 5 (csynf (fbind phi (x y) (+ x y)) (phi 3 4)) => 7 Notice in the first example that `varbind' can bind multiple args, and does so serially rather than in parallel. In contrast, `fbind' and `macrobind' can make only a single function or macro binding. | | | CAUTIONS | | | (1) As implemented, csynf syntax is in general incompatible with the special syntax used by `loop' and it can also get into trouble with `symbol-macrolet'. Thus it's best to avoid using `varbind' and friends within either of these. (See also 1:WARNINGS) (2) The symbols `varbind', `fbind', `csynf' etc. should probably be treated as ``reserved words''. Although theoretically valid, using them as names of variables, function-parameters, etc. is courting trouble. (3) Some incompatibility between csynf and backquote is suspected. There may be none, but if there is, this would be a problem for `mbind' because backquote's main use is in conjunction with macro definitions. | COMMENT The reason we make `fbind' use `labels' rather than `flet' is that in TCL, functions defined by `flet' can't be recursive. \ " (cons 'progn (csynf-kweli H))) (defmacro varbind (&rest args) "\ The symbol `varbind' (synonym `vbind') introduces a ``pseudoform'' intended for use with `deff' and `csynf'. If csynf-syntax were built into lisp then this would be a sort of generalized special form replacing `let' (or rather `let*'). As it is, we just make it signal an error, since it should never be used as such (except for debugging purposes). See the documentation of `csynf' for more information. CAUTION Though possible in principle, it is unwise to use `varbind' as the name of a variable, or in any other manner than as part of a pseudoform like `(varbind x 3)' \ " (declare (ignore args)) (error "Error: `varbind' is not a real function or macro in elisp or TCL")) (defmacro fbind (&rest args) "\ The symbol `fbind' introduces a ``pseudoform'' intended for use with `deff' and `csynf'. If csynf-syntax were built into lisp then this would be a sort of generalized special form replacing `flet', or rather `labels'. As it is, we just make it signal an error, since it should never be used as such (except for debugging purposes). See the documentation of `csynf' for more information. CAUTION Though possible in principle, it is unwise to use `fbind' as the name of a variable, or in any other manner than as part of a pseudoform like (fbind foo (x) (+ 3 x)) \ " (declare (ignore args)) (error "Error: `fbind' is not a real function in elisp or TCL")) (defmacro macrobind (&rest args) "\ The symbol `mbind' (synonym `macrobind') introduces a ``pseudoform'' intended for use with `deff' and `csynf'. If csynf-syntax were built into lisp then this would be a sort of generalized special form replacing `macrolet.' As it is, we just make it signal an error, since `mbind' should never be used as such (except for debugging purposes). See the documentation of `csynf' for more information. CAUTION Though possible in principle, it is unwise to use `mbind' as the name of a variable, or in any other manner than as part of a pseudoform like (mbind bar (x)...) \ " (declare (ignore args)) (error "Error: `macrobind' is not a real function in elisp or TCL")) (defalias 'clearer-syntax-block 'csynf) (defalias 'vbind 'varbind) (defalias 'mbind 'macrobind) ;; The macro `deff' (csynf (defmacro deff (&rest H) "\ This is an extension to `defun' to provide both localization and csynf syntax. You define a function as usual except that you can: (a) include a ``pseudoform'' looking like (&localize x y...z) (b) use `varbind', `fbind' and `mbind' within the function definition (c) include -- at top level only -- a pseudoform like (&bind-too u v...w) If you do (a) then the symbols x y...z will automatically be localized by `localize-using-name' (the name being that of the function itself). This applies to any occurrences of these symbols anywhere in the function, including its argument list. If you do (c) then that pseudoform (wherever it may be, as long as it is at top level) will turn into the equivalent of (vbind u nil v nil...). This last is useful mainly for preventing compiler warnings, but it can also be convenient on its own now and then. In case of elisp, `deff' also serves to incorporate the CL extensions to elisp's `defun'. See the documentation of `csynf' for more on `vbind', `fbind' and `mbind'. See the documentation of `localize-using-name' for more on what that macro does, including some cautions. The name ``deff'' stands for ``define-function'' or ``defun-fancy''. " ;---------------------------------------- ; Define auxiliary function for &bind-too ;---------------------------------------- (fbind process-bind-list (B) (cond ((null B) nil) (t (append (list (car B) nil) (process-bind-list (cdr B)))))) ;-------------------------------------- ; Record name of function being defined ;-------------------------------------- (varbind name (o symbol-name car H)) ;--------------------------------------------------------------------------- ; Find the `&localize' pseudoform if there is one, extract the symbols to be ; localized and delete the pseudoform if it was there. ;-------------------------------------------------------------------------- (varbind loc-form (find '&localize H :key 'car-safe) loclist (cdr loc-form)) (if loc-form (setq H (delq loc-form H))) ;-------------------------------------------------- ; Find the `&bind-too' pseudoform if there is one ;-------------------------------------------------- (varbind bind-too-cons (Member '&bind-too H :key (function car-safe)) bind-list nil) ;----------------------------------------------------------------------- ; extract the symbols to be vbound and convert the @ pseudoform to do so ;----------------------------------------------------------------------- (when bind-too-cons (setf bind-list (cdar bind-too-cons) (car bind-too-cons) (cons 'varbind (process-bind-list bind-list)))) ;------------------------------------------------------- ; rebuild the function definition with localized symbols ;------------------------------------------------------- `(localize-using-name ,name ,loclist (csynf (Defun ,@H))))) ;; Nice feature for debugging (defvar *csynf-debug* nil "true when varbind redefined to setq etc") (defvar *csynf-save-fbind* nil "holds original value of fbind") (defvar *csynf-save-varbind* nil "holds original value of varbind") (defun toggle-csynf-debugging () "\ Temporarily bind `varbind'/`vbind' to `setq' and `fbind' to `deff' If this is in effect then *csynf-debug* = true " (interactive) (cond ;----------------------- ;/turn it off if it's on ;----------------------- ((not *csynf-debug*) (setq *csynf-save-varbind* (macro-function 'varbind) *csynf-save-fbind* (macro-function 'fbind)) (defalias 'varbind 'setf) (defalias 'fbind 'deff) (setq *csynf-debug* t)) ;----------------------- ;/turn it on if it's off ;----------------------- (*csynf-debug* (setf (macro-function 'varbind) *csynf-save-varbind* (macro-function 'fbind) *csynf-save-fbind*) (setq *csynf-debug* nil))) ;------------------------------------------------ ;/make sure `vbind' is still aliased to `varbind' ;------------------------------------------------ (defalias 'vbind 'varbind) ;-------- ;/message ;-------- (if *csynf-debug* (message "csynf debugging turned ON") (message "csynf debugging turned OFF"))) ;:---------------------------------------------------------- ;: The macro `image' (LUN "image" (args D D-supplied F F-supplied x) (Defmacro image (&rest args &aux D (D-supplied nil) F (F-supplied nil) (x '$)) "\ Treats an expression F($) as a function of the symbolic argument `$' (or the argument symbol specified) and applies it to each element of a list D, returning the resulting list of values. (If you are applying `F' only for its side effect then use `ewe' instead.) The phrases can be in any order and many different ``keywords'' can be used to introduce them, for example (image on L of (cons $ $)) (image for x in L of (* x x)) (image of (* $ $) on '(1 2 3)) Here is a full list of the `keywords' accepted grouped into lists of synonyms: (on :on in :in domain :domain dom :dom) (of :of expression :expression expr :expr form :form formula :formula) (for :for arg :arg argument :argument parameter :parameter) \ " ;------------------------------------------------------------------------- ;/extract `D' (the domain), `F' (the function), `x' (the dummy arg) ;------------------------------------------------------------------------- (while args (case (car args) ;-------------------------- ;/domain phrase comes first ;-------------------------- ((on :on in :in dom :dom domain :domain) (setq D (cadr args) D-supplied t args (cddr args))) ;---------------------------- ;/function phrase comes first ;---------------------------- ((of :of form :form formula :formula expr :expr expression :expression) (setq F (cadr args) F-supplied t args (cddr args))) ;--------------------------------------- ;/symbol for dummy argument comes first ;--------------------------------------- ((arg :arg argument :argument parameter :parameter for :for) (setq x (cadr args) args (cddr args))) ;-------------------------------------- ;/unrecognizable phrase in calling form ;-------------------------------------- (otherwise (error (tcl-or-elisp "Unknown ``keyword'' given to `image': ~s" "Unknown ``keyword'' given to `image': %s") (car args))))) ;------------------------------------------------ ;/check that both D and F were actually specified ;------------------------------------------------ (unless (and D-supplied F-supplied) (error "must give both domain and formula to `image'")) ;-------------------------------------------------- ;/build the expansion form using `loop' or `mapcar' ;-------------------------------------------------- `(mapcar (lambda (,x) ,F) ,D))) ; ; Currently this is no more or less than an alternative syntax for `mapcar' ;: The macro `ewe' (LUN "ewe" (args D D-supplied F F-supplied x *D) (Defmacro ewe (&rest args &aux D (D-supplied nil) F (F-supplied nil) (x '$)) "\ Treats an expression F($) as a function of the symbolic argument `$' (or the argument symbol specified) and applies it -- FOR ITS SIDE EFFECT -- to each element of a list D. Returns nil. The phrases can be in any order and many different ``keywords'' can be used to introduce them, for example (ewe on L of (fanya $ $)) (ewe of (fanya $ $) on L) (ewe for x in L of (fanya x x)) Here is a full list of the `keywords' accepted, grouped into lists of synonyms: (on :on in :in domain :domain dom :dom) (of :of expression :expression expr :expr form :form formula :formula) (for :for arg :arg argument :argument parameter :parameter) Remark: the name ``ewe'' stands for ``elementwise effect'' " ;------------------------------------------------------------- ;/extract D (the domain), F (the function), x (the dummy arg) ;------------------------------------------------------------- (while args (case (car args) ;-------------------------- ;/domain phrase comes first ;-------------------------- ((on :on in :in dom :dom domain :domain) (setq D (cadr args) D-supplied t args (cddr args))) ;---------------------------- ;/function phrase comes first ;---------------------------- ((of :of form :form formula :formula expr :expr expression :expression) (setq F (cadr args) F-supplied t args (cddr args))) ;--------------------------------------- ;/symbol for dummy argument comes first ;--------------------------------------- ((arg :arg argument :argument parameter :parameter for :for) (setq x (cadr args) args (cddr args))) ;-------------------------------------- ;/unrecognizable phrase in calling form ;-------------------------------------- (otherwise (error (tcl-or-elisp "Unknown ``keyword'' given to `ewe': ~s" "Unknown ``keyword'' given to `ewe': %s") (car args))))) ;------------------------------------------- ;/now check that D and F were both specified ;------------------------------------------- (unless (and D-supplied F-supplied) (error "must give both domain and formula to `ewe'")) ;------------------------------------------------------------------- ;/build the expansion form using either `mapc' or `loop' or `mapcar' ;------------------------------------------------------------------- (case *lisp-type* ((elisp) `(progn (mapcar (lambda (,x) ,F) ,D) nil)) ((cmucl gcl) `(progn (mapc (lambda (,x) ,F) ,D) nil)) (otherwise (error "`ewe' not defined yet for current lisp type"))))) ; ; We are here using `mapc' with cmucl and gcl, and `mapcar' with elisp. ; ; Notice that although `mapc' doesn't accumulate the values, it doesn't of ; itself return nil either (for some reason it returns its second arg ; instead). ;: The macro `kwa' (localize-using-name "kwa" (indx from-key start to-key stop H final) (defmacro kwa (indx from-key start to-key stop &rest H) "\ A macro for simple looping, used in one of these three exemplified ways: (kwa j from 3 to 7 FORMS) (j will be 3 4 5 6 7) (kwa j from 3 upto 7 FORMS) (j will be 3 4 5 6) (kwa j from 3 while TEST FORMS) Synonyms: { from = } { to <= } { upto below < } A difference from `loop' is that here the loop vble will NOT be localized.\ " (assert (memq from-key (list 'from '=))) (assert (symbolp 'indx)) (case to-key ;----------------------- ;/case of inclusive `to' ;----------------------- ((to <=) `(csynf ; need csynf here to make it work! (varbind final ,stop) (setq ,indx ,start) (while (<= ,indx final) ,@H (setq ,indx (1+ ,indx))))) ;----------------------- ;/case of exclusive `to' ;----------------------- ((below upto <) `(csynf (varbind final ,stop) (setq ,indx ,start) (while (< ,indx final) ,@H (setq ,indx (1+ ,indx))))) ;---------------- ;/case of `while' ;---------------- ((while) `(csynf (setq ,indx ,start) (while ,stop ,@H (setq ,indx (1+ ,indx))))) ;--------------------------------------------- ;/signal error if in none of the above 3 cases ;--------------------------------------------- (t (error "Wrong syntax for `kwa': expected `to', `below'/`upto'/`<' or `while'" ))))) ; ; NOTES ; ; In part this macro only duplicates `loop', which exists in CL. One reason ; to keep it, nevertheless, is that it is free of variables like `G6743'. ; Another is that it makes it much easier to declare the type of the loop ; vble. More generally you might not always want latter to be anonymous. ; ; The name is `kwa' rather than `for' because edebug once disliked the latter. ; ; NB: crucial to use the csynf's above for Clisp (not for elisp) ; ; Possible improvement: extend to (kwa j from a to b by c ....) ; where must handle the negative sign of c separately ; (can we make `by c' optional and not mess it all up? we could by changing to ; this format: (kwa (j a b c) ....) ; ; Does having localized `final' using `LUN', mean that `(varbind final ,stop)' ; is not really needed. No! ; ; WARNING It took a L O N G time to define `kwa' in clisp and elisp ;: The macro `arith-to-lisp' (and the functions atl* and awff) (deff awff (phi) "\ Is this the right kind of input for `atl' ? Call such an expression an ``awff'' for ``arithmetically well formed formula''(as opposed to a ``lwff'', meaning a formula in lisp syntax). In the following ``symbol'' means any lisp symbol except `nil' or one of the arithmetic operators {+ - / * ^ **}, ``atom'' means a number or a symbol (which should name a number), and ``operand'' is syntactically a synonym for ``awff''. Then an awff is one of these: * an atom * a fcn call = a list of length 2 or more, first elt being a symbol and the rest being awff's * a formula = a list in which operators alternate with operands, the last elt is an operand, and the first is either an operand or one of the operators + or - REMARK This allows eg `(3 + (choose (4 + 5) 7) - 1)' to be an awff. \ " (fbind operator (x) (if (member x '(+ - / * ^ **)) t nil)) ; (fbind operator-safe (x) (or (not x) (operator x))) ; (fbind a-atom (x) (or (numberp x) (and (symbolp x) (o not operator x)))) ; (fbind fcncall (x) (and (listp x) (> (length x) 1) (and (o symbolp car x) (o not operator car x)) (loop for y in (cdr x) always (awff y)))) ; (fbind formula (x) (and (listp x) (or (o not operator car x) (memq (car x) '(+ -))) (loop for ptr on (reverse x) by #'cddr for wff = (car ptr) for op = (cadr ptr) always (and (awff wff) (operator-safe op))))) ; ;------------------------------------------- ;/is phi an atom, function call, or formula? ;------------------------------------------- (and phi (or (a-atom phi) (fcncall phi) (formula phi)))) (deff atl* (phi) " This does the real work of `atl'" (declare (optimize (safety 3) (speed 0))) ; maximum safety ;-------------------------- ;/function to handle powers ;-------------------------- (fbind handle-{^} (phi) (varbind AA (reverse phi) BB nil) (loop for a in AA do (case (car BB) ((^ **) (pop BB) (push `(expt ,a ,(pop BB)) BB)) (otherwise (push a BB)))) BB) ;---------------------------------- ;/function to handle multiplication ;---------------------------------- (fbind handle-{*} (phi) (varbind AA (reverse phi) BB nil) (loop while AA for a = (pop AA) do (cond ((not(eq a '*)) (push a BB)) (else (varbind factors nil) ; start collecting multiplicands (push (pop BB) factors) (loop for a1 = (pop AA) for a2 = (car AA) do (push a1 factors) unless (eq a2 '*) return nil do (pop AA)) (push (cons '* factors) BB)))) BB) ;---------------------------- ;/function to handle division ;---------------------------- (fbind handle-{/} (phi) (varbind AA (reverse phi) BB nil) (loop while AA for a = (pop AA) do (cond ((not(eq a '/)) (push a BB)) (else (varbind factors nil) ; start collecting multiplicands (push (pop BB) factors) (loop for a1 = (pop AA) for a2 = (car AA) do (push a1 factors) unless (eq a2 '/) return nil do (pop AA)) (push (cons '/ factors) BB)))) BB) ;-------------------------- ;/function to handle "sums" ;-------------------------- (fbind handle-{+-} (phi) ;--------------------------------------------- ;/if neither `+' nor `-' occur then do nothing ;--------------------------------------------- (unless (or (memq '+ phi) (memq '- phi)) (return-from handle-{+-} phi)) ;---------------------------------------------- ;/make sure the first term has an explicit sign ;---------------------------------------------- (unless (memq (car phi) '(+ -)) (push '+ phi)) ;; (setq phi (plist-to-alist phi)) ; convert to alist ;--------------------------------------- ;/collect positive and negative summands ;--------------------------------------- (varbind pos nil neg nil) ; the pos and neg summands (loop for cell in (reverse phi) for x = (cdr cell) do (case (car cell) ((+) (push x pos)) ((-) (push x neg)) (otherwise (error "badly formed sum")))) ;------------------------ ;/rearrange them suitably ;------------------------ (varbind |pos| (length pos)) ;; (varbind |pos| (length pos) |neg| (length neg)) (cond ((> |pos| 1) (if (not neg) `(+ ,@pos) `(- (+ ,@pos) ,@neg))) ;; ((= |pos| 1) (if (not neg) (car pos) `(- ,@pos ,@neg))) ;; ((= |pos| 0) (if (singleton-p neg) `(- ,(car neg)) `(- (+ ,@neg)))))) ; ; ; Very first check is needed so that function calls like (f 3 4 5) will ; survive ; ; (otherwise (error "empty arithmetic additive expression")))))) ; ; this last trap not needed, unreachable ;----------------- ;/body of function ;----------------- (assert phi nil "Empty argument to `arith-to-lisp'") (cond ;---------------------------------------------------- ;/if phi is an atom, return it, otherwise it's a list ;---------------------------------------------------- ((atom phi) phi) (otherwise ;------------------------------------------------------- ;/recursively convert all operands from awff's to lwff's ;------------------------------------------------------- (setq phi (mapcar #'atl* phi)) ;--------------------------------------------------- ;/now phi is a simple list of operators and operands ;--------------------------------------------------- (setq phi (handle-{^} phi)) (setq phi (handle-{*} phi)) (setq phi (handle-{/} phi)) (setq phi (handle-{+-} phi)) ;------------------------------------------------------ ;/return phi, after removing parens if it's a singleton ;------------------------------------------------------ (if (singleton-p phi) (car phi) phi)))) ; ; NOTES ; It might be cleaner to handle the singleton case before all the ; operators instead of after, but since it's working now ,,,, ; ; After ^ is handled, phi will be a list of operands and operators ; other than ^ , and so on for the remaining operators ; ; Basic "move" for `handle-{^}' ; (,,, a) (^ b ,,,) -> (,,,) ((^ a b) ,,,) ; and an example for `handle-{*}' ; (,,, c * a) (* b ,,,) -> (,,,) ((* c a b) ,,,) (defmacro arith-to-lisp (&rest L) "\ Translates a formula in which the arithmetic operations { + - * / ^ } have their usual syntax into standard lisp syntax. The formula should not contain any mixed-in lisp syntax like `(* 3 4 5)'. (And naturally it should not anywhere use `+' or any of the other arithmetic operators as variables.) Embedded function calls like `(log 17)' or even `(log (9 + 8))' are accepted. The operator `**' is recognized as a synonym for `^'. Operator precedence is (^ * / +-), the final +- indicating that the addition and subtraction operators are processed together. We interpret (a ^ b ^ c) as (a ^ (b ^ c)) and (a / b / c) as ((a / b) / c)). For more information, see ~/lisp/developing/arith-to-lisp.l or documentation for the auxiliary function awff. CAUTIONS The expression (e ^ x) will NOT produce (exp x) but rather (expt e x). It might be dangerous to use `atl' or `arith-to-lisp' as a vble name. EXAMPLE of valid use: (atl - 32 + x * (log y)) " (assert (awff L) nil "Not an arithmetically wff: %s" L) (atl* L)) (defalias 'atl 'arith-to-lisp) ;:------------------------------------------------------ ;: Other macros ;:: The macro `the-set-of' (LUN "the-set-of"(x |in| U |st| condition) (defmacro the-set-of (x |in| U |st| condition) "\ SAMPLE USAGE (the-set-of x in L st (evenp x)) BEWARE Don't use `|' or `:' in place of `st' since they have special meanings to tcl (escape character and package indicator). However it's fine to write eg `(the-set-of x within L such-that (evenp x))'. \ " (declare (ignore |in| |st|)) `(LUN "the-set-of" (,x) (loop for ,x in ,U if ,condition collect ,x)))) ; ; Note: the inner `LUN' really is needed (defalias 'set-of 'the-set-of) ;;: elisp and TCL versions of the macro `compiled-eval' (when *elisp* (LUN "compiled-eval" (H) (defmacro compiled-eval (&rest H) " Evals the forms that follow after compiling them" `(funcall (Compile (lambda () ,@ H)))))) (when *tcl* (LUN "compiled-eval" (H) (defmacro compiled-eval (&rest H) "evals the forms that follow after compiling them" `(funcall (compile nil '(lambda () ,@ H)))))) ;;: The macro `time-evaluation' (cmucl version) ;; (the elisp version is in bibliotek.macros.elisp.el) (when *cmucl* (deff time-evaluation (form) "\ Pass form to `time' and return net time occupied in its evaluation. Both the time and the number of bytes consed are stashed in `*mrv*'. \ " (&localize form kwa-kusoma lines line user-time system-time bytes-consed cpu-time) (&bind-too user-time system-time bytes-consed) ;-------------------------- ;/direct the timing output to a string ;-------------------------- (varbind *Trace-Output* (make-string-output-stream)) ;-------------------------------------- ;/collect garbage to give a clean start ;-------------------------------------- ; (gc) ;; omitted now, because `time-occupied' does it. ;-------------------- ;/give form to `time' ;-------------------- (eval `(time ,form)) ;--------------------------------------- ;/convert that string to an input stream ;--------------------------------------- (varbind kwa-kusoma (make-string-input-stream (get-output-stream-string *Trace-Output*))) ;------------------------------------------ ;/read the input stream, parsing into lines (assuming at most 8 lines) ;------------------------------------------ (varbind lines (loop repeat 8 collect (read-line kwa-kusoma nil))) ;-------------------------------- ;/get desired data from each line ;-------------------------------- (loop for line in lines if (search "user" line) do (setq user-time (read-from-string line)) if (search "system" line) do (setq system-time (read-from-string line)) if (search "bytes" line) do (setq bytes-consed (read-from-string line))) ;-------------------------- ;/compute net time taken ;-------------------------- (varbind cpu-time (+ system-time user-time)) (setq *mrv* (list cpu-time bytes-consed)) cpu-time)) ; ; NOTE ; `(o time eval form)' is WRONG way to do it, since ; it puts `eval' inside `time' ;:: The macro time-occupied (defmacro time-occupied (form) "\ The time occupied in evaluating FORM. We collect garbage first to get a clean start. The cmucl version also puts (time bytes consed) --> *mrv* " `(progn (garbage-collect) (time-evaluation (quote ,form)))) ;: End