; Acl2 Version 1.5 ; Copyright (C) 1989-94 Computational Logic, Inc. (CLI). All rights reserved. ; Use of this software constitutes agreement with the terms of the Acl2 GENERAL ; PUBLIC SOFTWARE LICENSE. The license agreement is displayed at the beginning ; of the Acl2 file "acl2.lisp". ; This file, axioms.lisp, serves two purposes. First, it describes ; the theory of Acl2 by enumerating the axioms and definitions. ; Second, it implements in Common Lisp those functions of the theory ; which are not already provided in Common Lisp. In some cases, the ; implementation of a function is identical to its axiomatization (cf. ; implies). In other cases, we provide functions whose semantics are ; applicative but whose implementations are decidely ``von ; Neumann-esque''. For example, we implement the array, property ; list, and io primitives with non-applicative techniques. ; This file is read by Common Lisp in two ways. First, we bring Acl2 ; into its initial state with the function boot-strap, which loads ; this file. Second, this file is read and compiled in the ; implementation of Acl2 itself. To support these two readings, we ; use the #+ and #- read macro feature of Common Lisp. While we are ; loading this file in boot-strap, we arrange for *features* to ; contain the symbol :acl2-logic-only; otherwise, *features* does not ; contain :acl2-logic-only. Thus, during boot-strap, forms immediately ; preceded by #+acl2-logic-only are ``seen'', whereas those ; immediately preceded by #-acl2-logic-only are invisible. The ; converse is true when we are compiling and loading the code for ; ACL2. ; If a symbol described in CLTL is axiomatized here, then we give it ; exactly the same semantics as it has in CLTL, under restrictions for ; which we check. (Actually, this is currently a lie about DEFUN, ; DEFMACRO, and PROGN, but we will provide someday a check that that ; those are only used in files in ways such that their Acl2 and Common ; Lisp meanings are prefectly consistent.) Thus, when we talk about ; +, we really mean the Common Lisp +. However, our + does not handle ; floating point numbers, so there is a guard on + that checks that ; its args are rations. The symbols in the list ; acl2::*common-lisp-symbols-from-main-lisp-package* are the symbols ; that we take as having a meaning in Common Lisp. If a user wishes ; access to these in a package, then he can use the permanent value of ; the global *common-lisp-symbols-from-main-lisp-package* as an import ; list for defpkg. ; If we use a symbol that has a $ suffix, it is a symbol we have ; defined with a meaning that it is similar to the Common Lisp symbol ; without the $ suffix, but different in some way, e.g. princ$ takes a ; state arg and returns a state. (in-package "ACL2") ; Leave the following as the second form in axioms.lisp. It is read ; by acl2.lisp. Leave the acl2:: prefix there, too. ; This list is, at the time of this writing, the list of externals (minus ; *break-on-warnings*, compiler-let, and int-char) for Franz and Lucid and a ; subset of the externals for AKCL, minus *modules*, char-bit, char-bits, ; char-bits-limit, char-control-bit, char-font, char-font-limit, ; char-hyper-bit, char-meta-bit, char-super-bit, common, commonp, make-char, ; provide, require, set-char-bit, string-char, and string-char-p; we have ; deleted these last because they are flushed in CLTL2. The three symbols ; deleted from Franz' and Lucid's externals were deleted in support of ; MacIntosh Common Lisp after noting that these three symbols are due to be ; deleted from CLTL2. Probably many more need to be flushed, but this will be ; caught by the export check in acl2.lisp. (acl2::defconst acl2::*common-lisp-symbols-from-main-lisp-package* '( &allow-other-keys &aux &body &environment &key &optional &rest &whole * ** *** *applyhook* *debug-io* *default-pathname-defaults* *error-output* *evalhook* *features* *load-verbose* *macroexpand-hook* *package* *print-array* *print-base* *print-case* *print-circle* *print-escape* *print-gensym* *print-length* *print-level* *print-pretty* *print-radix* *query-io* *random-state* *read-base* *read-default-float-format* *read-suppress* *readtable* *standard-input* *standard-output* *terminal-io* *trace-output* + ++ +++ - / // /// /= 1+ 1- < <= = > >= abs acons acos acosh adjoin adjust-array adjustable-array-p alpha-char-p alphanumericp and append apply applyhook apropos apropos-list aref array array-dimension array-dimension-limit array-dimensions array-element-type array-has-fill-pointer-p array-in-bounds-p array-rank array-rank-limit array-row-major-index array-total-size array-total-size-limit arrayp ash asin asinh assert assoc assoc-if assoc-if-not atan atanh atom bignum bit bit-and bit-andc1 bit-andc2 bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 bit-orc2 bit-vector bit-vector-p bit-xor block boole boole-1 boole-2 boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor both-case-p boundp break butlast byte byte-position byte-size caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call-arguments-limit car case catch ccase cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling cerror char char-code char-code-limit char-downcase char-equal char-greaterp char-int char-lessp char-name char-not-equal char-not-greaterp char-not-lessp char-upcase char/= char< char<= char= char> char>= character characterp check-type cis clear-input clear-output close clrhash code-char coerce compilation-speed compile compile-file compiled-function compiled-function-p complex complexp concatenate cond conjugate cons consp constantp copy-alist copy-list copy-readtable copy-seq copy-symbol copy-tree cos cosh count count-if count-if-not ctypecase decf declaration declare decode-float decode-universal-time defconstant define-modify-macro define-setf-method defmacro defparameter defsetf defstruct deftype defun defvar delete delete-duplicates delete-file delete-if delete-if-not denominator deposit-field describe digit-char digit-char-p directory directory-namestring disassemble do do* do-all-symbols do-external-symbols do-symbols documentation dolist dotimes double-float double-float-epsilon double-float-negative-epsilon dpb dribble ecase ed eighth elt encode-universal-time endp enough-namestring eq eql equal equalp error etypecase eval eval-when evalhook evenp every exp export expt fboundp fceiling ffloor fifth file-author file-length file-namestring file-position file-write-date fill fill-pointer find find-all-symbols find-if find-if-not find-package find-symbol finish-output first fixnum flet float float-digits float-precision float-radix float-sign floatp floor fmakunbound force-output format fourth fresh-line fround ftruncate ftype funcall function functionp gcd gensym gentemp get get-decoded-time get-dispatch-macro-character get-internal-real-time get-internal-run-time get-macro-character get-output-stream-string get-properties get-setf-method get-setf-method-multiple-value get-universal-time getf gethash go graphic-char-p hash-table hash-table-count hash-table-p host-namestring identity if ignore imagpart import in-package incf inline input-stream-p inspect integer integer-decode-float integer-length integerp intern internal-time-units-per-second intersection isqrt keyword keywordp labels lambda lambda-list-keywords lambda-parameters-limit last lcm ldb ldb-test ldiff least-negative-double-float least-negative-long-float least-negative-short-float least-negative-single-float least-positive-double-float least-positive-long-float least-positive-short-float least-positive-single-float length let let* lisp-implementation-type lisp-implementation-version list list* list-all-packages list-length listen listp load locally log logand logandc1 logandc2 logbitp logcount logeqv logior lognand lognor lognot logorc1 logorc2 logtest logxor long-float long-float-epsilon long-float-negative-epsilon long-site-name loop lower-case-p machine-instance machine-type machine-version macro-function macroexpand macroexpand-1 macrolet make-array make-broadcast-stream make-concatenated-stream make-dispatch-macro-character make-echo-stream make-hash-table make-list make-package make-pathname make-random-state make-sequence make-string make-string-input-stream make-string-output-stream make-symbol make-synonym-stream make-two-way-stream makunbound map mapc mapcan mapcar mapcon maphash mapl maplist mask-field max member member-if member-if-not merge merge-pathnames min minusp mismatch mod most-negative-double-float most-negative-fixnum most-negative-long-float most-negative-short-float most-negative-single-float most-positive-double-float most-positive-fixnum most-positive-long-float most-positive-short-float most-positive-single-float multiple-value-bind multiple-value-call multiple-value-list multiple-value-prog1 multiple-value-setq multiple-values-limit name-char namestring nbutlast nconc nil nintersection ninth not notany notevery notinline nreconc nreverse nset-difference nset-exclusive-or nstring-capitalize nstring-downcase nstring-upcase nsublis nsubst nsubst-if nsubst-if-not nsubstitute nsubstitute-if nsubstitute-if-not nth nthcdr null number numberp numerator nunion oddp open optimize or otherwise output-stream-p package package-name package-nicknames package-shadowing-symbols package-use-list package-used-by-list packagep pairlis parse-integer parse-namestring pathname pathname-device pathname-directory pathname-host pathname-name pathname-type pathname-version pathnamep peek-char phase pi plusp pop position position-if position-if-not pprint prin1 prin1-to-string princ princ-to-string print probe-file proclaim prog prog* prog1 prog2 progn progv psetf psetq push pushnew quote random random-state random-state-p rassoc rassoc-if rassoc-if-not ratio rational rationalize rationalp read read-byte read-char read-char-no-hang read-delimited-list read-from-string read-line read-preserving-whitespace readtable readtablep realpart reduce rem remf remhash remove remove-duplicates remove-if remove-if-not remprop rename-file rename-package replace rest return return-from revappend reverse room rotatef round rplaca rplacd safety satisfies sbit scale-float schar search second sequence set set-difference set-dispatch-macro-character set-exclusive-or set-macro-character set-syntax-from-char setf setq seventh shadow shadowing-import shiftf short-float short-float-epsilon short-float-negative-epsilon short-site-name signed-byte signum simple-array simple-bit-vector simple-bit-vector-p simple-string simple-string-p simple-vector simple-vector-p sin single-float single-float-epsilon single-float-negative-epsilon sinh sixth sleep software-type software-version some sort space special special-form-p speed sqrt stable-sort standard-char standard-char-p step stream stream-element-type streamp string string-capitalize string-downcase string-equal string-greaterp string-left-trim string-lessp string-not-equal string-not-greaterp string-not-lessp string-right-trim string-trim string-upcase string/= string< string<= string= string> string>= stringp structure sublis subseq subsetp subst subst-if subst-if-not substitute substitute-if substitute-if-not subtypep svref sxhash symbol symbol-function symbol-name symbol-package symbol-plist symbol-value symbolp t tagbody tailp tan tanh tenth terpri the third throw time trace tree-equal truename truncate type type-of typecase typep unexport unintern union unless unread-char unsigned-byte untrace unuse-package unwind-protect upper-case-p use-package user-homedir-pathname values values-list variable vector vector-pop vector-push vector-push-extend vectorp warn when with-input-from-string with-open-file with-open-stream with-output-to-string write write-byte write-char write-line write-string write-to-string y-or-n-p yes-or-no-p zerop) "*common-lisp-symbols-from-main-lisp-package* is a subset of the Common Lisp symbols that are are exported by the main Lisp package. These are the symbols that we import into the package ACL2.") ; Acl2 Version 1.5 ; We put the version number on the line above just to remind ourselves ; to bump the following variable, acl2-version, which gets printed out ; with the check-sum info. ; Leave this here. It is read when loading acl2.lisp. This constant ; should be a string containing at least one `.'. The function ; save-acl2-in-akcl in akcl-init.lisp suggests that the user see :doc ; notexxx, where xxx is the substring appearing after the first `.'. (acl2::defconst acl2::*acl2-version* "Acl2 Version 1.5") ; Leave this here. It is read when loading acl2.lisp. (acl2::defconst acl2::*acl2-files* '( "axioms" "basis" "translate" "type-set-a" "type-set-b" "rewrite" "simplify" "other-processes" "induct" "prove" "history-management" "defuns" "proof-checker-a" "defthm" "other-events" "ld" "proof-checker-pkg" "proof-checker-b" "tutorial" "interface-raw" "defpkgs" ) "*acl2-files* is the list of all the files necessary to build Acl2 from scratch.") #-acl2-logic-only (progn (defconstant *the-live-state* 'acl2_invisible::|The Live State Itself| " The value of the constant *the-live-state* is actually just a symbol, but that symbol is the unique representative of the one single active, global, real-time state of Acl2, which is represented both in real-time (e.g., characters not yet typed) and also rather efficiently, using typical von Neumann storage techniques. Functions that wish to access the global state must have received *the-live-state* as an arg. Functions that modify this global state must receive it as an arg and return it.") ; The following SPECIAL VARIABLE, *wormholep*, when non-nil, means that we ; are within a wormhole and are obliged to undo every change visited upon ; *the-live-state*. Clearly, we can undo some of them, e.g., f-put-globals, by ; remembering the first time we make a change to some component. But other ; changes, e.g., printing to a file, we can't undo and so must simply disallow. ; This feature is implemented so that we can permit the "wormhole window" to ; manipulate a "copy" of state without changing it. The story is that wormhole, ; which does not take state as an arg and which always returns nil, is ; "actually" implemented by calling the familiar LD on a near image of the ; current state. That near image is like the current state except that certain ; state globals have been set for wormhole. In addition, we assume that the ; physical map between Acl2 channels and the outside world has been altered so ; that *standard-co*, *standard-ci*, and *standard-oi* now actually interact ; with the "wormhole window" streams. Thus, even when *wormholep* is non-nil, we ; can allow i/o to those standard channels because it causes no change to the ; streams normally identified with those channels. If, while *wormholep* is ; non-nil we are asked to make a change that would undoably alter the state, we ; print a soft-looking error message and abort. If the requested change can be ; undone, we make the change after remembering enough to undo it. When we exit ; the wormhole we undo the changes. (defparameter *wormholep* nil) ; Below we define the function that generates the error message when ; non-undoable state changes are attempted within wormholes. It throws ; to a tag that is set up within LP. We do all that later. Right now ; we just define the error handler so we can code the primitives. ;;; As a temporary hack for the toothbrush, I've redefined wormhole-er ;;; so that it doesn't call fmt. (defun wormhole-er (fn args) (cond ((not (fboundp 'fmt)) (if args (format t "It is not possible to apply ~s to ~s in the current ~ context because we are in a wormhole state." fn args) (format t "It is not possible to apply ~s in the current context ~ because we are in a wormhole state." fn))) (t (error-fmt nil 'wormhole "It is not possible to apply ~p0~#1~[~/ to ~&2~] in the current ~ context because we are in a wormhole state." (list (cons #\0 fn) (cons #\1 (if args 1 0)) (cons #\2 args)) *the-live-state*))) (throw 'local-top-level :wormhole-er)) ; The following parameter is where we will accumulate changes to ; state components that we will undo. (defparameter *wormhole-cleanup-form* nil) ; The value of *wormhole-cleanup-form* is a lisp (but not Acl2) form that will ; be executed to cleanup the live state. This form is built up incrementally ; by certain state changing primitives (e.g., f-put-global) so as to enable us ; to "undo" the effects of those primitives. We store this undo information as ; an executable form (rather than, say, a list of "undo tuples") because of the ; interaction between this mechanism and our acl2-unwind-protect mechanism. In ; particular, it will just happen to be the case that the ; *wormhole-cleanup-form* is always on the unwind protection stack (a true lisp ; global variable) so that if an abort happens while executing in a wormhole ; and we get ripped all the way out because of perfectly timed aborts, the undo ; cleanup form(s) will be at their proper places on the stack of cleanup forms ; and it will just look certain acl2-unwind-protects were interrupted. See the ; discussion in and around LD-FN. The value of *wormhole-cleanup-form* is ; (PROGN save-globals undo-form1 ... undo-formk). The individual undo-formi ; are created and added to the *wormhole-cleanup-form* by push-wormhole-undo- ; formi, below. The initial value of the cleanup form is (PROGN save-globals) ; and new formis are added immediately after save-globals, making the final ; form a stack with save-globals always on top and the formi succeeding it in ; reverse order of their storage. The save-globals form will save into a lisp ; special the final values of the global variables that are available only in ; the wormhole. ; We introduce a CLTL structure for the sole purpose of preventing the ; accidental printing of huge objects like the world. If, in raw lisp, you ; write (make-cloaking-device :hint "world" :obj (w *the-live-state*)) then you ; get an object, x, that CLTL will print as and from which the ; actual world can be recovered via (cloaking-device-obj x). (defstruct (cloaking-device (:print-function (lambda (x stream k) (declare (ignore k)) (format stream "" (cloaking-device-hint x))))) hint obj) #| (defun cloaked-set-w! (x state) ; We invented this function, which is merely set-w! but takes a cloaked world, ; just so we can print the *acl2-unwind-protect-stack* during debugging without ; getting the world printed. (set-w! (cloaking-device-obj x) state)) |# (defun cloaked-set-w! (x state) (declare (ignore x state)) (error "CLOAKED-SET-W! has been on the toothbrush. Presumably that is because it was called by PUSH-WORMHOLE-UNDO-FORMI with the special variable *wormholep* set to a non-nil value.~%")) (defun push-wormhole-undo-formi (op arg1 arg2) ; When a primitive state changing function is called while *wormholep* is ; non-nil it actually carries out the change (in many cases) but saves some ; undo information on the special *wormhole-cleanup-form*. The value of that ; special is (PROGN save-globals form1 ... formk). In response to this call we ; will add a new form, say form0, and will destructively modify ; *wormhole-cleanup-form* so that it becomes (PROGN save-globals form0 form1 ... ; formk). ; We modify *wormhole-cleanup-form* destructively because it shares structure with ; the *acl2-unwind-protect-stack* as described above. ; The convention is that the primitive state changer calls this function before ; making any change. It passes us the essential information about the ; operation that must be performed to undo what it is about to do. Thus, if we ; store a new value for a global var, v, whose old value was x, then op will be ; 'put-global, arg1 will be v, and arg2 will be x. The formi we create will be ; (put-global 'v 'x *the-live-state*) and when that is executed it will undo ; the primitive state change. Note that we do not know what the primitive ; actually was, e.g., it might have been a put-global but it might also have ; been a makunbound-global. The point is that the 'put-global in our note is ; the operation that must be done at undo-time, not the operation that we are ; undoing. ; Furthermore, we need not save undo information after the first time ; we smash v. So we don't necessarily store a formi. But to implement this we ; have to know every possible formi and what its effects are. That is why we ; insist that this function (rather than our callers) create the forms. ; To think about the avoidance of formi saving, consider the fact that the ; cleanup form, being a PROGN, will be executed sequentially -- -- undoing the ; state changes in the reverse order of their original execution. Imagine that ; we in fact added a new formi at the front of the PROGN for each state change. ; Now think about it: if later on down the PROGN there is a form that will ; overwrite the effects of the form we are about to add, then there is no need ; to add it. In particular, the result of evaluating all the forms is the same ; whether we add the redundant one or not. (cond ((null *wormhole-cleanup-form*) (interface-er "push-wormhole-undo-formi was called with an empty ~ *wormhole-cleanup-form*. Supposedly, push-wormhole-undo-formi is only ~ called when *wormholep* is non-nil and, supposedly, when ~ *wormholep* is non-nil, the *wormhole-cleanup-form* is too."))) (let ((qarg1 (list 'quote arg1))) (case op (put-global ; So we want to push (put-global 'arg1 'arg2 state). But if there is already a ; form that will set arg1 or one that unbinds arg1, there is no point. (or (assoc-eq-equal 'put-global qarg1 (cddr *wormhole-cleanup-form*)) (assoc-eq-equal 'makunbound-global qarg1 (cddr *wormhole-cleanup-form*)) (and (eq arg1 'current-acl2-world) (assoc-eq 'cloaked-set-w! (cddr *wormhole-cleanup-form*))) (setf (cddr *wormhole-cleanup-form*) (cons `(put-global ,qarg1 (quote ,arg2) *the-live-state*) (cddr *wormhole-cleanup-form*))))) (makunbound-global ; We want to push (makunbound-global 'arg1 state). But if there is already ; a form that will make arg1 unbound or if there is a form that will ; give it a binding, this is redundant. (or (assoc-eq-equal 'put-global qarg1 (cddr *wormhole-cleanup-form*)) (assoc-eq-equal 'makunbound-global qarg1 (cddr *wormhole-cleanup-form*)) (and (eq arg1 'current-acl2-world) (assoc-eq 'cloaked-set-w! (cddr *wormhole-cleanup-form*))) (setf (cddr *wormhole-cleanup-form*) (cons `(makunbound-global ,qarg1 *the-live-state*) (cddr *wormhole-cleanup-form*))))) (cloaked-set-w! (or (assoc-eq 'cloaked-set-w! (cddr *wormhole-cleanup-form*)) (setf (cddr *wormhole-cleanup-form*) (cons `(cloaked-set-w! ,(make-cloaking-device :hint "world" :obj arg1) *the-live-state*) (cddr *wormhole-cleanup-form*))))) (otherwise (interface-er "Unrecognized op in push-wormhole-undo-formi, ~p0." op))))) ; The following symbol is the property under which we store Common ; Lisp streams on the property lists of channels. (defconstant *open-input-channel-key* 'acl2_invisible::|Open Input Channel Key|) ; The following symbol is the property under which we store the types ; of Common Lisp streams on the property lists of channels. (defconstant *open-input-channel-type-key* 'acl2_invisible::|Open Input Channel Type Key|) (defconstant *open-output-channel-key* 'acl2_invisible::|Open Output Channel Key|) (defconstant *open-output-channel-type-key* 'acl2_invisible::|Open Output Channel Type Key|) (defconstant *non-existent-stream* 'acl2_invisible::|A Non-Existent Stream|) (defmacro live-state-p (x) (list 'eq x '*the-live-state*)) ; We get ready to handle errors in such a way that they return to the ; top level logic loop if we are under it. (defun interface-er (&rest args) ; This function can conceivably be called before ALC2 has been fully ; compiled and loaded, so we check whether the usual error handler is ; around. (cond ((macro-function 'er) (eval `(let ((state *the-live-state*)) (er soft 'acl2-interface ,@(let (ans) (dolist (a args) (push (list 'quote a) ans)) (reverse ans))) (error "Acl2 Halted")))) (t (error "Acl2 error: ~a." args)))) ; We provide here ``raw'' implementations of basic functions that we ; ``wish'' were already in Common Lisp, to support primitives of the ; Acl2 logic. ; Some of the Common Lisp arithmetic primitives are n-ary functions. ; However, Acl2 supports only functions of fixed arity, to keep the ; logic simple. But in practice we find we want to use the n-ary ; arithmetic symbols ourselves. So in the logic we have binary-+ as ; the primitive binary addition function symbol, but we also have the ; macro +, which expands into a suitable number of uses of binary-+. ; Similarly for *, -, and /. (The Acl2 user cannot invoke ; symbol-function, fboundp, macrofunction or macroexpand, so it is no ; concern to the user whether we implement + as a macro or a ; function.) (defun binary-+ (x y) (+ x y)) (defun binary-* (x y) (* x y)) (defun unary-- (x) (- x)) (defun unary-/ (x) (/ x)) ; Below we define our top-level events as seen by the Common Lisp ; compiler. For example, (defuns a b c) expands into a progn of defun ; forms, (defthm ...) is a no-op, etc. (defparameter *in-recover-world-flg* nil) ;;; A toothbrush state is one in which full initialization has not ;;; been done. (defun toothbrush-p (state) (not (getprop 'event-number-baseline 'global-value nil 'current-acl2-world (w state)))) ;;; The following function is defined in basis.lisp, but it's handy to ;;; have here for the toothbrush. (defun global-set (var val wrld) (putprop var 'global-value val wrld)) (defmacro defpkg (name imports &optional doc) (declare (ignore doc)) (sublis (list (cons 'name name) (cons 'imports imports)) '(progn (eval-when (compile) (error "~%Never put a DEFPKG form in a file to be compiled.")) (cond ;;; The following is in support of the toothbrush, in particular when ;;; evaluating a portcullis for an include-book. ((assoc-eq name (getprop 'known-package-alist 'global-value nil 'current-acl2-world (w *the-live-state*))) nil) (t (cond ((and (not *in-recover-world-flg*) (not (getprop 'boot-strap-flg 'global-value nil 'current-acl2-world (w *the-live-state*)))) (let ((p (find-package name))) (cond (p (do-symbols (sym p) (unintern sym p))) (t (make-package name :use nil)))) (let ((g (concatenate 'string acl2::*global-package-prefix* name))) (let ((p (find-package g))) (cond (p (do-symbols (sym p) (makunbound sym))) (t (make-package g :use nil))))))) (import imports (find-package name)) ;;; More support for the toothbrush.... (cond ((toothbrush-p *the-live-state*) (f-put-global 'current-acl2-world (global-set 'known-package-alist (cons (cons name imports) (known-package-alist *the-live-state*)) (w *the-live-state*)) *the-live-state*))) name))))) (defmacro defuns (&rest lst) `(progn ,@(mapcar #'(lambda (x) `(defun ,@x)) lst))) (defmacro defthm (&rest args) (declare (ignore args)) nil) (defmacro defaxiom (&rest args) (declare (ignore args)) nil) (defmacro skip-proofs (arg) arg) (defmacro deflabel (&rest args) (declare (ignore args)) nil) (defmacro deftheory (&rest args) (declare (ignore args)) nil) (defmacro verify-termination (&rest args) (declare (ignore args)) nil) (defmacro verify-guards (&rest args) (declare (ignore args)) nil) (defmacro in-theory (&rest args) (declare (ignore args)) nil) (defmacro table (&rest args) ; Note: The decision to make table a no-op in compiled files was not ; taken lightly. But table, like defthm, has no effect on the logic. ; Indeed, like defthm, table merely modifies the world and if it is ; permitted in compiled code to ignore defthm's effects on the world ; then so too the effects of table. (declare (ignore args)) nil) (defmacro encapsulate (signatures &rest lst) ; The code we generate for the constrained functions in signatures is ; the same as executed in extend-world1 when we introduce an undefined ; function. `(progn ,@(mapcar (function (lambda (sig) `(defun ,(car sig) ,(cadr sig) (declare (ignore ,@(cadr sig))) (throw 'ev-fncall-apply 'ev-fncall-null-body-er)))) signatures) ,@lst)) ;; *connected-book-directory* and include-book have been moved to the end for ;; the toothbrush. ; Include-book is the only event that is sensitive to ; *connected-book-directory*. The variable is virtually always to have the ; value of (@ connected-book-directory). The *connected-book-directory* is ; always nil at the top of the system. This means we should grab the value in ; the state, which is generally "" but may be odd if the user assigned to it. ; Thereafter (in recursive include-books) it is bound to the same value that ; include-book sets connected-book-directory. (defmacro local (x) (declare (ignore x)) nil) ; Although defuns provides us conceptually with the right function for ; packaging together mutually recursive functions, we never use it ; because it hides things from standard Lisp editor indexing programs ; such as etags. Instead, we use mutual-recursion. (defmacro mutual-recursion (&rest lst) (cons 'progn lst)) ; DECLARATIONS ; We use XARGS in DECLARE forms. By making this proclamation, we ; suppress compiler warnings. (proclaim '(declaration xargs)) ) ; STANDARD CHANNELS (deflabel miscellaneous :doc ":Doc-Section Miscellaneous A Miscellany of Documented Functions And Concepts (often cited in more accessible documentation)~/~/ Perhaps as the system matures this section will become more structured.~/") (defconst *standard-co* 'acl2-output-channel::standard-character-output-0 ":Doc-Section Miscellaneous the Acl2 analogue of CLTL's *STANDARD-OUTPUT*~/ The value of the Acl2 constant *standard-co* is an open character output channel that is synonymous to Common Lisp's *STANDARD-OUTPUT*.~/ Acl2 character output to *standard-co* will go to the stream named by Common Lisp's *STANDARD-OUTPUT*. That is, by changing the setting of *STANDARD-OUTPUT* in raw Common Lisp you can change the actual destination of Acl2 output on the channel named by *standard-co*. Observe that this happens without changing the logical value of *standard-co* (which is some channel symbol). Changing the setting of *STANDARD-OUTPUT* in raw Common Lisp essentially just changes the map that relates Acl2 to the physical world of terminals, files, etc. To see the value of this observation, consider the following. Suppose you write an Acl2 function which does character output to the constant channel *standard-co*. During testing you see that the output actually goes to your terminal. Can you use the function to output to a file? Yes, if you are willing to do a little work in raw Common Lisp: open a stream to the file in question, set *STANDARD-OUTPUT* to that stream, call your Acl2 function, and then close the stream and restore *STANDARD-OUTPUT* to its nominal value. Similar observations can be made about the two Acl2 input channels, *standard-oi* and *standard-ci*, which are analogues of *STANDARD-INPUT*. Another reason you might have for wanting to change the actual streams associated with *standard-oi* and *standard-co* is to drive the Acl2 top-level loop, LD, on alternative input and output streams. This end can be accomplished easily within Acl2 by either calling LD on the desired channels or file names or by resetting the Acl2 state global variables 'standard-oi and 'standard-co which are used by LD. See :DOC standard-oi and :DOC standard-co.") (defconst *standard-oi* 'acl2-input-channel::standard-object-input-0 ":Doc-Section Miscellaneous an Acl2 object-based analogue of CLTL's *STANDARD-INPUT*~/ The value of the Acl2 constant *standard-oi* is an open object input channel that is synonymous to Common Lisp's *STANDARD-INPUT*.~/ Acl2 object input from *standard-oi* is actually obtained by reading from the stream named by Common Lisp's *STANDARD-INPUT*. That is, by changing the setting of *STANDARD-INPUT* in raw Common Lisp you can change the source from which Acl2 reads on the channel *standard-oi*. See the discussion in :DOC *standard-co*.") (defconst *standard-ci* 'acl2-input-channel::standard-character-input-0 ":Doc-Section Miscellaneous an Acl2 character-based analogue of CLTL's *STANDARD-INPUT*~/ The value of the Acl2 constant *standard-ci* is an open character input channel that is synonymous to Common Lisp's *STANDARD-INPUT*.~/ Acl2 character input from *standard-ci* is actually obtained by reading characters from the stream named by Common Lisp's *STANDARD-INPUT*. That is, by changing the setting of *STANDARD-INPUT* in raw Common Lisp you can change the source from which Acl2 reads on the channel *standard-ci*. See the discussion in :DOC *standard-co*.") ; IF and EQUAL ; Convention: when a term t is used as a formula it means ; (not (equal t nil)) ; The following four axioms define if and equal but are not expressed ; in the Acl2 language. ; (if NIL y z) = z ; x/=NIL -> (if x y z) = y ; (equal x x) = T ; x/=y -> (equal x y) = NIL ; LOGIC #+acl2-logic-only (defconst nil 'nil " NIL, a symbol, represents in Common Lisp both the false truth value and the empty list.") #+acl2-logic-only (defconst t 't "T, a symbol, represents the true truth value in Common Lisp.") (defun implies (p q) " IMPLIES is the Acl2 implication function. (implies P Q) means that either P is false or Q is true." (declare (xargs :color :gold)) (if p (if q t nil) t)) (defun iff (p q) "IFF is the Acl2 biconditional, ``if and only if''." (if p (if q t nil) (if q nil t))) #+acl2-logic-only (defun not (p) " NOT is the Common Lisp negation function. The negation of NIL is T and the negation of anything else is NIL." (declare (xargs :color :gold)) (if p nil t)) (defun hide (x) x) (defun e0-ord-< (x y) ":Doc-Section Miscellaneous the well-founded less-than relation on ordinals up to epsilon-0~/ If x and y are both E0-ORDINALPs (see :DOC e0-ordinalp) then (E0-ORD-< x y) is true iff x is strictly less than y. E0-ORD-< is well-founded on the E0-ORDINALPs. When x and y are both nonnegative integers, E0-ORD-< is just the familiar < relation.~/ E0-ORD-< plays a key role in the formal underpinnings of the Acl2 logic. In order for a recursive definition to be admissible it must be proved to ``terminate.'' By that we mean that the arguments to the function ``get smaller'' as the function recurses. Without loss of generality, suppose the definition in question introduces the function f, with one formal parameter x (which might be a list of objects). Then we require that there exist a measure expression, (m x), that always produces an E0-ORDINALP. Furthermore, consider any recursive call, (f (d x)), in the body of the definition. Let hyps be the conjunction terms (each of which is either the test of an IF in the body or else the negation of such a test) describing the path through the body to the recursive call in question. Then it must be a theorem that (IMPLIES hyps (E0-ORD-< (m (d x)) (m x))). When we say E0-ORD-< is ``well-founded'' on the e0-ordinalps we mean that there is no infinite sequence of e0-ordinalps such that each is smaller than its predecessor in the sequence. Thus, the theorems that must be proved about f when it is introduced establish that it cannot recur forever because each time a recursive call is taken (m x) gets smaller. From this, and the syntactic restrictions on definitions, it can be shown (as on page 44 in ``A Computational Logic'', Boyer and Moore, Academic Press, 1979) that there exists a function satisfying the definition; intuitively, the value assigned to any given x by the alleged function is that computed by a sufficiently large machine. Hence, the logic is consistent if the axiom defining f is added. See :DOC e0-ordinalp for a discussion of the ordinals and how to compare two ordinals." (if (consp x) (if (consp y) (if (e0-ord-< (car x) (car y)) t (if (equal (car x) (car y)) (e0-ord-< (cdr x) (cdr y)) nil)) nil) (if (consp y) t (< (if (rationalp x) x 0) (if (rationalp y) y 0))))) (defun true-listp (x) " TRUE-LISTP is the Acl2 function that checks whether its argument is a list that ends in NIL." (if (consp x) (true-listp (cdr x)) (equal x nil))) (defun list-macro (lst) (declare (xargs :guard (true-listp lst))) (if (equal lst nil) nil (cons 'cons (cons (car lst) (cons (list-macro (cdr lst)) nil))))) #+acl2-logic-only (defmacro list (&rest args) " LIST is the Common Lisp macro for building a list of objects. For example, (LIST 1 2 3) returns a list of length 3 whose elements are 1, 2, and 3 respectively." (list-macro args)) (defun and-macro (lst) (if (consp lst) (if (consp (cdr lst)) (list 'if (car lst) (and-macro (cdr lst)) nil) (car lst)) t)) #+acl2-logic-only (defmacro and (&rest args) " AND is the Common Lisp macro for conjunctions. AND takes any number of arguments. AND returns NIL if one of the arguments is NIL, but otherwise returns the last argument. If there are no arguments, AND returns T." (and-macro args)) (defun or-macro (lst) (if (consp lst) (if (consp (cdr lst)) (list 'if (car lst) (car lst) (or-macro (cdr lst))) (car lst)) nil)) #+acl2-logic-only (defmacro or (&rest args) " OR is the Common Lisp disjunction function. OR takes any number of arguments and returns the first that is non-NIL, or NIL if there is no non-NIL element." (or-macro args)) #+acl2-logic-only (defun eq (x y) " EQ is the Common Lisp function for determining whether two objects are identical (i.e., have the exact same store address in the current von Neumann implementation of Common Lisp.) In Acl2, we insist that one of the arguments to EQ be symbol. Common Lisp guarantees that if x is a symbol, then x is EQ to y if and only if x is EQUAL to y. Thus, the Acl2 user should think of EQ as nothing besides a fast means for checking EQUAL when one argument is known to be a symbol. In particular, it is possible that an EQ test will not even require the cost of a function call but will be as fast as a single machine instruction." (declare (xargs :guard (or (symbolp x) (symbolp y)) :color :gold)) (equal x y)) #-acl2-logic-only (defun acl2-numberp (x) (numberp x)) #+acl2-logic-only (defmacro - (x &optional (y 'nil binary-casep)) ; In the general case, (- x y) expands to (binary-+ x (unary-- y)). But in the ; special case that y is a numeric constant we go ahead and run the unary-- ; and we put it in front of x in the binary-+ expression so that it is in the ; expected "normal" form. Thus, (- x 1) expands to (binary-+ -1 x). Two forms ; of y allow this "constant folding": explicit numbers and the quotations of ; explicit numbers. ; Constant folding is important in processing definitions. If the user has ; written (1- x), we translate that to (binary-+ -1 x) instead of to the more ; mechanical (binary-+ (unary-- 1) x). Note that the type of the former is ; easier to determine that the latter because type-set knows about the effect ; of adding the constant -1 to a positive, but not about adding the term (- 1). (if binary-casep ; First we map 'n to n so we don't have so many cases. (let ((y (if (and (consp y) (eq (car y) 'quote) (consp (cdr y)) (acl2-numberp (car (cdr y))) (eq (cdr (cdr y)) nil)) (car (cdr y)) y))) (if (acl2-numberp y) (cons 'binary-+ (cons (unary-- y) (cons x nil))) (cons 'binary-+ (cons x (cons (cons 'unary-- (cons y nil)) nil))))) (let ((x (if (and (consp x) (eq (car x) 'quote) (consp (cdr x)) (acl2-numberp (car (cdr x))) (eq (cdr (cdr x)) nil)) (car (cdr x)) x))) (if (acl2-numberp x) (unary-- x) (cons 'unary-- (cons x nil)))))) ; integer-abs is just abs if x is an integer and is 0 otherwise. ; integer-abs is used because we don't know that that (abs x) is a ; nonnegative integer when x is an integer. By using integer-abs in ; the defun of acl2-count below we get that the type-prescription for ; acl2-count is a nonnegative integer. (defun integer-abs (x) (if (integerp x) (if (< x 0) (- x) x) 0)) (defun xxxjoin (fn args) " (xxxjoin fn args) spreads the binary function symbol fn over args, a list of arguments. For example, (xxxjoin '+ '(1 2 3)) = '(+ 1 (+ 2 3)))." (declare (xargs :guard (if (true-listp args) (cdr args) nil))) (if (cdr (cdr args)) (cons fn (cons (car args) (cons (xxxjoin fn (cdr args)) nil))) (cons fn args))) #+acl2-logic-only (defmacro + (&rest rst) (if rst (if (cdr rst) (xxxjoin 'binary-+ rst) (cons 'binary-+ (cons 0 (cons (car rst) nil)))) 0)) ; We now define length (and its subroutine len) so we can use them in ; acl2-count. (defun len (x) (if (consp x) (+ 1 (len (cdr x))) 0)) #+acl2-logic-only (defun length (x) " LENGTH is the Common Lisp function for determining the length of a sequence. In Acl2, the argument is required to be either a true-listp or a string." (declare (xargs :guard (if (true-listp x) t (stringp x)))) (if (stringp x) (len (coerce x 'list)) (len x))) #-acl2-logic-only (defun complex-rationalp (x) (complexp x)) (defun acl2-count (x) ":Doc-Section Miscellaneous a commonly used measure for justifying recursion~/ (Acl2-count x) returns a nonnegative integer that indicates the ``size'' of its argument x.~/ All characters and symbols have ACL2-COUNT 0. The ACL2-COUNT of a string is the number of characters in it, i.e., its length. The ACL2-COUNT of a cons is one greater than the sum of the ACL2-COUNTs of the car and cdr. The ACL2-COUNT of an integer is its absolute value. The ACL2-COUNT of a rational is the sum of the ACL2-COUNTs of the numerator and denominator. The ACL2-COUNT of a complex rational is one greater than the sum of the ACL2-COUNTs of the real and imaginary parts." ; We used to define the acl2-count of symbols to be (+ 1 (length ; (symbol-name x))) but then found it useful to make the acl2-count of ; NIL be 0 so that certain normalizations didn't explode the count. ; We then made the count of all symbols 0. This broad stroke was not ; strictly necessary, as far as we can see, it just simplifies the ; definition of acl2-count and does not seem to affect the common ; recursions and inductions. (if (consp x) (+ 1 (acl2-count (car x)) (acl2-count (cdr x))) (if (rationalp x) (if (integerp x) (integer-abs x) (+ (integer-abs (numerator x)) (denominator x))) (if (complex-rationalp x) (+ 1 (acl2-count (realpart x)) (acl2-count (imagpart x))) (if (stringp x) (length x) 0))))) ; The following rewrite rule may be useful for termination proofs, but ; at this point it seems premature to claim any kind of understanding ; of how to integrate such rules with appropriate linear rules. #| (defthm acl2-count-consp (implies (consp x) (equal (acl2-count x) (+ 1 (acl2-count (car x)) (acl2-count (cdr x)))))) |# (defun cond-clausesp (clauses) (if (consp clauses) (and (consp (car clauses)) (true-listp (car clauses)) (< (len (car clauses)) 3) (cond-clausesp (cdr clauses))) (eq clauses nil))) (defun cond-macro (clauses) (declare (xargs :guard (cond-clausesp clauses))) (if (eq clauses nil) nil (if (eq (car (car clauses)) t) (if (cdr (car clauses)) (car (cdr (car clauses))) (car (car clauses))) (list 'if (car (car clauses)) (if (cdr (car clauses)) (car (cdr (car clauses))) (car (car clauses))) (cond-macro (cdr clauses)))))) #+acl2-logic-only (defmacro cond (&rest clauses) " COND is the Lisp construct for IF, THEN, ELSE IF, ... The test is against NIL. The argument list for COND is a list of ``clauses'', each of which is a list. In Acl2, clauses must have length less than 3 and greater than 0." (cond-macro clauses)) ; The function eqlablep is gold even during the first pass, in order to support ; the definition of eql, which is in *expandable-boot-strap-non-rec-fns* and ; hence needs to be :gold. (defun eqlablep (x) (declare (xargs :color :gold)) (or (acl2-numberp x) (symbolp x) (characterp x))) ; Note: Eqlablep is the guard on the function eql. Eql is on *expandable-boot- ; strap-non-rec-fns* and is hence expanded by type-set and assume-true-false ; when its guard is established. Thus, the system works best if eqlablep is ; known to be a compound recognizer so that type-set can work with it when it ; sees it in the guard of eql. (defthm eqlablep-recog (equal (eqlablep x) (or (acl2-numberp x) (symbolp x) (characterp x))) :rule-classes :compound-recognizer) (in-theory (disable eqlablep)) (defun eqlable-listp (l) (if (consp l) (and (eqlablep (car l)) (eqlable-listp (cdr l))) (equal l nil))) #+acl2-logic-only (defun atom (x) (declare (xargs :color :gold)) (not (consp x))) (defun eqlable-alistp (x) (cond ((atom x) (equal x nil)) (t (and (consp (car x)) (eqlablep (car (car x))) (eqlable-alistp (cdr x)))))) (defun alistp (l) (cond ((atom l) (eq l nil)) (t (and (consp (car l)) (alistp (cdr l)))))) (defthm alistp-forward-to-true-listp (implies (alistp x) (true-listp x)) :rule-classes :forward-chaining) (defthm eqlable-alistp-forward-to-alistp (implies (eqlable-alistp x) (alistp x)) :rule-classes :forward-chaining) (defun member-equal (x lst) (declare (xargs :guard (true-listp lst))) (cond ((eq lst nil) nil) ((equal x (car lst)) lst) (t (member-equal x (cdr lst))))) (defun union-equal (x y) (declare (xargs :guard (and (true-listp x) (true-listp y)))) (cond ((eq x nil) y) ((member-equal (car x) y) (union-equal (cdr x) y)) (t (cons (car x) (union-equal (cdr x) y))))) (defun subsetp-equal (x y) (declare (xargs :guard (and (true-listp y) (true-listp x)))) (cond ((eq x nil) t) ((member-equal (car x) y) (subsetp-equal (cdr x) y)) (t nil))) (defun symbolp-listp (lst) (cond ((atom lst) (eq lst nil)) (t (and (symbolp (car lst)) (symbolp-listp (cdr lst)))))) (defthm symbolp-listp-forward-to-true-listp (implies (symbolp-listp x) (true-listp x)) :rule-classes :forward-chaining) (defun member-eq (x lst) (declare (xargs :guard (if (symbolp x) (true-listp lst) (symbolp-listp lst)))) (cond ((eq lst nil) nil) ((eq x (car lst)) lst) (t (member-eq x (cdr lst))))) (defun symbol-alistp (x) (cond ((atom x) (eq x nil)) (t (and (consp (car x)) (symbolp (car (car x))) (symbol-alistp (cdr x)))))) (defthm symbol-alistp-forward-to-eqlable-alistp (implies (symbol-alistp x) (eqlable-alistp x)) :rule-classes :forward-chaining) (defun assoc-eq (x alist) (declare (xargs :guard (if (symbolp x) (alistp alist) (symbol-alistp alist)))) (cond ((eq alist nil) nil) ((eq x (car (car alist))) (car alist)) (t (assoc-eq x (cdr alist))))) (defun assoc-equal (x alist) (declare (xargs :guard (alistp alist))) (cond ((eq alist nil) nil) ((equal x (car (car alist))) (car alist)) (t (assoc-equal x (cdr alist))))) (defun assoc-eq-equal-alistp (x) (cond ((atom x) (eq x nil)) (t (and (consp (car x)) (symbolp (car (car x))) (consp (cdr (car x))) (assoc-eq-equal-alistp (cdr x)))))) (defun assoc-eq-equal (x y alist) ; We look for a pair on alist of the form (x y . val) where we compare the ; first key using eq and the second using equal. We return the pair or nil. ; The guard could be weakened so that if x is a symbol, then alist need only be ; a true-listp whose elements are of the form (x y . val). But there seems to ; be little advantage in having such a guard, considering the case splits that ; it could induce. (declare (xargs :guard (assoc-eq-equal-alistp alist))) (cond ((eq alist nil) nil) ((and (eq (car (car alist)) x) (equal (car (cdr (car alist))) y)) (car alist)) (t (assoc-eq-equal x y (cdr alist))))) (defun no-duplicatesp (l) (declare (xargs :guard (true-listp l))) (cond ((equal l nil) t) ((member-equal (car l) (cdr l)) nil) (t (no-duplicatesp (cdr l))))) (defun strip-cars (x) (declare (xargs :guard (alistp x))) (cond ((atom x) nil) (t (cons (car (car x)) (strip-cars (cdr x)))))) #+acl2-logic-only (defmacro let* (bindings body) (declare (xargs :guard (and (eqlable-alistp bindings) (no-duplicatesp (strip-cars bindings))))) ; If one is ever tempted to permit let* to have a declaration ; spot after the bindings, worry about filtering the declarations ; in the recursion. (cond ((consp bindings) (list 'let (list (car bindings)) (list 'let* (cdr bindings) body))) (t body))) #+acl2-logic-only (defun eql (x y) (declare (xargs :guard (or (eqlablep x) (eqlablep y)) :color :gold)) (equal x y)) ; DATA TYPES #+acl2-logic-only (defmacro <= (x y) (list 'not (list '< y x))) #+acl2-logic-only (defun = (x y) (declare (xargs :guard (and (acl2-numberp x) (acl2-numberp y)) :color :gold)) (equal x y)) #+acl2-logic-only (defun /= (x y) (declare (xargs :guard (and (acl2-numberp x) (acl2-numberp y)) :color :gold)) (not (equal x y))) #+acl2-logic-only (defmacro > (x y) (list '< y x)) #+acl2-logic-only (defmacro >= (x y) (list 'not (list '< x y))) #+acl2-logic-only (defun nth (n l) (declare (xargs :guard (and (integerp n) (>= n 0) (true-listp l)))) (if (eq l nil) nil (if (eql n 0) (car l) (nth (- n 1) (cdr l))))) #+acl2-logic-only (defun char (s n) (declare (xargs :guard (and (stringp s) (integerp n) (>= n 0) (< n (length s))))) (nth n (coerce s 'list))) (defun proper-consp (x) (and (consp x) (true-listp x))) (defun improper-consp (x) (and (consp x) (not (true-listp x)))) #+acl2-logic-only (defun null (x) (declare (xargs :color :gold)) (eq x nil)) #+acl2-logic-only (defmacro * (&rest rst) (cond ((null rst) 1) ((null (cdr rst)) (list 'binary-* 1 (car rst))) (t (xxxjoin 'binary-* rst)))) #+acl2-logic-only (defun conjugate (x) (declare (xargs :guard (acl2-numberp x))) (if (complex-rationalp x) (complex (realpart x) (- (imagpart x))) x)) (defun prog2$ (x y) ; This odd little duck is not as useless as it seems. The purpose of ; this function is only to serve as a messenger for translate to use ; to send a message to the guard checker. Guards that are created by ; declarations in lets and other places are put into the first arg of ; a prog2$. Once the guards required by x have been noted, x's value ; may be ignored. If this function is changed, consider the places it ; is mentioned, including the mention of 'prog2$ in distribute-first- ; if. (declare (ignore x) (xargs :color :gold)) y) #+acl2-logic-only (defmacro / (x &optional (y 'nil binary-casep)) (cond (binary-casep (list 'binary-* x (list 'unary-/ y))) (t (list 'unary-/ x)))) (defaxiom closure (implies (and (acl2-numberp x) (acl2-numberp y)) (and (acl2-numberp (+ x y)) (acl2-numberp (* x y)) (acl2-numberp (- x)) (implies (not (equal x 0)) (acl2-numberp (/ x))))) :rule-classes nil) (defaxiom Associativity-of-+ (implies (and (acl2-numberp x) (acl2-numberp y) (acl2-numberp z)) (equal (+ (+ x y) z) (+ x (+ y z))))) (defaxiom Commutativity-of-+ (implies (and (acl2-numberp x) (acl2-numberp y)) (equal (+ x y) (+ y x)))) (defaxiom Unicity-of-0 (implies (acl2-numberp x) (equal (+ 0 x) x))) (defaxiom Inverse-of-+ (implies (acl2-numberp x) (equal (+ x (- x)) 0))) (defaxiom Associativity-of-* (implies (and (acl2-numberp x) (acl2-numberp y) (acl2-numberp z)) (equal (* (* x y) z) (* x (* y z))))) (defaxiom Commutativity-of-* (implies (and (acl2-numberp x) (acl2-numberp y)) (equal (* x y) (* y x)))) (defaxiom Unicity-of-1 (implies (acl2-numberp x) (equal (* 1 x) x))) (defaxiom Inverse-of-* (implies (and (acl2-numberp x) (not (equal x 0))) (equal (* x (/ x)) 1))) (defaxiom Distributivity (implies (and (acl2-numberp x) (acl2-numberp y) (acl2-numberp z)) (equal (* x (+ y z)) (+ (* x y) (* x z))))) (defaxiom <-on-others (implies (and (rationalp x) (rationalp y)) (equal (< x y) (< (+ x (- y)) 0))) :rule-classes nil) (defaxiom Zero (not (< 0 0)) :rule-classes nil) (defaxiom Trichotomy (and (implies (rationalp x) (or (< 0 x) (equal x 0) (< 0 (- x)))) (implies (rationalp x) (or (not (< 0 x)) (not (< 0 (- x)))))) :rule-classes nil) (defaxiom Positive (implies (and (rationalp x) (rationalp y)) (implies (and (< 0 x) (< 0 y)) (and (< 0 (+ x y)) (< 0 (* x y))))) :rule-classes nil) (defaxiom Rational-implies1 (implies (rationalp x) (and (integerp (denominator x)) (integerp (numerator x)) (< 0 (denominator x)))) :rule-classes nil) (defaxiom Rational-implies2 (implies (rationalp x) (equal (* (numerator x) (/ (denominator x))) x))) (defaxiom integer-implies-rational (implies (integerp x) (rationalp x)) :rule-classes nil) (defaxiom complex-implies1 (implies (acl2-numberp x) (and (rationalp (realpart x)) (rationalp (imagpart x)))) :rule-classes nil) (defaxiom complex-definition (implies (and (rationalp x) (rationalp y)) (equal (complex x y) (+ x (* #c(0 1) y)))) :rule-classes nil) (defaxiom complex-rationalp-has-nonzero-imagpart (implies (complex-rationalp x) (not (equal 0 (imagpart x)))) :rule-classes nil) (defaxiom realpart-imagpart-elim (implies (acl2-numberp x) (equal (complex (realpart x) (imagpart x)) x)) :rule-classes (:REWRITE :ELIM)) ; We think that the following two axioms can be proved from the others. (defaxiom realpart-complex (implies (and (rationalp x) (rationalp y)) (equal (realpart (complex x y)) x))) (defaxiom imagpart-complex (implies (and (rationalp x) (rationalp y)) (equal (imagpart (complex x y)) y))) (defthm complex-equal (implies (and (rationalp x1) (rationalp y1) (rationalp x2) (rationalp y2)) (equal (equal (complex x1 y1) (complex x2 y2)) (and (equal x1 x2) (equal y1 y2)))) :hints (("Goal" :use ((:instance imagpart-complex (x x1) (y y1)) (:instance imagpart-complex (x x2) (y y2)) (:instance realpart-complex (x x1) (y y1)) (:instance realpart-complex (x x2) (y y2))) :in-theory (disable imagpart-complex realpart-complex)))) (defun force (x) ":Doc-Section Miscellaneous identity function used to force a case split~/ When a hypothesis of a conditional rule has the form (force hyp) it is logically equivalent to hyp but has a pragmatic effect. In particular, when the rule is considered, the needed instance of the hypothesis, hyp', is assumed and a special case is generated, requiring the system to prove that hyp' is true in the current context. The proofs of all such ``forced assumptions'' are delayed until the successful completion of the main goal. See :DOC forcing-round. Forcing should only be used on hypotheses that are always expected to be true, such as the guards of functions. All the power of the theorem prover is brought to bear on a forced hypothesis and no backtracking is possible. It is possible to cause the prover to advise the user every time a hypothesis is forced; see :DOC force-table. If the :executable-counterpart of the function force is disabled, then no hypothesis is forced. See :DOC enable-forcing and :DOC disable-forcing.~/ It sometimes happens that a conditional rule is not applied because some hypothesis, hyp, could not be relieved, even though the required instance of hyp, hyp', can be shown true in the context. This happens when insufficient resources are brought to bear on hyp' at the time we try to relieve it. A sometimes desirable alternative behavior is for the system to assume hyp', apply the rule, and to generate explicitly a special case to show that hyp' is true in the context. This is called ``forcing'' hyp. It can be arranged by restating the :COROLLARY of the rule, replacing the offending hypothesis, hyp, by (force hyp). Technically, force is just a function of one argument that returns that argument. It is generally enabled and hence evaporates during simplification. But its presence among the hypotheses of a conditional rule causes case splitting to occur if the hypothesis cannot be conventionally relieved. Since a forced hypothesis must be provable whenever the rule is otherwise applicable, forcing should be used only on hypotheses that are expected always to be true. A common situation is when the hypothesis is in fact a guard (or part of a guard) of some function involved in the pattern that triggers the rule. Intuitively, if that pattern term occurs in the current conjecture, then its guards had better be true, since otherwise nothing is known about the term. A particularly common situation in which some hypotheses should be forced is in ``most general'' type-prescription lemmas. If a single lemma describes the ``expected'' type of a function, for all ``expected'' arguments, then it is probably a good idea to force the hypotheses of the lemma. Thus, every time a term involving the function arises, the term will be given the expected type and its arguments will be required to be of the expected type. In applying this advice it might be wise to avoid forcing those hypotheses that are in fact just type predicates on the arguments, since the routine that applies type-prescription lemmas has fairly thorough knowledge of the types of all terms. Force can have the additional benefit of causing the Acl2 typing mechanism to interact with the Acl2 rewriter to establish the hypotheses of type-prescription rules. To understand this remark, think of the Acl2 type reasoning system as a rather primitive rule-based theorem prover for questions about Common Lisp types, e.g., ``does this expression produce a CONSP?'' ``does this expression produce some kind of Acl2 number, e.g., an INTEGERP, a RATIONALP, or a COMPLEX-RATIONALP?'' etc. It is driven by type-prescription rules. To relieve the hypotheses of such rules, the type system recursively invokes itself. This can be done for any hypothesis, whether it is ``type-like'' or not, since any proposition, p, can be phrased as the type-like question ``does p produce an object of type NIL?'' However, as you might expect, the type system is not very good at establishing hypotheses that are not type-like, unless they happen to be assumed explicitly in the context in which the question is posed, e.g., ``If p produces a CONSP then does p produce NIL?'' If type reasoning alone is insufficient to prove some instance of a hypothesis, then the instance will not be proved by the type system and a type-prescription rule with that hypothesis will be inapplicable in that case. But by embedding such hypotheses in FORCE expressions you can effectively cause the type system to ``punt'' them to the rest of the theorem prover. Of course, as already noted, this should only be done on hypotheses that are ``always true.'' In particular, if is required to establish some hypothesis of a type-prescription rule, then the rule will be found inapplicable because the hypothesis will not be established by type reasoning alone. The Acl2 rewriter uses the type reasoning system as a subsystem. It is therefore possible that the type system will force a hypothesis that the rewriter could establish. Before a forced hypothesis is reported out of the rewriter, we try to establish it by rewriting. This makes the following surprising behavior possible: A type-prescription rule fails to apply because some true hypothesis is not being relieved. The user changes the rule so as to FORCE the hypothesis. The system then applies the rule but reports no forcing. How can this happen? The type system ``punted'' the forced hypothesis to the rewriter, which established it.~/" x) (defmacro disable-forcing nil ":Doc-Section Miscellaneous to disallow forced case splits~/ General Form: ACL2 Gold>:disable-forcing ; disallow forced case splits See :DOC force for a discussion of forced case splits.~/ Disable-forcing is a macro that disables the executable counterpart of the function symbol FORCE, as described in :DOC force." '(in-theory (disable (:executable-counterpart force)))) (defmacro enable-forcing nil ":Doc-Section Miscellaneous to allow forced case splits~/ General Form: ACL2 Gold>:enable-forcing ; allowed forced case splits See :DOC force for a discussion of forced case splits.~/ Enable-forcing is a macro that enables the executable counterpart of the function symbol FORCE, as described in :DOC force." '(in-theory (enable (:executable-counterpart force)))) (defun syntaxp (x) (declare (ignore x) (xargs :color :gold)) ":Doc-Section Miscellaneous to attach a heuristic filter on a :REWRITE rule~/ Example: Consider the :REWRITE rule created from (IMPLIES (SYNTAXP (NOT (AND (CONSP X) (EQ (CAR X) 'NORM)))) (EQUAL (LXD X) (LXD (NORM X)))). The SYNTAXP hypothesis in this rule will allow the rule to be applied to (LXD (TRN A B)) but will not allow it to be applied to (LXD (NORM A)).~/ General Form: (SYNTAXP test) may be used as the nth hypothesis in a :REWRITE rule whose :COROLLARY is (IMPLIES (AND hyp1 ... hypn ... hypk) (equiv lhs rhs)) provided test is a term, test contains at least one variable, and every variable occuring freely in test occurs freely in lhs or in some hypi, i #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\] #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ #\| #\} #\~)) #+acl2-logic-only (defun standard-char-p (x) ; The following guard is required by p. 234 of CLtL. (declare (xargs :guard (characterp x))) (if (member x *standard-chars*) t nil)) (defun standard-char-listp (l) (cond ((consp l) (and (characterp (car l)) (standard-char-p (car l)) (standard-char-listp (cdr l)))) (t (equal l nil)))) (defun character-lst (l) (cond ((atom l) (equal l nil)) (t (and (characterp (car l)) (character-lst (cdr l)))))) (defthm character-lst-forward-to-eqlable-listp (implies (character-lst x) (eqlable-listp x)) :rule-classes :forward-chaining) (defthm standard-char-listp-forward-to-character-lst (implies (standard-char-listp x) (character-lst x)) :rule-classes :forward-chaining) (defaxiom stringp-coerce-string (implies (standard-char-listp x) (stringp (coerce x 'string)))) (defaxiom coerce-inverse-1 (implies (standard-char-listp x) (equal (coerce (coerce x 'string) 'list) x))) #| A "historical document" regarding standard characters: To: Kaufmann Subject: over strong axiom FCC: ~moore/old-mail --text follows this line-- Axioms.lisp currently contains (defaxiom coerce-inverse-2 (implies (stringp x) (equal (coerce (coerce x 'list) 'string) x))) But the guard for coerce (when the second argument is 'string) requires the first argument to be a standard-char-listp. Thus, unless we know that (coerce x 'list) returns a standard-char-listp when (stringp x), the guard on the outer coerce is violated. If we are really serious that Acl2 strings may contain nonstandard chars, then this axiom is too strong. I will leave this note in axioms.lisp and just go on. But when the guard question is settled I would like to return to this and make explicit our occasional implicit assumption that strings are composed of standard chars. J |# (defaxiom coerce-inverse-2 (implies (stringp x) (equal (coerce (coerce x 'list) 'string) x))) ; Once upon a time, Moore (working alone) added the following axiom. (defaxiom standard-char-listp-coerce (implies (stringp str) (standard-char-listp (coerce str 'list)))) ; In AKCL the nonstandard character #\Page prints as ^L and may be included in ; strings, as in "^L". Now if you try to type that string in Acl2, you get an ; error. And Acl2 does not let you use coerce to produce the string, e.g., ; with (coerce (list #\Page) 'string), because the guard for coerce is ; violated. So here we have a situation in which no Acl2 function in LP will ; ever see a nonstandard char in a string, but CLTL permits it. However, we ; consider the axiom to be appropriate, because Acl2 strings contain only ; standard characters. (in-theory (disable standard-char-listp standard-char-p)) (defthm standard-char-listp-coerce-forward-chaining ; If (stringp str) is in the context, we want to make a "note" that ; (coerce str 'list) is a standard-char-listp in case this fact is ; needed during later backchaining. We see no need to forward chain ; from (standard-char-listp (coerce str 'list)), however; the rewrite ; rule generated here should suffice for relieving any such hypothesis. (implies (stringp str) (standard-char-listp (coerce str 'list))) :rule-classes ((:forward-chaining :trigger-terms ((coerce str 'list))))) #+acl2-logic-only (defun string (x) "Coerces x to a string, where x can be STRINGP, SYMBOLP, or STANDARD-CHAR-P." (declare (xargs :guard ; NOTE: When we finally get hold of a definitive Common Lisp ; reference, let's clarify the statement near the bottom of p. 466 of ; CLtL2, which says: "Presumably converting a character to a string ; always works according to this vote." But we'll plunge ahead as ; follows, in part because we want to remain compliant with CLtL1, ; which isn't as complete as one might wish regarding which characters ; can go into strings. (or (stringp x) (symbolp x) (and (characterp x) (standard-char-p x))) :guard-hints (("Goal" :in-theory (enable standard-char-listp))))) (cond ((stringp x) x) ((symbolp x) (symbol-name x)) (t (coerce (list x) 'string)))) #+acl2-logic-only (defun alpha-char-p (x) ; The following guard is required by p. 235 of CLtL. (declare (xargs :guard (characterp x))) (and (member x '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) t)) #+acl2-logic-only (defun upper-case-p (x) ; The following guard is required by p. 235 of CLtL. (declare (xargs :guard (characterp x))) (and (member x '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)) t)) #+acl2-logic-only (defun lower-case-p (x) ; The following guard is required by p. 235 of CLtL. (declare (xargs :guard (characterp x))) (and (member x '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) t)) #+acl2-logic-only (defun char-upcase (x) ; The following guard is required by p. 231 of CLtL. (declare (xargs :guard (characterp x))) (let ((pair (assoc x '((#\a . #\A) (#\b . #\B) (#\c . #\C) (#\d . #\D) (#\e . #\E) (#\f . #\F) (#\g . #\G) (#\h . #\H) (#\i . #\I) (#\j . #\J) (#\k . #\K) (#\l . #\L) (#\m . #\M) (#\n . #\N) (#\o . #\O) (#\p . #\P) (#\q . #\Q) (#\r . #\R) (#\s . #\S) (#\t . #\T) (#\u . #\U) (#\v . #\V) (#\w . #\W) (#\x . #\X) (#\y . #\Y) (#\z . #\Z))))) (cond (pair (cdr pair)) (t x)))) #+acl2-logic-only (defun char-downcase (x) ; The following guard is required by p. 231 of CLtL. (declare (xargs :guard (characterp x))) (let ((pair (assoc x '((#\A . #\a) (#\B . #\b) (#\C . #\c) (#\D . #\d) (#\E . #\e) (#\F . #\f) (#\G . #\g) (#\H . #\h) (#\I . #\i) (#\J . #\j) (#\K . #\k) (#\L . #\l) (#\M . #\m) (#\N . #\n) (#\O . #\o) (#\P . #\p) (#\Q . #\q) (#\R . #\r) (#\S . #\s) (#\T . #\t) (#\U . #\u) (#\V . #\v) (#\W . #\w) (#\X . #\x) (#\Y . #\y) (#\Z . #\z))))) (cond (pair (cdr pair)) (t x)))) (defthm lower-case-p-char-downcase (implies (and (upper-case-p x) (characterp x)) (lower-case-p (char-downcase x)))) (defthm upper-case-p-char-upcase (implies (and (lower-case-p x) (characterp x)) (upper-case-p (char-upcase x)))) (defthm lower-case-p-forward-to-alpha-char-p (implies (and (lower-case-p x) (characterp x)) (alpha-char-p x)) :rule-classes :forward-chaining) (defthm upper-case-p-forward-to-alpha-char-p (implies (and (upper-case-p x) (characterp x)) (alpha-char-p x)) :rule-classes :forward-chaining) (defthm alpha-char-p-forward-to-standard-char-p (implies (and (alpha-char-p x) (characterp x)) (standard-char-p x)) :rule-classes :forward-chaining) (defthm standard-char-p-char-downcase (implies (and (characterp x) (standard-char-p x)) (and (characterp (char-downcase x)) (standard-char-p (char-downcase x)))) :rule-classes ((:forward-chaining :trigger-terms ((char-downcase x))))) (defthm standard-char-p-char-upcase (implies (and (characterp x) (standard-char-p x)) (and (characterp (char-upcase x)) (standard-char-p (char-upcase x)))) :rule-classes ((:forward-chaining :trigger-terms ((char-upcase x))))) (in-theory (disable alpha-char-p upper-case-p lower-case-p char-upcase char-downcase)) (defun string-downcase1 (l) (declare (xargs :guard (character-lst l))) (if (atom l) nil (cons (char-downcase (car l)) (string-downcase1 (cdr l))))) (defthm standard-char-listp-string-downcase-1 (implies (standard-char-listp x) (standard-char-listp (string-downcase1 x))) :hints (("Goal" :in-theory (enable standard-char-listp)))) #+acl2-logic-only (defun string-downcase (x) (declare (xargs :guard (stringp x))) ; As with other functions, e.g., reverse, the guards on this function ; can't currently be proved because the outer coerce below requires ; its argument to be made of standard characters. We don't know that ; the string x is made of standard characters. (coerce (string-downcase1 (coerce x 'list)) 'string)) (defun string-upcase1 (l) (declare (xargs :guard (character-lst l))) (if (atom l) nil (cons (char-upcase (car l)) (string-upcase1 (cdr l))))) (defthm standard-char-listp-string-upcase-1 (implies (standard-char-listp x) (standard-char-listp (string-upcase1 x))) :hints (("Goal" :in-theory (enable standard-char-listp)))) #+acl2-logic-only (defun string-upcase (x) (declare (xargs :guard (stringp x))) (coerce (string-upcase1 (coerce x 'list)) 'string)) (defun our-digit-char-p (ch radix) (declare (xargs :guard (rationalp radix))) (let ((l (assoc ch '((#\0 . 0) (#\1 . 1) (#\2 . 2) (#\3 . 3) (#\4 . 4) (#\5 . 5) (#\6 . 6) (#\7 . 7) (#\8 . 8) (#\9 . 9) (#\a . 10) (#\b . 11) (#\c . 12) (#\d . 13) (#\e . 14) (#\f . 15) (#\g . 16) (#\h . 17) (#\i . 18) (#\j . 19) (#\k . 20) (#\l . 21) (#\m . 22) (#\n . 23) (#\o . 24) (#\p . 25) (#\q . 26) (#\r . 27) (#\s . 28) (#\t . 29) (#\u . 30) (#\v . 31) (#\w . 32) (#\x . 33) (#\y . 34) (#\z . 35) (#\A . 10) (#\B . 11) (#\C . 12) (#\D . 13) (#\E . 14) (#\F . 15) (#\G . 16) (#\H . 17) (#\I . 18) (#\J . 19) (#\K . 20) (#\L . 21) (#\M . 22) (#\N . 23) (#\O . 24) (#\P . 25) (#\Q . 26) (#\R . 27) (#\S . 28) (#\T . 29) (#\U . 30) (#\V . 31) (#\W . 32) (#\X . 33) (#\Y . 34) (#\Z . 35))))) (cond ((and l (< (cdr l) radix)) (cdr l)) (t nil)))) #+acl2-logic-only (defmacro digit-char-p (ch &optional (radix '10)) `(our-digit-char-p ,ch ,radix)) ; CLTL2 and the ANSI standard have made the main Lisp package name be ; COMMON-LISP rather than the older LISP. (defconst *main-lisp-package-name* #-CLTL2 "LISP" #+CLTL2 "COMMON-LISP") ; Warning: If you add primitive packages to this list, be sure to add ; the defaxioms that would be done by defpkg. For example, below you ; will find a defaxiom for ACL2-INPUT-CHANNEL-PACKAGE and any new ; package should have an analogous axiom added. Each of the primitive ; packages below has such an axiom explicitly added in axioms.lisp ; (except for the main lisp package name, whose import list is ; essentially unknown). (defconst *initial-known-package-alist* (list (cons "ACL2-INPUT-CHANNEL" nil) (cons "ACL2-OUTPUT-CHANNEL" nil) (cons "ACL2" *common-lisp-symbols-from-main-lisp-package*) (cons *main-lisp-package-name* nil) (cons "KEYWORD" nil))) #-acl2-logic-only (defun symbol-package-name (x) (cond ((get x *initial-lisp-symbol-mark*)) ((package-name (symbol-package x))) ; We use ERROR now because we cannot print symbols without packages ; with Acl2 functions. (t (error "The symbol ~a, which has no package, was encountered~%~ by Acl2. This is an inconsistent state of affairs, one that~%~ may have arisen by undoing a defpkg but holding onto a symbol~%~ in the package being flushed, contrary to warnings printed.~%~%" x)))) (defaxiom no-duplicates-among-characterps (implies (characterp x) (not (member x (cdr (member x (cons #\Page (cons #\Rubout (cons #\Tab *standard-chars*)))))))) :rule-classes nil) #+acl2-logic-only (defun keywordp (x) (and (symbolp x) (equal (symbol-package-name x) "KEYWORD"))) (defthm keywordp-forward-to-symbolp (implies (keywordp x) (symbolp x)) :rule-classes :forward-chaining) #| The following axiom has been deleted because Moore didn't like the vision that it entails, namely, that we are operating in a world in which there has been a defpkg for every possible string. The deletion of this axiom has had a few effects, which have been noted by the occurrence of the name symbolp-intern in nearby comments. (defaxiom symbolp-intern (implies (and (stringp s) (stringp p)) (symbolp (intern s p)))) |# ; ??? The following axiom is new and was added by Moore working alone. ; Is it ok? It is phrased as a bridge lemma because it is actually ; useful when pkg is permitted to be a quoted constant like "ACL2". ; This axiom was needed in the proof that the Nqthm embedding of ; LITATOMs was done correctly. (defaxiom intern-symbol-name (implies (and (symbolp x) (equal pkg (symbol-package-name x))) (equal (intern (symbol-name x) pkg) x))) (defun atom-listp (lst) (cond ((atom lst) (eq lst nil)) (t (and (atom (car lst)) (atom-listp (cdr lst)))))) (defthm atom-listp-forward-to-true-listp (implies (atom-listp x) (true-listp x)) :rule-classes :forward-chaining) (defthm eqlable-listp-forward-to-atom-listp (implies (eqlable-listp x) (atom-listp x)) :rule-classes :forward-chaining) ; member-symbol-name is used in the defpkg axiom. (defun member-symbol-name (str l) (declare (xargs :guard (symbolp-listp l))) (cond ((eq l 'nil) nil) ((equal str (symbol-name (car l))) l) (t (member-symbol-name str (cdr l))))) (defaxiom symbol-equality ; I don't know whether this axiom can be derived from the other ; axioms, but it is supposed to be true. Note that it would not be ; true if Acl2 could get its hands on gensyms. ?? (implies (and (symbolp s1) (symbolp s2) (equal (symbol-name s1) (symbol-name s2)) (equal (symbol-package-name s1) (symbol-package-name s2))) (equal s1 s2)) :rule-classes nil) ; The following axiom is specious if we don't have symbolp-intern. In ; particular, (intern s p) must yield a symbol to satisfy the guards of ; symbol-name and symbolp-package-name. (defaxiom symbol-name-intern (implies (and (stringp s) (stringp p)) (and (equal (symbol-name (intern s p)) s) (stringp (symbol-package-name (intern s p)))))) ; What else do we know about (symbol-package-name (intern s p)), under ; the hypotheses that both s and p are strings? Our knowledge is ; never complete on this question. The answer, if it is known, ; depends upon the defpkg axiomatic acts of the user. At any moment, ; the current value of known-package-alist is an alist dotting strings ; with symbol lists. The current value is always an extension of the ; initial value. If p is not in the domain of known-package-alist, ; then we just don't know the answer to the question at this time. ; But if p is in the domain of known-package-alist, then we do, and ; here is the answer. Let l be the image of p under ; known-package-alist. l is a list of symbols. If s is not the ; symbol-name of any of the members of l, then (symbol-package-name ; (intern s p)) = p. However, suppose s is the symbol name of s', a ; member of l. (It is an invariant on known-package-alist that no two ; members of l have the same symbol-name.) Then (symbol-package-name ; (intern s p)) = (symbol-package s'). An invariant of ; known-package-alist is that (symbol-package s') is in the domain of ; the tail of known-package-alist after p. ; The next group of axioms was added by Moore working alone. It is ; just the axioms that would be added by defpkg had the packages in ; question been introduced that way. ; Warning: If the forms of these axioms are changed, you should ; probably visit the same change to the rules added by defpkg. (defaxiom acl2-input-channel-package (and (implies (stringp x) (symbolp (intern x "ACL2-INPUT-CHANNEL"))) (implies (stringp x) (equal (symbol-package-name (intern x "ACL2-INPUT-CHANNEL")) "ACL2-INPUT-CHANNEL"))) :rule-classes ((:REWRITE :COROLLARY (implies (stringp x) (equal (symbol-package-name (intern x "ACL2-INPUT-CHANNEL")) "ACL2-INPUT-CHANNEL"))))) (defaxiom acl2-output-channel-package (and (implies (stringp x) (symbolp (intern x "ACL2-OUTPUT-CHANNEL"))) (implies (stringp x) (equal (symbol-package-name (intern x "ACL2-OUTPUT-CHANNEL")) "ACL2-OUTPUT-CHANNEL"))) :rule-classes ((:REWRITE :COROLLARY (implies (stringp x) (equal (symbol-package-name (intern x "ACL2-OUTPUT-CHANNEL")) "ACL2-OUTPUT-CHANNEL"))))) (defaxiom acl2-package (and (implies (stringp x) (symbolp (intern x "ACL2"))) (implies (and (stringp x) (not (member-symbol-name x *common-lisp-symbols-from-main-lisp-package*))) (equal (symbol-package-name (intern x "ACL2")) "ACL2"))) :rule-classes ((:REWRITE :COROLLARY (implies (and (stringp x) (not (member-symbol-name x *common-lisp-symbols-from-main-lisp-package*))) (equal (symbol-package-name (intern x "ACL2")) "ACL2"))))) (defaxiom keyword-package (and (implies (stringp x) (symbolp (intern x "KEYWORD"))) (implies (stringp x) (equal (symbol-package-name (intern x "KEYWORD")) "KEYWORD"))) :rule-classes ((:REWRITE :COROLLARY (implies (stringp x) (equal (symbol-package-name (intern x "KEYWORD")) "KEYWORD"))))) ; Adding a similar axiom for pkg "LISP" would be wrong. We do not ; know what the imports to "LISP" are, they differ from lisp to lisp. ; ?? Do we need a similar axiom to that below about 'string? Exactly ; what is the point of this axiom? (defaxiom nil-is-circular (equal nil (intern (coerce (cons #\N (cons #\I (cons #\L nil))) 'string) (coerce (cons #\L (cons #\I (cons #\S (cons #\P nil)))) 'string))) :rule-classes nil) (defun intern-in-package-of-symbol (str sym) ; In general we require that intern be given an explicit string constant ; that names a package known at translate time. This avoids the run-time ; check that the package is known -- which would require passing state down ; to intern everywhere. However, we would like a more general intern ; mechanism and hence define the following, which is admitted by special ; decree in translate. The beauty of this use of intern is that the user ; supplies a symbol which establishes the existence of the desired package. (declare (type string str) (type symbol sym)) (intern str (symbol-package-name sym))) ; UTILITIES - definitions of the rest of applicative Common Lisp. (defun binary-append (x y) (declare (xargs :guard (true-listp x))) (cond ((null x) y) (t (cons (car x) (binary-append (cdr x) y))))) #+acl2-logic-only (defmacro append (x y &rest rst) (xxxjoin 'binary-append (cons x (cons y rst)))) ; The following lemma originally appeared to be useful for accepting the ; definition of make-input-channel. But now it's definitely useful for ; accepting the definition of string-append. (defthm standard-char-listp-append (implies (true-listp x) (equal (standard-char-listp (append x y)) (and (standard-char-listp x) (standard-char-listp y)))) :hints (("Goal" :in-theory (enable standard-char-listp)))) (defun string-append (str1 str2) (declare (xargs :guard (and (stringp str1) (stringp str2)))) (coerce (append (coerce str1 'list) (coerce str2 'list)) 'string)) (defun stringp-lst (x) (cond ((atom x) (eq x nil)) (t (and (stringp (car x)) (stringp-lst (cdr x)))))) (defun string-append-lst (x) (declare (xargs :guard (stringp-lst x))) (cond ((null x) "") ((null (cdr x)) (car x)) (t (string-append (car x) (string-append-lst (cdr x)))))) (defthm stringp-string-append-lst (implies (force (stringp-lst x)) (stringp (string-append-lst x))) :rule-classes :type-prescription) #+acl2-logic-only (defmacro concatenate (result-type &rest sequences) ; We do *not* try to comply with CLtL's insistence that concatenate copies. ; After all, we're in an applicative world, and this is a logic-only ; definition. (declare (xargs :guard (member-equal result-type '('string 'list)))) (cond ((equal result-type ''string) (list 'string-append-lst (cons 'list sequences))) ((null sequences) nil) ((null (cdr sequences)) (car sequences)) (t (cons 'append sequences)))) #+acl2-logic-only (defun 1+ (x) (declare (xargs :guard (acl2-numberp x) :color :gold)) (+ 1 x)) #+acl2-logic-only (defun 1- (x) (declare (xargs :guard (acl2-numberp x) :color :gold)) (- x 1)) #+acl2-logic-only (defun remove (x l) (declare (xargs :guard (if (eqlablep x) (true-listp l) (eqlable-listp l)))) (cond ((null l) nil) ((eql x (car l)) (remove x (cdr l))) (t (cons (car l) (remove x (cdr l)))))) (defun pairlis$ (x y) ; CLTL allows its pairlis to construct an alist in any order! So we ; have to give this function a different name. (declare (xargs :guard (and (true-listp x) (true-listp y) (eql (length x) (length y))))) (cond ((null x) nil) (t (cons (cons (car x) (car y)) (pairlis$ (cdr x) (cdr y)))))) (defun remove-duplicates-eql (l) (declare (xargs :guard (eqlable-listp l))) (cond ((null l) nil) ((member (car l) (cdr l)) (remove-duplicates-eql (cdr l))) (t (cons (car l) (remove-duplicates-eql (cdr l)))))) (defthm standard-char-listp-remove-duplicates-eql (implies (standard-char-listp x) (standard-char-listp (remove-duplicates-eql x))) :hints (("Goal" :in-theory (enable standard-char-listp)))) #+acl2-logic-only (defun remove-duplicates (l) (declare (xargs :guard (or (stringp l) (eqlable-listp l)))) (cond ((stringp l) (coerce (remove-duplicates-eql (coerce l 'list)) 'string)) (t (remove-duplicates-eql l)))) (defun remove-duplicates-equal (l) (declare (xargs :guard (true-listp l))) (cond ((null l) nil) ((member-equal (car l) (cdr l)) (remove-duplicates-equal (cdr l))) (t (cons (car l) (remove-duplicates-equal (cdr l)))))) ; Mutual Recursion ; We are about to need mutual recursion for the first time in axioms.lisp. ; We now define the mutual-recursion macro for the logic (defun strip-cdrs (l) (declare (xargs :guard (alistp l))) (cond ((atom l) nil) (t (cons (cdr (car l)) (strip-cdrs (cdr l)))))) (defun mutual-recursion-guardp (rst) (cond ((atom rst) (equal rst nil)) (t (and (consp (car rst)) (eq (car (car rst)) 'defun) (mutual-recursion-guardp (cdr rst)))))) ; We now define the first five documentation sections: Events, ; Documentation, History, Other, and Miscellaneous. These ; are defined here simply so we can use them freely throughout. The ; first four are advertised in :help. (deflabel events :doc ":Doc-Section Events Functions which Extend the Logic~/~/ Any extension of the syntax of Acl2 (i.e., the definition of a new constant or macro), the axioms (i.e., the definition of a function), or the rule data base (i.e., the proof of a theorem), constitutes a logical ``event.'' Events change the Acl2 logical world (see :DOC world). Indeed, the only way to change the Acl2 world is via the successful evaluation of an event function. Every time the world is changed by an event, a landmark is left on the world and it is thus possible to identify the world ``as of'' the evaluation of a given event. An event may introduce new logical names. Some events introduce no new names (e.g., VERIFY-GUARDS), some introduce exactly one (e.g., DEFMACRO and DEFTHM), and some may introduce many (e.g., ENCAPSULATE).~/") (deflabel documentation :doc ":Doc-Section Documentation Functions which Display Documentation~/ For an introduction to the Acl2 online documentation system, type :more below. Whenever the documentation system concludes with ``(cont'd)'' you may type :more to see the next block of documentation. The documentation commands are documented individually:~/ The Acl2 online documentation feature allows you to see extensive documentation on many Acl2 functions and ideas. You may use the documentation facilities to document your own Acl2 functions and theorems. If there is some name you wish to know more about, then type ACL2 Gold>:doc name in the top-level loop. If the name is documented, a brief blurb will be printed. If the name is not documented, but is ``similar'' to some documented names, they will be listed. Otherwise, NIL is returned. Every name that is documented contains a one-line description, a few notes, and some details. :Doc will print the one-liner and the notes. When :doc has finished it stops with the message ``(cont'd)'' to remind you that details are available. If you then type ACL2 Gold>:more a block of the continued text will be printed, again concluding with ``(cont'd)'' if the text continues further, or concluding with ``*-'' if the text has been exhausted. By continuing to type :more until exhausting the text you can read successive blocks. Alternatively, you can type :more! to get all the remaining blocks. If you want to get the details and don't want to see the elementary stuff typed by :doc name, type: ACL2 Gold>:MORE-DOC name We have documented not just function names but names of certain important ideas too. For example, :DOC rewrite and :DOC meta will tell you about :REWRITE rules and :META rules, respectively. :DOC hints will describe the structure of the :hints argument to the prover. The DEFLABEL event (see :DOC deflabel) is a way to introduce a logical name for no reason other than to attach documentation to it. How do you know what names are documented? There is a documentation data base which is querried with the :docs command. The documentation data base is divided into sections. The sections are listed by ACL2 Gold>:docs * Each section has a name, sect, and by typing ACL2 Gold>:docs sect or equivalently ACL2 Gold>:doc sect you will get an enumeration of the topics within that section. Those topics can be further explored by using :doc (and :more) on them. In fact the section name itself is just a documented name. :More generally gives an informal overview of the general subject of the section. ACL2 Gold>:docs ** will list all documented topics, by section. This fills several pages but might be a good place to start. If you want documentation on some topic, but none of our names or brief descriptions seem to deal with that topic, you can invoke a command to search the text in the data base for a given string. This is like the GNU Emacs ``apropos'' command. ACL2 Gold>:docs \"functional inst\" will list every documented topic whose :doc or :more-doc text includes the substring \"functional inst\", where case and the exact number of spaces are irrelevant. If you want documentation on an Acl2 function or macro and the documentation data base does not contain any entries for it, there are still several alternatives. ACL2 Gold>:args fn will print the arguments and some other relevant information about the named function or macro. This information is all gleaned from the definition (not from the documentation data base) and hence this is a definitive way to determine if fn is defined as a function or macro. You might also want to type: ACL2 Gold>:pc fn which will print the command which introduced fn. You should see :DOC command-descriptor for details on the kinds of input you can give the :pc command. The entire Acl2 documentation data base is user extensible. That is, if you document your function definitions or theorems, then that documentation is made available via the data base and its query commands. The implementation of our online documentation system makes use of Common Lisp's ``documentation strings.'' While Common Lisp permits a documentation string to be attached to any defined concept, Common Lisp assigns no interpretation to these strings. Acl2 attaches special significance to documentation strings that begin with the characters ``:Doc-Section''. When such a documentation string is seen, it is stored in the data base and may be displayed via :doc, :more, :docs, etc. Such documentation strings must follow rigid syntactic rules to permit their processing by our commands. These are spelled out in :DOC doc-string. A description of the structure of the documentation data base may also be found in :DOC doc-string.~/") (deflabel history :doc ":Doc-Section History Functions which Display or Change History~/~/ Acl2 keeps track of the commands that you have executed that have extended the logic or the rule data base, as by the definition of macros, functions, etc. Using the facilities in this section you can review the sequence of commands executed so far. For example, you can ask to see the most recently executed command, or the command 10 before that, or the command that introduced a given function symbol. You can also undo back through some previous command, restoring the logical world to what it was before the given command. Several technical terms are used in the documentation of the history commands. You must understand these terms to use the commands. These terms are documented via :doc entries of their own. See :DOC command, :DOC events, :DOC command-descriptor, and :DOC logical-name.~/") (deflabel Other :doc ":Doc-Section Other Other Commonly Used Top-Level Functions~/~/ This section contains an assortment of functions that fit into none of the other categories and yet are suffiently useful as to merit ``advertisement'' in the :help command.~/") #+acl2-logic-only (defmacro mutual-recursion (&whole event-form &rest rst) ":Doc-Section Events define some mutually recursive functions~/ Example: (mutual-recursion (defun evenlp (x) (if (consp x) (oddlp (cdr x)) t)) (defun oddlp (x) (if (consp x) (evenlp (cdr x)) nil)))~/ General Form: (mutual-recursion def1 ... defn) where each defi is a DEFUN form. When mutually recursive functions are introduced it is necessary to do the termination analysis on the entire clique of definitions. Each DEFUN form specifies its own measure, either with the :measure keyword xarg (see :DOC xargs) or by default to ACL2-COUNT. When a function in the clique calls a function in the clique, the measure of the callee's actuals must be smaller than the measure of the caller's formals -- just as in the case of a simply recursive function. But with mutual recursion, the callee's actuals are measured as specified by the callee's DEFUN while the caller's formals are measured as specified by the caller's DEFUN. These two measures may be different but must be comparable in the sense that E0-ORD-< decreases through calls. The guard analysis must also be done for all of the functions at the same time. If any one of the DEFUNs specifies the :color xarg to be :blue, then guard verification is omitted for all of the functions. Technical Note: Each defi above must be of the form (DEFUN ...). In particular, it is not permitted for a defi to be a form that will macroexpand into a DEFUN form. This is because MUTUAL-RECURSION is itself a macro, and since macroexpansion occurs from the outside in, at the time (MUTUAL-RECURSION def1 ... defk) is expanded the defi have not yet been. But MUTUAL-RECURSION must decompose the defi. We therefore insist that they be explicitly presented as DEFUNs. Suppose you have defined your own DEFUN-like macro and wish to use it in a MUTUAL-RECURSION expression. Well, you can't. (!) But you can define your own version of MUTUAL-RECURSION that allows your DEFUN-like form. Here is an example. Suppose you define (defmacro my-defun (&rest args) (my-defun-fn args)) where my-defun-fn takes the arguments of the MY-DEFUN form and produces from them a DEFUN form. As noted above, you are not allowed to write (MUTUAL-RECURSION (MY-DEFUN ...) ...). But you can define the macro my-mutual-recursion so that (my-mutual-recursion (my-defun ...) ... (my-defun ...)) expands into (mutual-recursion (defun ...) ... (defun ...)) by applying my-defun-fn to each of the arguments of my-mutual-recursion. (defun my-mutual-recursion-fn (lst) (declare (xargs :guard (alistp lst))) ; Each element of lst must be a consp (whose car, we assume, is always ; MY-DEFUN). We apply my-defun-fn to the arguments of each element and ; collect the resulting list of DEFUNs. (cond ((atom lst) nil) (t (cons (my-defun-fn (cdr (car lst))) (my-mutual-recursion-fn (cdr lst)))))) (defmacro my-mutual-recursion (&rest lst) ; Each element of lst must be a consp (whose car, we assume, is always ; MY-DEFUN). We obtain the DEFUN corresponding to each and list them ; all inside a MUTUAL-RECURSION form. (declare (xargs :guard (alistp lst))) (cons 'mutual-recursion (my-mutual-recursion-fn lst))).~/" (declare (xargs :guard (mutual-recursion-guardp rst))) (list 'defuns-fn (list 'quote (strip-cdrs rst)) 'state (list 'quote event-form))) ; Progn. ; The definition of er-progn-fn below exposes a deficiency in Acl2 not ; present in full Common Lisp, namely ACL2's inability to generate a ; really ``new'' variable the way one can in a Common Lisp macro via ; gensym. One would like to be sure that in binding the two variables ; er-progn-not-to-be-used-elsewhere-erp ; er-progn-not-to-be-used-elsewhere-val that they were not used ; anywhere in the subsequent macro expansion of lst. If one had the ; macro expansion of lst at hand, one could manufacture a variable ; that was not free in the expansion with genvars, and that would do. ; As a less than elegant rememdy to the situation, we introduce below ; the macro check-vars-not-free, which takes two arguments, the first ; a not-to-be-evaluated list of variable names and the second an ; expression. We arrange to return the translation of the expression ; provided none of the variables occur freely in it. Otherwise, an error ; is caused. The situation is subtle because we cannot even obtain ; the free vars in an expression until it has been translated. For ; example, (value x) has the free var STATE in it, thanks to the macro ; expansion of value. But a macro can't call translate because macros ; can't get their hands on state. ; In an earlier version of this we built check-vars-not-free into ; translate itself. We defined it with a defmacro that expanded to ; its second arg, but translate did not actually look at the macro ; (raw lisp did) and instead implemented the semantics described ; above. Of course, if no error was caused the semantics agreed with ; the treatment and if an error was caused, all bets are off anyway. ; The trouble with that approach was that it worked fine as long as ; check-vars-not-free was the only such example we had of needing to ; look at the translated form of something in a macro. Unfortunately, ; others came along. So we invented the more general ; translate-and-test and now use it to define check-vars-not-free. (mutual-recursion (defun weak-termp (x) (declare (xargs :color :red)) (cond ((atom x) (symbolp x)) ((eq (car x) 'quote) (and (consp (cdr x)) (null (cdr (cdr x))))) ((symbolp (car x)) (weak-termp-lst (cdr x))) (t (and (consp (car x)) (true-listp (car x)) (eq (car (car x)) 'lambda) (equal 3 (length (car x))) (symbolp-listp (car (cdr (car x)))) (weak-termp (car (cdr (cdr (car x))))) (weak-termp-lst (cdr x)) (equal (length (car (cdr (car x)))) (length (cdr x))))))) (defun weak-termp-lst (x) (declare (xargs :color :red)) (cond ((atom x) (equal x nil)) (t (and (weak-termp (car x)) (weak-termp-lst (cdr x)))))) ) (verify-termination (weak-termp (declare (xargs :color :blue))) (weak-termp-lst (declare (xargs :color :blue)))) (defthm weak-termp-lst-forward-to-true-listp (implies (weak-termp-lst x) (true-listp x)) :rule-classes :forward-chaining) (verify-guards weak-termp) (defun add-to-set-eq (x lst) (declare (xargs :guard (if (symbolp x) (true-listp lst) (symbolp-listp lst)))) (cond ((member-eq x lst) lst) (t (cons x lst)))) (defmacro variablep (x) (list 'atom x)) (defmacro fquotep (x) (list 'eq ''quote (list 'car x))) (defmacro ffn-symb (x) (list 'car x)) (defmacro fargs (x) (list 'cdr x)) (mutual-recursion (defun all-vars1 (term ans) (declare (xargs :guard (and (weak-termp term) (symbolp-listp ans)) :color :red)) (cond ((variablep term) (add-to-set-eq term ans)) ((fquotep term) ans) (t (all-vars1-lst (fargs term) ans)))) (defun all-vars1-lst (lst ans) (declare (xargs :guard (and (weak-termp-lst lst) (symbolp-listp ans)) :color :red)) (cond ((null lst) ans) (t (all-vars1-lst (cdr lst) (all-vars1 (car lst) ans))))) ) (verify-termination (all-vars1 (declare (xargs :color :blue))) (all-vars1-lst (declare (xargs :color :blue)))) ; It is IMPERATIVE that the following macro, when-cool, is ONLY used when its ; argument is a form that evaluates to an error triple. ; Keep this function in sync with boot-translate. (defmacro when-cool (x) (list 'if '(member-eq (default-color-from-state state) '(:red :pink)) '(mv nil nil state) x)) (local (encapsulate () ; It would probably be better to make all-vars1-all-vars1-lst local, ; since it's really not of any interest outside the guard verification ; of all-vars1. However, since we are passing through this file more ; than once, that does not seem to be an option. (defun all-vars1-all-vars1-lst (flg x ans) ;; flg is non-nil for all-vars1, nil for all-vars1-lst (declare (xargs :color :blue :measure (acl2-count x) :guard (and (if flg (weak-termp x) (weak-termp-lst x)) (symbolp-listp ans)))) (if flg (let ((term x)) (cond ((variablep term) (add-to-set-eq term ans)) ((fquotep term) ans) (t (all-vars1-all-vars1-lst nil (fargs term) ans)))) (let ((lst x)) (cond ((null lst) ans) (t (all-vars1-all-vars1-lst nil (cdr lst) (all-vars1-all-vars1-lst t (car lst) ans))))))) (local (defthm symbolp-listp-all-vars1-all-vars1-lst (implies (and (symbolp-listp ans) (if flg (weak-termp x) (weak-termp-lst x))) (symbolp-listp (all-vars1-all-vars1-lst flg x ans))))) (local (defthm symbolp-listp-all-vars1-all-vars1-lst-better (implies (and (equal temp (all-vars1-all-vars1-lst flg x ans)) (symbolp-listp ans) (if flg (weak-termp x) (weak-termp-lst x))) (symbolp-listp temp)))) (local (defthm all-vars1-all-vars1-lst-property (implies (and (symbolp-listp ans) (if flg (weak-termp x) (weak-termp-lst x))) (equal (all-vars1-all-vars1-lst flg x ans) (if flg (all-vars1 x ans) (all-vars1-lst x ans)))))) (local (in-theory (disable symbolp-listp-all-vars1-all-vars1-lst))) (defthm symbolp-listp-all-vars1 (implies (symbolp-listp ans) (and (implies (weak-termp x) (symbolp-listp (all-vars1 x ans))) (implies (weak-termp-lst x) (symbolp-listp (all-vars1-lst x ans))))) :hints (("Goal" :use ((:instance symbolp-listp-all-vars1-all-vars1-lst (flg t)) (:instance symbolp-listp-all-vars1-all-vars1-lst (flg nil))))) :rule-classes ((:forward-chaining :corollary (implies (and (symbolp-listp ans) (weak-termp x)) (symbolp-listp (all-vars1 x ans))) :trigger-terms ((all-vars1 x ans))) (:forward-chaining :corollary (implies (and (symbolp-listp ans) (weak-termp-lst x)) (symbolp-listp (all-vars1-lst x ans))) :trigger-terms ((all-vars1-lst x ans))))) ) ) (verify-guards all-vars1) (defun all-vars (term) ; This function collects the variables in term in reverse print order of ; first occurrence. E.g., all-vars of '(f (g a b) c) is '(c b a). ; This ordering is exploited by loop-stopper. (declare (xargs :guard (weak-termp term))) (all-vars1 term nil)) (defmacro translate-and-test (test-fn form) ; Test-fn should be a LAMBDA expression (or function or macro symbol) ; of one non-STATE argument, and form is an arbitrary form. Logically ; we ignore test-fn and return form. However, an error is caused by ; TRANSLATE if the translation of form is not "approved" by test-fn. ; By "approved" we mean that when (test-fn 'term) is evaluated, where ; term is the translation of form, (a) the evaluation completes ; without an error and (b) the result is T. Otherwise, the result is ; treated as an error msg and displayed. (Actually, test-fn's answer ; is treated as an error msg if it is a stringp or a consp. Any other ; result, e.g., T or NIL (!), is treated as "approved.") If test-fn ; approves then the result of translation is the translation of form. ; For example, ; (translate-and-test ; (lambda (term) ; (or (subsetp (all-vars term) '(x y z)) ; (msg "~p0 uses variables other than x, y, and z." ; term))) ;
) ; is just the translation of provided that translation ; only involves the free vars x, y, and z; otherwise an error is ; caused. By generating calls of this macro other macros can ; insure that the s they generate satisfy certain tests ; after those s are translated. ; This macro is actually implemented in translate. It can't be ; implemented here because translate isn't defined yet. However the ; semantics is consistent with the definition below, namely, it just ; expands to its second argument (which is, of course, translated). ; It is just that sometimes errors are caused. ; There are two tempting generalizations of this function. The first ; is that test-fn should be passed STATE so that it can make more ; "semantic" checks on the translation of form and perhaps so that it ; can signal the error error itself. There is, as far as I know, ; nothing wrong with this generalization except that it is hard to ; implement. In order for TRANSLATE to determine whether test-fn ; approves of the term it must ev an expression. If that expression ; involved STATE then translated must pass in its STATE in that ; position. This requires coercing the state to an object, an act ; which is done with some trepidation in trans-eval and which could, ; presumably, be allowed earlier in translate. ; The second tempting generalization is that test-fn should have the ; power to massage the translation and return a new form which should, ; in turn, be translated. For example, then one could imagine, say, a ; macro that would permit a form to be turned into the quoted constant ; listing the variables that occur freely in the translated form. If ; the first generalization above has been carried out, then this would ; permit the translation of a form to be state dependent, which is ; illegal. But this second generalization is problematic anyway. In ; particular, what is the raw lisp counterpart of the generalized ; macro? Note that in its current incarnation, the raw lisp ; counterpart of translate-and-test is the same as its logical ; meaning: it just expands to its second arg. But if the desired ; expansion is computed from the translation of its second arg, then ; raw lisp would have to translate that argument. But we can't do ; that for a variety of reasons: (a) CLTL macros shouldn't be state ; dependent, (b) we can't call translate during compilation because in ; general the Acl2 world isn't present, etc. (declare (ignore test-fn)) form) (defun intersectp-eq (x y) (declare (xargs :guard (and (symbolp-listp x) (symbolp-listp y)))) (cond ((null x) nil) ((member-eq (car x) y) t) (t (intersectp-eq (cdr x) y)))) (defun intersectp-equal (x y) (declare (xargs :guard (and (true-listp x) (true-listp y)))) (cond ((null x) nil) ((member-equal (car x) y) t) (t (intersectp-equal (cdr x) y)))) (defun make-fmt-bindings (chars forms) (declare (xargs :guard (and (true-listp chars) (true-listp forms) (<= (length forms) (length chars))))) (cond ((null forms) nil) (t (list 'cons (list 'cons (car chars) (car forms)) (make-fmt-bindings (cdr chars) (cdr forms)))))) (defmacro msg (str &rest args) ; This macro returns a pair suitable giving to the fmt directive ~@. Fmt is ; defined much later. But we need msg now because several of our macros ; generate calls of msg and thus msg must be a function when terms using those ; macros are translated. ; In any case, suppose that #\0, say, is bound to the value of this function. ; Then the fmt directive ~@0 will print out the string, str, above, in the ; context of the alist in which the successive fmt variables #\0 through ; possibly #\9 are bound to the successive elements of args. (declare (xargs :guard (<= (length args) 10))) `(cons ,str ,(make-fmt-bindings '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) args))) (defmacro check-vars-not-free (vars form) ; A typical use of this macro is (check-vars-not-free (my-erp my-val) ; ...) which just expands to the translation of ... provided my-erp ; and my-val do not occur freely in it. (declare (xargs :guard (symbolp-listp vars))) `(translate-and-test (lambda (term) (let ((vars ',vars)) (or (not (intersectp-eq vars (all-vars term))) (msg "It is forbidden to use ~v0 in ~p1." vars term)))) ,form)) (defun er-progn-fn (lst) (declare (xargs :guard (true-listp lst))) (cond ((null lst) nil) ((null (cdr lst)) (car lst)) (t (list 'mv-let '(er-progn-not-to-be-used-elsewhere-erp er-progn-not-to-be-used-elsewhere-val state) (car lst) (list 'if 'er-progn-not-to-be-used-elsewhere-erp '(mv er-progn-not-to-be-used-elsewhere-erp er-progn-not-to-be-used-elsewhere-val state) (list 'check-vars-not-free '(er-progn-not-to-be-used-elsewhere-erp er-progn-not-to-be-used-elsewhere-val) (er-progn-fn (cdr lst)))))))) (defmacro er-progn (&rest lst) (declare (xargs :guard (and (true-listp lst) lst))) (er-progn-fn lst)) #+acl2-logic-only (defmacro progn (&rest r) ; ?? Like defun, defmacro, and in-package, progn does not have quite ; the same semantics as the Common Lisp function. This is useful only ; for sequences at the top level. It permits us to handle things like ; type sets and records. (cons 'er-progn r)) (defun legal-case-clausesp (tl) (cond ((atom tl) (eq tl nil)) ((and (consp (car tl)) (or (eqlablep (car (car tl))) (eqlable-listp (car (car tl)))) (consp (cdr (car tl))) (null (cdr (cdr (car tl)))) (if (or (eq t (car (car tl))) (eq 'otherwise (car (car tl)))) (null (cdr tl)) t)) (legal-case-clausesp (cdr tl))) (t nil))) (defun case-test (x pat) (cond ((atom pat) (list 'eql x (list 'quote pat))) (t (list 'member x (list 'quote pat))))) (defun case-list (x l) (declare (xargs :guard (legal-case-clausesp l))) (cond ((null l) nil) ((or (eq t (car (car l))) (eq 'otherwise (car (car l)))) (list (list 't (car (cdr (car l)))))) ((null (car (car l))) (case-list x (cdr l))) (t (cons (list (case-test x (car (car l))) (car (cdr (car l)))) (case-list x (cdr l)))))) (defun case-list-check (l) (declare (xargs :guard (legal-case-clausesp l))) (cond ((null l) nil) ((or (eq t (car (car l))) (eq 'otherwise (car (car l)))) (list (list 't (list 'check-vars-not-free '(case-do-not-use-elsewhere) (car (cdr (car l))))))) ((null (car (car l))) (case-list-check (cdr l))) (t (cons (list (case-test 'case-do-not-use-elsewhere (car (car l))) (list 'check-vars-not-free '(case-do-not-use-elsewhere) (car (cdr (car l))))) (case-list-check (cdr l)))))) #+acl2-logic-only (defmacro case (&rest l) (declare (xargs :guard (and (consp l) (legal-case-clausesp (cdr l))))) (cond ((atom (car l)) (cons 'cond (case-list (car l) (cdr l)))) (t `(let ((case-do-not-use-elsewhere ,(car l))) (cond ,@(case-list-check (cdr l))))))) #+acl2-logic-only (progn (defmacro caar (x) (list 'car (list 'car x))) (defmacro cadr (x) (list 'car (list 'cdr x))) (defmacro cdar (x) (list 'cdr (list 'car x))) (defmacro cddr (x) (list 'cdr (list 'cdr x))) (defmacro caaar (x) (list 'car (list 'caar x))) (defmacro caadr (x) (list 'car (list 'cadr x))) (defmacro cadar (x) (list 'car (list 'cdar x))) (defmacro caddr (x) (list 'car (list 'cddr x))) (defmacro cdaar (x) (list 'cdr (list 'caar x))) (defmacro cdadr (x) (list 'cdr (list 'cadr x))) (defmacro cddar (x) (list 'cdr (list 'cdar x))) (defmacro cdddr (x) (list 'cdr (list 'cddr x))) (defmacro caaaar (x) (list 'car (list 'caaar x))) (defmacro caaadr (x) (list 'car (list 'caadr x))) (defmacro caadar (x) (list 'car (list 'cadar x))) (defmacro caaddr (x) (list 'car (list 'caddr x))) (defmacro cadaar (x) (list 'car (list 'cdaar x))) (defmacro cadadr (x) (list 'car (list 'cdadr x))) (defmacro caddar (x) (list 'car (list 'cddar x))) (defmacro cadddr (x) (list 'car (list 'cdddr x))) (defmacro cdaaar (x) (list 'cdr (list 'caaar x))) (defmacro cdaadr (x) (list 'cdr (list 'caadr x))) (defmacro cdadar (x) (list 'cdr (list 'cadar x))) (defmacro cdaddr (x) (list 'cdr (list 'caddr x))) (defmacro cddaar (x) (list 'cdr (list 'cdaar x))) (defmacro cddadr (x) (list 'cdr (list 'cdadr x))) (defmacro cdddar (x) (list 'cdr (list 'cddar x))) (defmacro cddddr (x) (list 'cdr (list 'cdddr x))) (defmacro first (x) (list 'car x)) (defmacro second (x) (list 'cadr x)) (defmacro third (x) (list 'caddr x)) (defmacro fourth (x) (list 'cadddr x)) (defmacro fifth (x) (list 'car (list 'cddddr x))) (defmacro sixth (x) (list 'cadr (list 'cddddr x))) (defmacro seventh (x) (list 'caddr (list 'cddddr x))) (defmacro eighth (x) (list 'cadddr (list 'cddddr x))) (defmacro ninth (x) (list 'car (list 'cddddr (list 'cddddr x)))) (defmacro tenth (x) (list 'cadr (list 'cddddr (list 'cddddr x)))) (defmacro rest (x) (list 'cdr x)) (defun identity (x) x) ) (defun nonnegative-integer-quotient (i j) (declare (xargs :guard (and (integerp i) (not (< i 0)) (integerp j) (< 0 j)) :color :red)) (if (< i j) 0 (+ 1 (nonnegative-integer-quotient (- i j) j)))) (verify-termination nonnegative-integer-quotient (declare (xargs :color :blue))) (verify-guards nonnegative-integer-quotient :hints (("Goal" :induct (nonnegative-integer-quotient i j)))) #+acl2-logic-only (progn (defun floor (i j) (declare (xargs :guard (and (rationalp i) (rationalp j) (not (eql j 0))))) (let* ((q (* i (/ j))) (n (numerator q)) (d (denominator q))) (cond ((= d 1) n) ((>= n 0) (nonnegative-integer-quotient n d)) (t (+ (- (nonnegative-integer-quotient (- n) d)) -1))))) (defun ceiling (i j) (declare (xargs :guard (and (rationalp i) (rationalp j) (not (eql j 0))))) (let* ((q (* i (/ j))) (n (numerator q)) (d (denominator q))) (cond ((= d 1) n) ((>= n 0) (+ (nonnegative-integer-quotient n d) 1)) (t (- (nonnegative-integer-quotient (- n) d)))))) (defun truncate (i j) (declare (xargs :guard (and (rationalp i) (rationalp j) (not (eql j 0))))) (let* ((q (* i (/ j))) (n (numerator q)) (d (denominator q))) (cond ((= d 1) n) ((>= n 0) (nonnegative-integer-quotient n d)) (t (- (nonnegative-integer-quotient (- n) d)))))) (defun round (i j) (declare (xargs :guard (and (rationalp i) (rationalp j) (not (eql j 0))))) (let* ((q (* i (/ j))) (n (numerator q)) (d (denominator q))) (cond ((= d 1) n) ((>= n 0) (let* ((fl (floor q 1)) (remainder (- q fl))) (cond ((> remainder 1/2) (+ fl 1)) ((< remainder 1/2) fl) (t (cond ((integerp (* fl (/ 2))) fl) (t (+ fl 1))))))) (t (let* ((cl (ceiling q 1)) (remainder (- q cl))) (cond ((< (- 1/2) remainder) cl) ((> (- 1/2) remainder) (+ cl -1)) (t (cond ((integerp (* cl (/ 2))) cl) (t (+ cl -1)))))))))) (defun mod (x y) (declare (xargs :guard (and (rationalp x) (rationalp y) (not (eql y 0))))) (- x (* (floor x y) y))) (defun rem (x y) (declare (xargs :guard (and (rationalp x) (rationalp y) (not (eql y 0))))) (- x (* (truncate x y) y))) (defun evenp (x) (declare (xargs :guard (integerp x))) (integerp (* x (/ 2)))) (defun oddp (x) (declare (xargs :guard (integerp x))) (not (evenp x))) (defun zerop (x) (declare (xargs :guard (acl2-numberp x) :color :gold)) (eql x 0)) (defun plusp (x) (declare (xargs :guard (rationalp x) :color :gold)) (> x 0)) (defun minusp (x) (declare (xargs :guard (rationalp x) :color :gold)) (< x 0)) (defun min (x y) (declare (xargs :guard (and (rationalp x) (rationalp y)))) (if (< x y) x y)) (defun max (x y) (declare (xargs :guard (and (rationalp x) (rationalp y)))) (if (> x y) x y)) (defun abs (x) (declare (xargs :guard (rationalp x))) ; From CLTL p. 205. Note that we do not allow complex x as an argument to abs ; in Acl2, because this would take us out of the realm of rational (complexes). (if (minusp x) (- x) x)) (defun signum (x) (declare (xargs :guard (rationalp x))) ; On CLTL p. 206 one sees the definition ; (if (zerop x) x (* x (/ (abs x)))). ; However, that suffers because it looks to type-set like it returns ; an arbitrary rational when in fact it returns -1, 0, or 1. So we ; give a more explicit definition. See the comment in abs for a ; justification for disallowing complex arguments. (if (zerop x) 0 (if (minusp x) -1 +1))) (defun lognot (i) (declare (xargs :guard (integerp i))) (+ (- i) -1)) ; This function is introduced now because we need it in the admission of ; logand. The admission of e0-ordinalp could be moved up to right ; after the introduction of the "and" macro. ) (defun e0-ordinalp (x) ":Doc-Section Miscellaneous a recognizer for the ordinals up to epsilon-0~/ Using the nonnegative integers and lists we can represent the ordinals up to epsilon-0. The Acl2 notion of ordinal is the same as that found in Nqthm-1992 and both are very similar to the development given in ``New Version of the Consistency Proof for Elementary Number Theory'' in The Collected Papers of Gerhard Gentzen, ed. M.E. Szabo, North-Holland Publishing Company, Amsterdam, 1969, pp 132-213.~/ The following essay is intended to provide intuition about ordinals. The Truth, of course, lies simply in the Acl2 definitions of E0-ORDINALP and E0-ORD-<. Very intuitively, think of each non-zero natural number as by being denoted by a series of the appropriate number of strokes, i.e., 0 0 1 | 2 || 3 ||| 4 |||| ... ... Then ``omega,'' here written as w, is the ordinal that might be written as w |||||..., i.e., an infinite number of strokes. Addition here is just concatenation. Observe that adding one to the front of w in the picture above produces w again, which gives rise to a standard definition of w: w is the least ordinal such that adding another stroke at the beginning does not change the ordinal. We denote by w+w or w*2 the ``doubly infinite'' sequence that we might write as follows. w*2 |||||... |||||... One way to think of w*2 is that it is obtained by replacing each stroke in 2 (||) by w. Thus, one can imagine w*3, w*4, etc., which leads ultimately to the idea of ``w*w,'' the ordinal obtained by replacing each stroke in w by w. This is also written as ``omega squared'' or w^2, or: 2 w |||||... |||||... |||||... |||||... |||||... ... We can analogously construct w^3 by replacing each stroke in w by w^2 (which, it turns out, is the same as replacing each stroke in w^2 by w). That is, we can construct w^3 as w copies of w^2, 3 2 2 2 2 w w ... w ... w ... w ... ... Then we can construct w^4 as w copies of w^3, w^5 as w copies of w^4, etc., ultimately suggesting w^w. We can then stack omegas, i.e., (w^w)^w etc. Consider the ``limit'' of all of those stacks, which we might display as follows. . . . w w w w w That is is epsilon-0. Below we begin listing some ordinals up to epsilon-0; the reader can fill in the gaps at his or her leisure. We show in the left column the conventional notation, using w as ``omega,'' and in the right column the Acl2 object representing the corresponding ordinal. ordinal Acl2 representation 0 0 1 1 2 2 3 3 ... ... w '(1 . 0) w+1 '(1 . 1) w+2 '(1 . 2) ... ... w*2 '(1 1 . 0) (w*2)+1 '(1 1 . 1) ... ... w*3 '(1 1 1 . 0) (w*3)+1 '(1 1 1 . 1) ... ... 2 w '(2 . 0) ... ... 2 w +w*4+3 '(2 1 1 1 1 . 3) ... ... 3 w '(3 . 0) ... ... w w '((1 . 0) . 0) ... ... w 99 w +w +4w+3 '((1 . 0) 99 1 1 1 1 . 3) ... ... 2 w w '((2 . 0) . 0) ... ... w w w '(((1 . 0) . 0) . 0) ... ... Observe that the sequence of E0-ORDINALPs starts with the nonnegative integers. This is convenient because it means that if a term, such as a measure expression for justifying a recursive function (see :DOC e0-ord-<) must produce an E0-ORDINALP it suffices for it to produce a nonnegative integer. The ordinals listed above are listed in ascending order. This is the ordering tested by E0-ORD-<. The ``epsilon-0 ordinals'' of Acl2 are recognized by the recursively defined function E0-ORDINALP. The base case of the recursion tells us that positive integers are epsilon-0 ordinals. Otherwise, an epsilon-0 ordinal is a cons pair (o1 . o2), where o1 is a non-0 epsilon-0 ordinal, o2 is an epsilon-0 ordinal, and if o2 is not an integer then its car (which, by the foregoing, must be an epsilon-0 ordinal) is no greater than o1. Thus, if you think of a (non-integer) epsilon-0 ordinal as a list, each element is an non-0 epsilon-0 ordinal, the ordinals are listed in weakly descending order, and the final cdr of the list is an integer. The function E0-ORD-< compares two epsilon-0 ordinals, x and y. If both are integers, E0-ORD-< is just x= x 0)))) ; Functions such as logand require significant arithmetic to prove. Therefore ; their "warming" will be deferred. #+acl2-logic-only (progn (defun expt (r i) ; CLtL2 (page 300) allows us to include complex rational arguments. (declare (xargs :guard (and (acl2-numberp r) (integerp i) (not (and (eql r 0) (< i 0)))) :measure (abs i))) (cond ((eql i 0) 1) ((eql r 0) 0) ((> i 0) (* r (expt r (+ i -1)))) (t (* (/ r) (expt r (+ i +1)))))) (defun logcount (x) (declare (xargs :guard (integerp x))) (cond ((< x 0) (logcount (lognot x))) ((= x 0) 0) ((evenp x) (logcount (nonnegative-integer-quotient x 2))) (t (1+ (logcount (nonnegative-integer-quotient x 2)))))) (defun listp (x) (declare (xargs :color :gold)) (or (consp x) (equal x nil))) (defun nthcdr (n l) (declare (xargs :guard (and (integerp n) (<= 0 n) (true-listp l)))) (if (eql n 0) l (nthcdr (+ n -1) (cdr l)))) (defun last (l) (declare (xargs :guard (listp l))) (if (atom (cdr l)) l (last (cdr l)))) (defun logbitp (i j) (declare (xargs :guard (and (integerp j) (integerp i) (>= i 0)) :color :red)) (oddp (floor j (expt 2 i)))) (defun ash (i c) (declare (xargs :guard (and (integerp i) (integerp c)) :color :red)) (floor (* i (expt 2 c)) 1)) ) ; John Cowles first suggested a version of the following lemma for rationals. (defthm expt-type-prescription-non-zero-base (implies (and (acl2-numberp r) (integerp i) (not (equal r 0))) (and (acl2-numberp (expt r i)) (not (equal (expt r i) 0)))) :rule-classes :type-prescription) (defthm expt-type-prescription-non-zero-base-rationalp-case (implies (and (rationalp r) (integerp i) (not (equal r 0))) (and (rationalp (expt r i)) (not (equal (expt r i) 0)))) :rule-classes :type-prescription) (verify-termination logbitp) (verify-termination ash) (encapsulate () (local (defthm nonnegative-integer-quotient-by-2-goes-down-1 (implies (and (integerp n) (< 0 n)) (< (nonnegative-integer-quotient n 2) n)) :rule-classes :linear)) (local (defthm nonnegative-integer-quotient-by-2-goes-down-2-lemma (implies (and (integerp n) (< 2 n)) (< (nonnegative-integer-quotient n 2) (+ -1 n))) :rule-classes nil)) (local (defthm nonnegative-integer-quotient-by-2-goes-down-2 (implies (and (integerp n) (not (integerp (* 1/2 n))) (< 0 n) (not (equal 1 n))) (< (nonnegative-integer-quotient (+ 1 n) 2) n)) :rule-classes :linear :hints (("Goal" :use ((:instance nonnegative-integer-quotient-by-2-goes-down-2-lemma (n (+ 1 n)))))))) (defun positive-integer-log2 (n) (declare (xargs :guard (and (integerp n) (< 0 n)) :color :blue)) (cond ((= n 1) 0) (t (1+ (positive-integer-log2 (nonnegative-integer-quotient (if (evenp n) n (1+ n)) 2)))))) ) (encapsulate () (local (defthm <-0-nonnegative-integer-quotient-by-2 (implies (and (integerp n) (< 0 n) (not (equal 1 n))) (< 0 (nonnegative-integer-quotient n 2))))) (defthm nonnegative-integerp-positive-integer-log2 (implies (and (force (integerp n)) (force (< 0 n))) (and (integerp (positive-integer-log2 n)) (<= 0 (positive-integer-log2 n)))) :rule-classes :type-prescription) (verify-guards positive-integer-log2) ) #+acl2-logic-only (defun integer-length (x) ; p. 361 of CLtL2 (declare (xargs :guard (integerp x))) (positive-integer-log2 (if (< x 0) (- x) (1+ x)))) (defun list*-macro (lst) (declare (xargs :guard (and (true-listp lst) (consp lst)))) (if (eq (cdr lst) nil) (car lst) (cons 'cons (cons (car lst) (cons (list*-macro (cdr lst)) nil))))) #+acl2-logic-only (defmacro list* (&rest args) (list*-macro args)) (defun hard-error () (declare (xargs :guard nil)) #-acl2-logic-only (acl2::interface-er "Hard error.") nil) (defun illegal (ctx str alist) ; We would like to use this function in :gold function definitions, but prove ; that it's never called. Thus we have to make this function gold, and its ; guard is then nil. (declare (xargs :guard nil)) #+acl2-logic-only (declare (ignore ctx str alist)) #-acl2-logic-only (cond ((fboundp 'acl2::error-fmt) (let ((*standard-output* *error-output*) (fn 'acl2::error-fmt)) (funcall fn t ctx str alist *the-live-state*))) (t (print (list ctx str alist) *error-output*))) (hard-error)) (defun translate-declaration-to-guard/integer (lo var hi) (let ((lower-bound (cond ((integerp lo) lo) ((eq lo '*) '*) ((and (consp lo) (integerp (car lo)) (null (cdr lo))) (1+ (car lo))) (t nil))) (upper-bound (cond ((integerp hi) hi) ((eq hi '*) '*) ((and (consp hi) (integerp (car hi)) (null (cdr hi))) (1- (car hi))) (t nil)))) (cond ((and upper-bound lower-bound) (cond ((eq lower-bound '*) (cond ((eq upper-bound '*) (list 'integerp var)) (t (list 'and (list 'integerp var) (list '<= var upper-bound))))) (t (cond ((eq upper-bound '*) (list 'and (list 'integerp var) (list '<= lower-bound var))) (t (list 'and (list 'integerp var) (list '<= lower-bound var) (list '<= var upper-bound))))))) (t nil)))) (defun translate-declaration-to-guard1 (x var) (cond ((or (eq x 'integer) (eq x 'signed-byte)) (list 'integerp var)) ((and (consp x) (eq (car x) 'integer) (true-listp x) (equal (length x) 3)) (translate-declaration-to-guard/integer (cadr x) var (caddr x))) ((eq x 'rational) (list 'rationalp var)) ((eq x 'complex) (list 'complex-rationalp var)) ((and (consp x) (eq (car x) 'rational) (true-listp x) (equal (length x) 3)) (let ((lower-bound (cond ((rationalp (cadr x)) (cadr x)) ((eq (cadr x) '*) '*) ((and (consp (cadr x)) (rationalp (car (cadr x))) (null (cdr (cadr x)))) (list (car (cadr x)))) (t nil))) (upper-bound (cond ((rationalp (caddr x)) (caddr x)) ((eq (caddr x) '*) '*) ((and (consp (caddr x)) (rationalp (car (caddr x))) (null (cdr (caddr x)))) (list (car (caddr x)))) (t nil)))) (cond ((and upper-bound lower-bound) (cond ((eq lower-bound '*) (cond ((eq upper-bound '*) (list 'rationalp var)) (t (list 'and (list 'rationalp var) (cond ((consp upper-bound) (list '< var (car upper-bound))) (t (list '<= var upper-bound))))))) (t (cond ((eq upper-bound '*) (list 'and (list 'rationalp var) (cond ((consp lower-bound) (list '< (car lower-bound) var)) (t (list '<= lower-bound var))))) (t (list 'and (list 'rationalp var) (cond ((consp lower-bound) (list '< (car lower-bound) var)) (t (list '<= lower-bound var))) (cond ((consp upper-bound) (list '> (car upper-bound) var)) (t (list '<= var upper-bound))))))))) (t nil)))) ((eq x 'bit) (list 'or (list 'equal var 1) (list 'equal var 0))) ((and (consp x) (eq (car x) 'mod) (true-listp x) (equal (length x) 2) (integerp (cadr x))) (translate-declaration-to-guard/integer 0 var (1- (cadr x)))) ((and (consp x) (eq (car x) 'signed-byte) (true-listp x) (equal (length x) 2) (integerp (cadr x)) (> (cadr x) 0)) (translate-declaration-to-guard/integer (- (expt 2 (1- (cadr x)))) var (1- (expt 2 (1- (cadr x)))))) ((eq x 'unsigned-byte) (translate-declaration-to-guard/integer 0 var '*)) ((and (consp x) (eq (car x) 'unsigned-byte) (true-listp x) (equal (length x) 2) (integerp (cadr x)) (> (cadr x) 0)) (translate-declaration-to-guard/integer 0 var (1- (expt 2 (cadr x))))) ((eq x 'atom) (list 'atom var)) ((eq x 'character) (list 'characterp var)) ((eq x 'cons) (list 'consp var)) ((eq x 'list) (list 'listp var)) ((eq x 'nil) ; We return a translated nil here instead of just nil so as not to ; look like we're saying "This is an unrecognized declaration." ''nil) ((eq x 'null) (list 'eq var nil)) ((eq x 'ratio) (list 'and (list 'rationalp var) (list 'not (list 'integerp var)))) ((eq x 'standard-char) (list 'standard-charp var)) ((eq x 'string) (list 'stringp var)) ((and (consp x) (eq (car x) 'string) (true-listp x) (equal (length x) 2) (integerp (cadr x)) (>= (cadr x) 0)) (list 'and (list 'stringp var) (list 'equal (list 'length var) (cadr x)))) ((eq x 'symbol) (list 'symbolp var)) ((eq x 't) t) ((and (consp x) (eq (car x) 'satisfies) (true-listp x) (equal (length x) 2) (symbolp (cadr x))) (list (cadr x) var)) ((and (consp x) (eq (car x) 'member) (eqlable-listp (cdr x))) (list 'member var (list 'quote (cdr x)))) (t nil))) (mutual-recursion (defun translate-declaration-to-guard (x var) ; This function is typically called on the sort of x you might write ; in a TYPE declaration, e.g., (DECLARE (TYPE x var1 ... varn)). ; Thus, x might be something like '(or symbol cons (integer 0 128)) ; meaning that var is either a symbolp, a consp, or an integer in the ; given range. X is taken as a declaration about the variable symbol ; var and is converted into an UNTRANSLATED term about var. (declare (xargs :measure (acl2-count x))) (cond ((atom x) (translate-declaration-to-guard1 x var)) ((eq (car x) 'not) (cond ((and (true-listp x) (equal (length x) 2)) (let ((term (translate-declaration-to-guard (cadr x) var))) (and term (list 'not term)))) (t nil))) ((eq (car x) 'and) (cond ((true-listp x) (cond ((null (cdr x)) t) (t (let ((args (translate-declaration-to-guard-lst (cdr x) var))) (cond (args (cons 'and args)) (t nil)))))) (t nil))) ((eq (car x) 'or) (cond ((true-listp x) (cond ((null (cdr x)) ''nil) (t (let ((args (translate-declaration-to-guard-lst (cdr x) var))) (cond (args (cons 'or args)) (t nil)))))) (t nil))) ((eq (car x) 'complex) (cond ((and (consp (cdr x)) (null (cddr x))) (list 'and (list 'complex-rationalp var) (translate-declaration-to-guard (cadr x) (list 'realpart var)) (translate-declaration-to-guard (cadr x) (list 'imagpart var)))) (t nil))) (t (translate-declaration-to-guard1 x var)))) (defun translate-declaration-to-guard-lst (l var) (declare (xargs :measure (acl2-count l) :guard (and (true-listp l) (consp l)))) (let ((frst (translate-declaration-to-guard (car l) var))) (cond ((null frst) nil) ((null (cdr l)) (list frst)) (t (let ((rst (translate-declaration-to-guard-lst (cdr l) var))) (cond ((null rst) nil) (t (cons frst rst)))))))) ) (deflabel declare :doc ":Doc-Section acl2::Miscellaneous declarations~/ Examples: (declare (ignore x y z)) (declare (ignore x y z) (type integer i j k) (type (satisfies integerp) m1 m2)) (declare (xargs :guard (and (integerp i) (<= 0 i)) :guard-hints ((\"Goal\" :use (:instance lemma3 (x (+ i j)))))))~/ General Form: (declare d1 ... dn) where, in Acl2, each di is of one of the following forms: (ignore v1 ... vn) -- where each vi is a variable bound in the immediately superior lexical environment. (type type-spec v1 ... vn) -- where each vi is a variable bound in the immediately superior lexical environment and type-spec is as described in :DOC type-spec. (xargs :key1 val1 ... :keyn valn) -- where the legal values of the keyi's and their respective vali's are given in :DOC xargs. Declarations in Acl2 may occur only where dcl occurs below: (DEFUN name args doc-string dcl ... dcl body) (DEFMACRO name args doc-string dcl ... dcl body) (LET ((v1 t1) ...) dcl ... dcl body) (MV-LET (v1 ...) term dcl ... dcl body) Of course, if a form macroexpands into one of these (as LET* expands into nested LETs and our ER-LET* expands into nested MV-LETs) then declarations are permitted as handled by the macros involved.~/") (deflabel type-spec :doc ":Doc-Section Miscellaneous type specifiers in declarations~/ Examples: The symbol INTEGER in (declare (type INTEGER i j k)) is a type-spec. Other type-specs supported by Acl2 include RATIONAL, COMPLEX, (INTEGER 0 127), (RATIONAL 1 *), CHARACTER, and ATOM. Type :more for a complete listing.~/ The type-specs and their meanings (when applied to the variable X as in (DECLARE (TYPE type-spec X))) are given below. type-spec meaning ATOM (ATOM X) BIT (OR (EQUAL X 1) (EQUAL X 0)) CHARACTER (CHARACTERP X) COMPLEX, (AND (COMPLEXP X) (COMPLEX RATIONAL) (RATIONALP (REALPART X)) (RATIONALP (IMAGPART X))) (COMPLEX type) (AND (COMPLEXP X) (p (REALPART X)) (p (IMAGPART X))) where (p x) is the meaning for type-spec type CONS (CONSP X) INTEGER (INTEGERP X) (INTEGER i j) (AND (INTEGERP X) ; See notes below (<= i X) (<= X j)) (MEMBER x1 ... xn) (MEMBER X '(x1 ... xn)) (MOD i) same as (INTEGER 0 i-1) NIL NIL NULL (EQ X NIL) RATIO (AND (RATIONALP X) (NOT (INTEGERP X))) RATIONAL (RATIONALP X) (RATIONAL i j) (AND (RATIONALP X) ; See notes below (<= i X) (<= X j)) (SATISFIES pred) (pred X) SIGNED-BYTE (INTEGERP X) (SIGNED-BYTE i) same as (INTEGER -2**i-1 (2**i-1)-1) STANDARD-CHAR (STANDARD-CHARP X) STRING (STRINGP X) (STRING max) (AND (STRINGP X) (EQUAL (LENGTH X) max)) SYMBOL (SYMBOLP X) T T UNSIGNED-BYTE same as (INTEGER 0 *) (UNSIGNED-BYTE i) same as (INTEGER 0 (2**i)-1) Notes: In general, (INTEGERP i j) means (AND (INTEGERP X) (<= i X) (<= X j)). But if i is the symbol *, the first inequality is omitted. If j is the symbol *, the second inequality is omitted. If instead of being an integer, the second element of the type specification is a list containing an integer, (i), then the first inequality is made strict. An analogous remark holds for the (j) case. The RATIONAL type specifier is similarly generalized.~/") (defun the-error (x y) (declare (xargs :guard nil)) (illegal nil "The object ~pa does not satisfy the declaration ~pb." (list 'list (list 'cons #\a y) (list 'cons #\b x)))) (defun the-fn (x y) (declare (xargs :guard (translate-declaration-to-guard x 'var))) (let ((guard (translate-declaration-to-guard x 'var))) ; Observe that we translate the type expression, x, wrt the variable var ; and then bind var to y below. It is logically equivalent to translate ; wrt to y instead and then generate the if-expression below instead of the ; let. Why do we do that? Because y (or var) is liable to occur many times ; in the guard (and one more time in the if) and if y is a huge expression we ; blow ourselves away there. A good example of this comes up if one ; translates the expression (the-type-set xxx). When we translated the ; declaration wrt to 'xxx we got an expression in which 'xxx occurred ; five times. By generating the let below, it occurs only once. ; We have tried an experiment in which we treat the (symbolp y) case ; specially: translate wrt to y and just lay down the if-expression ; (if guard y (the-error 'x y)). The system was able to do an :init, so ; this did not blow us out of the water -- as we know it does if you so ; treat all y's. But this IF-expressions in the guard are therefore ; turned loose in the surrounding term and contribute to the explosion of ; normalized bodies. So we have backtracked to this, which has the ; advantage of keeping the normalized sizes just linearly bigger. (cond ((null guard) (illegal nil "Illegal-type." (list (cons #\0 x)))) (t (list 'let (list (list 'var y)) (list 'if guard 'var (list 'the-error (list 'quote x) 'var))))))) #+acl2-logic-only (defmacro the (x y) (the-fn x y)) #-acl2-logic-only (defconstant *char-to-ascii* (make-array char-code-limit :initial-element 0 :element-type 'fixnum)) #-acl2-logic-only (eval-when (load) (setf (aref *char-to-ascii* (char-code #\Tab)) 9) (setf (aref *char-to-ascii* (char-code #\Newline)) 10) (setf (aref *char-to-ascii* (char-code #\Page)) 12) (setf (aref *char-to-ascii* (char-code #\Rubout)) 127) (do ((i 32 (1+ i)) (tl (cdr *standard-chars*) (cdr tl))) ((null tl)) (setf (aref *char-to-ascii* (char-code (car tl))) i))) (defun ascii-<-l (l1 l2 i) (declare (xargs :guard (and (eqlable-listp l1) (eqlable-listp l2) (integerp i)))) (cond ((null l1) (cond ((null l2) nil) (t i))) ((null l2) nil) ((eql (car l1) (car l2)) (ascii-<-l (cdr l1) (cdr l2) (+ i 1))) ((member (car l2) (cdr (member (car l1) *standard-chars*))) i) (t nil))) (defun ascii-<=-l (l1 l2 i) (declare (xargs :guard (and (eqlable-listp l1) (eqlable-listp l2) (integerp i)))) (cond ((null l1) i) ((null l2) nil) ((eql (car l1) (car l2)) (ascii-<=-l (cdr l1) (cdr l2) (+ i 1))) ((member (car l2) (member (car l1) *standard-chars*)) i) (t nil))) (defun ascii-< (str1 str2) (declare (xargs :guard (and (stringp str1) (stringp str2)))) #+acl2-logic-only (ascii-<-l (coerce str1 'list) (coerce str2 'list) 0) #-acl2-logic-only (let ((l1 (length str1)) (l2 (length str2)) (j 0)) (declare (fixnum l1 l2 j)) (let ((min (if (< l1 l2) l1 l2))) (declare (fixnum min)) (do ((i 0 (1+ i))) ((= i (the fixnum min))) (declare (fixnum i)) (let ((c1 (ascii-code (char str1 i))) (c2 (ascii-code (char str2 i)))) (declare (fixnum c1 c2)) (cond ((< c1 c2) (return-from ascii-< j)) ((> c1 c2) (return-from ascii-< nil))) (setq j (the fixnum (+ j 1))))) (cond ((< l1 l2) j) (t nil))))) (defun ascii-<= (str1 str2) (declare (xargs :guard (and (stringp str1) (stringp str2)))) #+acl2-logic-only (ascii-<=-l (coerce str1 'list) (coerce str2 'list) 0) #-acl2-logic-only (let ((l1 (length str1)) (l2 (length str2)) (j 0)) (declare (fixnum l1 l2 j)) (let ((min (if (< l1 l2) l1 l2))) (declare (fixnum min)) (do ((i 0 (1+ i))) ((= i (the fixnum min))) (declare (fixnum i)) (let ((c1 (ascii-code (char str1 i))) (c2 (ascii-code (char str2 i)))) (declare (fixnum c1 c2)) (cond ((< c1 c2) (return-from ascii-<= j)) ((> c1 c2) (return-from ascii-<= nil))) (setq j (the fixnum (+ j 1))))) (cond ((< l1 l2) j) ((> l1 l2) nil) (t j))))) (defun symbol-< (x y) (declare (xargs :guard (and (symbolp x) (symbolp y)))) (let ((x1 (symbol-name x)) (y1 (symbol-name y))) (or (ascii-< x1 y1) (and (equal x1 y1) (ascii-< (symbol-package-name x) (symbol-package-name y)))))) #+acl2-logic-only (defun revappend (x y) (declare (xargs :guard (true-listp x))) (if (null x) y (revappend (cdr x) (cons (car x) y)))) (defthm standard-char-listp-revappend (implies (and (standard-char-listp x) (standard-char-listp y)) (standard-char-listp (revappend x y))) :hints (("Goal" :in-theory (enable standard-char-listp)))) #+acl2-logic-only (defun reverse (x) (declare (xargs :guard (or (true-listp x) (stringp x)))) (cond ((stringp x) (coerce (revappend (coerce x 'list) nil) 'string)) (t (revappend x nil)))) #+acl2-logic-only (defun subsetp (x y) (declare (xargs :guard (if (eqlable-listp y) (true-listp x) (if (eqlable-listp x) (true-listp y) nil)))) (cond ((null x) t) (t (and (member (car x) y) (subsetp (cdr x) y))))) #+acl2-logic-only (defun sublis (alist tree) (declare (xargs :guard (eqlable-alistp alist))) (cond ((atom tree) (let ((pair (assoc tree alist))) (cond (pair (cdr pair)) (t tree)))) (t (cons (sublis alist (car tree)) (sublis alist (cdr tree)))))) #+acl2-logic-only (defun subst (new old tree) (declare (xargs :guard (eqlablep old))) (cond ((eql old tree) new) ((atom tree) tree) (t (cons (subst new old (car tree)) (subst new old (cdr tree)))))) (defmacro pprogn (&rest lst) ; The convention for pprogn usage is to give it a non-empty ; sequence of args, each of which (except for the last) returns state ; as its only value. The state returned by each but the last is ; passed on to the next. The value or values of the last form are ; returned as the value of the progn. (declare (xargs :guard (and lst (true-listp lst)))) (cond ((null (cdr lst)) (car lst)) (t (list 'let (list (list 'STATE (car lst))) (cons 'pprogn (cdr lst)))))) ; The Unwind-Protect Essay ; We wish to define an Acl2 macro form: ; (acl2-unwind-protect body cleanup1 cleanup2) ; with the following logical semantics ; (mv-let (erp val state) ; ,body ; (cond (erp (pprogn ,cleanup1 (mv erp val state))) ; (t (pprogn ,cleanup2 (mv erp val state))))) ; The idea is that it returns the 3 results of evaluating body except before ; propagating those results upwards it runs one of the two cleanup forms, ; depending on whether the body signalled an error. The cleanup forms return ; state. In typical use the cleanup forms restore the values of state global ; variables that were "temporarily" set by body. ; In addition, we want acl2-unwind-protect to handle aborts caused by the user ; during the processing of body and we want ev to handle acl2-unwind-protect ; "properly" in a sense discussed later. ; We deal first with the notion of the "proper" way to handle aborts. Because ; of the way acl2-unwind-protect is used, namely to "restore" a "temporarily" ; smashed state, aborts during body should not prevent the execution of the ; cleanup code. Intuitively, the compiled form of an acl2-unwind-protect ; ought to involve a Common Lisp unwind-protect. In fact, it does not, for ; reasons developed below. But it is easier to think about the correctness of ; our implementation if we start by thinking in terms of using a raw lisp ; unwind-protect in the macroexpansion of each acl2-unwind-protect. ; The (imagined) unwind-protect is almost always irrelevant because "errors" ; signalled by body are in fact not Lisp errors. But should the user cause an ; abort during body, the unwind-protect will insure that cleanup1 is executed. ; This is a logically arbitrary choice; we might have said cleanup2 is ; executed. By "insure" we mean not only will the Lisp unwind-protect fire ; the cleanup code even though body was aborted; we mean that the cleanup code ; will be executed without possibility of abort. Now there is no way to ; disable interrupts in CLTL. But if we make sufficient assumptions about the ; cleanup forms then we can effectively disable interrupts by executing each ; cleanup form repeatedly until it is executed once without being aborted. We ; might define "idempotency" to be just the necessary property: the repeated ; (possibly partial) execution of the form, followed by a complete execution ; of the form, produces the same state as a single complete execution. For ; example, (f-put-global 'foo 'old-val state) is idempotent but (f-put-global ; 'foo (1- (get-global 'foo state)) state) is not. Cleanup1 should be idempotent ; to insure that our implementation of unwind protect in the face of aborts is ; correct with respect to the (non-logical) semantics we have described. ; Furthermore, it bears pointing out that cleanup1 might be called upon to undo ; the work of a "partial" execution of cleanup2! This happens if the body ; completes normally and without signalling an error, cleanup2 is undertaken, ; and then the user aborts. So the rule is that if an abort occurs during an ; acl2-unwind-protect, cleanup1 is executed without interrupts. ; What, pray, gives us the freedom to give arbitrary semantics to ; acl2-unwind-protect in the face of an abort? We regard an abort as akin to ; unplugging the machine and plugging it back in. One should be thankful for ; any reasonable behavior and not quibble over whether it is the "logical" one ; or whether one ought to enforce informal rules like idempotency. Thus, we ; are not terribly sympathetic to arguments that this operational model is ; inconsistent with Acl2 semantics when the user types "Abort!" or doesn't ; understand unenforced assumptions about his cleanup code. All logical bets ; are off the moment the user types "Abort!". This model has the saving grace ; that we can implement it and that it can be used within the Acl2 system code ; to implement what we need during abort recovery. The operational model of ; an abort is that the machine finds the innermost acl2-unwind-protect, rips ; out of the execution of its body (or its cleanup code), executes the ; cleanup1 code with all aborts disabled and then propagates the abort upward. ; Now unfortunately this operational model cannot be implemented entirely ; locally in the compilation of an acl2-unwind-protect. Operationally, ; (acl2-unwind-protect body cleanup1 cleanup2) sort of feels like: ; (unwind-protect ,body ; (cond ( ,cleanup1 ) ; ( ,cleanup1 ) ; (t ,cleanup2 ))) ; where we do whatever we have to do to detect aborts and to pass aborts up in ; some cases and triples up in others. This can all be done with a suitable ; local nest of let, catch, unwind-protect, tests, and throw. But there is a ; problem: if the user is typing "Abort!" then what is to prevent him from ; doing it during the cleanup forms? Nothing. So in fact the sketched use of ; unwind-protect doesn't guarantee that the cleanup forms are executed fully. ; We have been unable to find a way to guarantee via locally produced compiled ; code that even idempotent cleanup forms are executed without interruption. ; Therefore, we take a step back and claim that at the top of the system is ; the Acl2 command interpreter. It will have an unwind-protect in it (quite ; probably the only unwind-protect in the whole system) and it will guarantee ; to execute all the cleanup forms before it prompts the user for the next ; expression to evaluate. An abort there will rip us out of the command ; interpreter. We shall arrange for re-entering it to execute the cleanup ; forms before prompting. If we imagine, again, that each acl2-unwind-protect ; is compiled into an unwind-protect, then since the aborts are passed up and ; the cleanup forms are each executed in turn as we ascend back to the top, ; the cleanup forms are just stacked. It suffices then for ; acl2-unwind-protect to push the relevant cleanup form (always form 1) on ; this stack before executing body and for the top-level to pop these forms ; and evaluate them one at a time before prompting for the next input. ; Actually, we must push the cleanup form and the current variable bindings in ; order to be able to evaluate the form "out of context." ; The stack in question is called *acl2-unwind-protect-stack*. It is really a ; stack of "frames". Each frame on the stack corresponds to a call of the ; general-purpose Acl2 read-eval-print loop. By so organizing it we can insure ; that each call of the read-eval-print loop manages its own unwind protection ; (in the normal case) while also insuring that the stack is global and visible ; to all. This allows each level to clean up after aborted inferiors what ; failed to clean up after themselves. ; One final observation is in order. It could be that there is no command ; interpreter because we are running an Acl2 application in raw lisp. In that ; case, "Abort!" means the machine was unplugged and all bets are off anyway. #-acl2-logic-only (defparameter *acl2-unwind-protect-stack* nil) #-acl2-logic-only (defparameter *ld-level* 0) ; The parameter above, *ld-level*, will always be equal to the number of ; recursive calls of LD and/or WORMHOLE we are in. Since each pushes a new frame on ; *acl2-unwind-protect-stack* the value of *ld-level* should always be the ; length of the stack. But *ld-level* is maintained as a special, i.e., it is ; always bound when we enter LD while the stack is a global. An abort may ; possibly rip us out of a call of LD, causing *ld-level* to decrease but not ; affecting the stack. It is this violation of the "invariant" between the two ; that indicates that the stack must be unwound some (to cleanup after an ; aborted inferior). (defmacro acl2-unwind-protect (explain-form body cleanup1 cleanup2) ; Note: If the names used for the erp and val results are changed in the #+ ; code, then change them in the #- code also. We use the same names (rather ; than using gensym) just because we know they are acceptable if translate ; approves the check-vars-not-free. ; Note: Keep this function in sync with translated-acl2-unwind-protectp4. That ; function not only knows the precise form of the expression generated below ; but even knows the variable names used! #+acl2-logic-only (declare (ignore explain-form)) #+acl2-logic-only `(mv-let (acl2-unwind-protect-erp acl2-unwind-protect-val state) (check-vars-not-free (acl2-unwind-protect-erp acl2-unwind-protect-val) ,body) (cond (acl2-unwind-protect-erp (pprogn (check-vars-not-free (acl2-unwind-protect-erp acl2-unwind-protect-val) ,cleanup1) (mv acl2-unwind-protect-erp acl2-unwind-protect-val state))) (t (pprogn (check-vars-not-free (acl2-unwind-protect-erp acl2-unwind-protect-val) ,cleanup2) (mv acl2-unwind-protect-erp acl2-unwind-protect-val state))))) ; The raw code is very similar. But it starts out by pushing onto the undo ; stack the name of the cleanup function and the values of the arguments. Note ; however that we do this only if the state is the live state. That is the ; only state that matters after an abort. Suppose unwind protected code is ; modifying some state object other than the live one (e.g., we are computing ; some explicit value during a proof). Suppose an abort occurs. Consider the ; operational model described: we rip out of the computation, execute the ; cleanup code for the nearest unwind protect, and then pass the abort upwards, ; continuing until we get to the top level. No state besides the live one is ; relevant because no value is returned from an aborted computation. The fake ; state cleaned up at each stop on the way up is just wasted time. So we don't ; push the cleanup code for fake states. If body concludes without an abort we ; execute the appropriate cleanup form and then we pop the undo stack (if we ; pushed something). Note that it is possible that body completes without ; error, cleanup2 is started (and begins smashing state) and then (perhaps even ; after the completion of cleanup2 but before the pop) an abort rips us out, ; causing cleanup1 to be executed after cleanup2. Idempotency is not enough to ; say. #-acl2-logic-only `(progn (cond ((live-state-p state) (push (cons ,explain-form (function (lambda nil ,cleanup1))) ; FUNCTION captures the binding environment in which cleanup1 would ; have been executed. So by applying the resulting function to no ; arguments we evaluate cleanup1 in the current environment. (car *acl2-unwind-protect-stack*)))) (mv-let (acl2-unwind-protect-erp acl2-unwind-protect-val state) ,body (cond (acl2-unwind-protect-erp (pprogn ,cleanup1 (cond ((live-state-p state) (pop (car *acl2-unwind-protect-stack*)) state) (t state)) (mv acl2-unwind-protect-erp acl2-unwind-protect-val state))) (t (pprogn ,cleanup2 (cond ((live-state-p state) (pop (car *acl2-unwind-protect-stack*)) state) (t state)) (mv acl2-unwind-protect-erp acl2-unwind-protect-val state))))))) #-acl2-logic-only (defun acl2-unwind (n flg) ; flg = nil, pop until length of stack is n. Do not mess with new top-most ; frame. ; flg = t, pop until the length of the stack is n and there is ; at most one form in the top-most frame. This configures the stack ; the way it was when frame n was first built. ; In all cases, no form is removed from the stack until the form has been ; executed. Thus, an interruption in this process will leave the still-undone ; cleanup forms on the stack for continued processing. ; There is a very odd aspect to this function: the value of each cleanup form ; is simply discarded! What is going on? To think about this it is clarifying ; first to consider the case of cleanup in the absence of aborts, i.e., to ; think about the logical semantics of unwind protection. Consider then ; (acl2-unwind-protect body cleanup1 cleanup2). Call the initial STATE st. ; Suppose body computes normally but returns (mv t nil st'). That is, body ; signals an error and returns a modified state (e.g., that has the error ; message printed to it). Then cleanup1 is executed on st' to produce st'' ; and then the error triple (mv t nil st'') is propagated upwards. Note that ; unlike all the other variables in the cleanup form, the STATE used by ; cleanup1 is the post-body value of the variable, not the pre-body value. ; Now reflect on our abort processing. Before body is executed we captured the ; binding environment in which cleanup1 would have been executed, except that ; that environment contains the pre-body value for STATE. If an abort occurs ; during body we evaluate the cleanup function on those saved values. ; Technically we should replace the value of STATE by the post-body state, st', ; produced by body before the abort. Technically we should then pass upward to ; the next cleanup form the state, st'', produced by the just executed cleanup ; form. ; What prevents us from having to do this is the fact that we are always ; cleaning up the live state and only the live state. The slot holding STATE ; in the environment captured by FUNCTION contains *the-live-state*, which is ; both the pre-body and post-body value of STATE. The result of the cleanup ; form is guaranteed to be *the-live-state*. And so it only looks like we are ; ignoring the values of the cleanup forms! (cond ((and (= (length *acl2-unwind-protect-stack*) n) (or (null flg) (null (car *acl2-unwind-protect-stack*)) (null (cdr (car *acl2-unwind-protect-stack*))))) nil) ((null (car *acl2-unwind-protect-stack*)) (pop *acl2-unwind-protect-stack*) (acl2-unwind n flg)) (t (let ((*wormholep* nil)) ; We bind *wormholep* to nil so that we do not try to store undo forms ; for the state changes we are about to make. (apply (cdr (car (car *acl2-unwind-protect-stack*))) ; The presence of explain-form requires us to take the cdr! nil)) (pop (car *acl2-unwind-protect-stack*)) (acl2-unwind n flg)))) ; The above function, acl2-unwind, will be called in the command interpreter ; before any command is read from the user. Thus, by the time a user command ; is executed we are guaranteed that all cleanup forms from the previous ; command have been completed, regardless of how often it and its cleanup forms ; were interrupted. This completes our consideration of user-caused aborts ; during the execution of Acl2 source or compiled code by the Common Lisp ; system. Now we turn to the even more complicated (!) business of the ; "correct" execution acl2-unwind-protect by Acl2's own EV. ; The code for EV is presented several files from here. But we discuss ; the design issues here while the previous discussion is still fresh. ; By way of foreshadowing, ev is an interpreter for the logic. ; The first problem is that when EV sees an acl2-unwind-protect it doesn't see ; an acl2-unwind-protect at all. It sees the translation of the macro ; expansion. To make matters worse, there are two translations of an MV-LET ; expression: one if the expression occurs inside a function definition (or is ; otherwise deemed "executable") and another if it does not. The functions ; translated-acl2-unwind-protectp and translated-acl2-unwind-protectp4 ; recognize and return the relevant parts of a translated acl2-unwind-protect. ; We can't define them here because they use case-match, which isn't yet ; defined. ; So imagine that EV encounters a translated acl2-unwind-protect form, say ; (acl2-unwind-protect body cleanup1 cleanup2). Of course, if the evaluation ; is error and abort free, then it is done correctly. If an abort occurs we ; are free (by the unplugging argument) to do whatever we want. But what ; should EV do if there is some kind of an evaluation error in body? For ; example, suppose body calls an undefined function or violates some guard. A ; simple concrete question is "what should EV return on ; (acl2-unwind-protect (mv nil (car 0) state) ; (f-put-global 'foo 'error state) ; (f-put-global 'foo 'no-error state))?" ; For what it is worth, our answer to this concrete question is: ; (mv t "guard violation msg for car" (f-put-global 'foo 'error state)). ; To discuss this, we have to tip-toe carefully around a variety of "errors." ; Let us review EV's functionality. ; EV returns (mv erp val lsr), where val is the value of the given form when ; erp is nil. If the form returns multiple values, then val is the ; corresponding list. Note well: if form returns an error triple, then the ; error flag of that triple is the car of val, not erp. If erp is t, then some ; sort of "evaluation error" occurred (such as a udf, ubv or guard violation) ; and val is an error message. Lsr is the "last state returned" during the ; attempted evaluation of body. We distinguish "evaluation errors" (erp = t) ; from the "programmed errors" that may be signaled by some bodys (erp = nil, ; (length val) = 3, lsr /= nil, (nth 0 val) = t, (nth 2 val) = lsr). ; It is useful to draw an analogy between Common Lisp execution of Acl2 source ; code and the EV interpretation of such code. In that analogy, EV's ; "evaluation errors" correspond to "aborts" and "hard errors," while EV's ; "programmed errors" correspond to "soft errors." It is this analogy that ; guides us in the design of EV. What does EV do if an evaluation error occurs ; during body? Consider the analogy: if Common Lisp gets a hard error during ; the evaluation of body, it evaluates cleanup1 and then passes the hard error ; up. Therefore, if EV gets an evaluation error during the evaluation of body, ; it evaluates cleanup1 and then passes the evaluation error up. In ; particular, if the attempt to eval body produces (mv t "msg" lsr') then EV ; returns (mv t "msg" lsr''), where lsr'' is obtained by evaluating cleanup1 ; with STATE bound to lsr'. This is analogous to what Common Lisp does for the ; live state. EV can do it for any state (live or otherwise) because it is ; tracking explicitly "the last returned state" during the computation, while ; Common Lisp is not. Furthermore, Common Lisp need not pass non-live states ; up since it is only the cleaned up live state that matters -- no other value ; is returned from aborted computations. But EV may be called by Acl2 code ; that makes use of the last state returned during the computation. ; If we could stop here the situation would be pretty neat. But there is more. ; EV must deal with a third kind of error: true aborts. We have just spoken of ; evaluation errors (i.e., guard violations and other errors detected by EV ; during evaluation) and of programmed errors signaled by the code EV is ; evaluating. But what if the user types "Abort?" Certainly neither EV nor ; its caller "catches" the abort: we just rip our way up through the unwind ; protects. But if EV was being used to modify the live state in an unwind ; protected way, those cleanup forms must be evaluated. This is just another ; way of saying that EV's interpretation of acl2-unwind-protect must be phrased ; in terms of acl2-unwind-protect just so that the live state is cleaned up ; after aborts. We can't actually do that because acl2-unwind-protect is too ; structured and insists that we deal with (mv erp val state) triples when EV ; is dealing with (mv erp (mv erp val lsr) lsr) triples. But we use the same ; raw mechanism of the *acl2-unwind-protect-stack*. ; Now the question arises, "what gives us the right to design EV by ; analogy?" The spec for EV is that it returns the correct value when ; it reports no error (returned erp = nil). When an evaluation error ; is reported then all bets are off, i.e., the plug was pulled, and we ; can pretty much return the lsr we want, as long as it is, indeed, ; the last state returned. ; This completes the unwind-protect essay. There are some additional comments ; in the code for EV. ; --------------------------------------------------------------------------- ; The *initial-event-defmacros* Discussion ; Lasciate ogni speranza, voi ch' entrate ; The following sequence of defmacros is critically important during ; boot strapping because they define the macros we have been using all ; this time! In fact, this very sequence of forms appears elsewhere in ; this system as a quoted list of constants, *initial-event-defmacros*. ; We'll present the defmacros first and then explain the rules for ; adding to or changing them. See also the discussion at ; *initial-event-defmacros*. #+acl2-logic-only (defmacro in-package (str) ;See note below. ":Doc-Section acl2::Miscellaneous select current package~/ Example: (in-package \"MY-PKG\")~/ General Form: (in-package str) where str is a string that names an existing Acl2 package, i.e., one of the initial packages such as \"KEYWORD\" or \"ACL2\" or a package introduced with DEFPKG. For a complete list of the known packages created with DEFPKG, evaluate (strip-cars (known-package-alist state)). See :DOC defpkg. IN-PACKAGE forms can only be typed at the top-level of the Acl2 loop and as the first form in a file being loaded or compiled." (list 'in-package-fn (list 'quote str) 'state)) #+acl2-logic-only (defmacro defpkg (&whole event-form name form &optional doc) ":Doc-Section Events define a new symbol package~/ Example: (defpkg \"MY-PKG\" (union-eq *acl2-exports* *common-lisp-symbols-from-main-lisp-package*))~/ General Form: (defpkg \"name\" term doc-string) where \"name\" is a string that names the package to be created, term is a variable-free expression that evaluates to a list of symbols (no two of which have the same symbol-name) to be imported into the newly created package, and doc-string is an optional documentation string as described in :DOC doc-string. The name of the new package must be ``new:'' the host lisp must not contain any package of that name. There are two exceptions to this newness rule, discussed at the end of this documentation. DEFPKG forms can be entered at the top-level of the Acl2 command loop. They should occur in a file only if the file is not to be compiled and contains nothing besides DEFPKG and IN-PACKAGE forms. After a successful DEFPKG it is possible to INTERN a string into the named package, e.g., (intern \"ABC\" \"MY-PKG\"). If the given string is the symbol name of any symbol in the imports list of the named package, intern returns the corresponding symbol (which is unique by the restriction on term above). Otherwise, intern returns a symbol in the named package. DEFPKG is the only means by which an Acl2 user can create a new package or specify what it imports. That is, Acl2 does not support the Common Lisp functions make-package or import. Currently, Acl2 does not support exporting at all. We now explain the two exceptions to the newness rule for package names. The careful experimenter will note that if a package is created with a DEFPKG that is subsequently undone, the host lisp system will contain the created package even after the undo. This is because CLTL1 does not provide a means of deleting packages. However, because Acl2 can clean out the package with unintern and reset the imports list arbitrarily, it is possible to reuse such an old package. Thus, the first exception to the rule is that name is allowed to be the name of an existing package if that package was created by an undone DEFPKG. This exception does not violate the spirit of the newness rule, since one is disinclined to believe in the existence of undone packages. The second exception is that name is allowed to be the name of an existing package if the package was created by a DEFPKG with identical imports. That is, it is permissible to execute ``redundant'' DEFPKG commands. The redundancy test is based on the values of the two import forms, not on the forms themselves.~/" (list 'defpkg-fn ;See note below. (list 'quote name) (list 'quote form) 'state (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro defun (&whole event-form &rest def) ;See note below. ":Doc-Section acl2::Events define a function symbol~/ Examples: (defun app (x y) (if (consp x) (cons (car x) (app (cdr x) y)) y)) (defun fact (n) (declare (xargs :guard (and (integerp n) (>= n 0)))) (if (= n 0) (* n (fact (1- n))) 1))~/ General Form: (defun fn (var1 ... varn) doc-string dcl ... dcl body), where fn is the symbol you wish to define and is a new symbolic name (see :DOC name), (var1 ... varn) is its list of formal parameters (see :DOC name), and body is its body. The definitional is logically admissible provided certain restrictions are met. These are sketched below. Note that Acl2 does not support the use of lambda-list keywords (such as &optional) in the formals list of functions. We do support some such keywords in macros and often you can achieve the desired syntax by defining a macro in addition to the general version of your function. See :DOC defmacro. The documentation string, doc-string, is optional and is described in :DOC doc-string. The declarations, dcl, are also optional and are described in :DOC declare. If multiple dcl forms appear, they are effectively grouped together as one. Perhaps the most commonly used Acl2 specific declaration is of the form (DECLARE (XARGS :guard g :measure m)). This declaration in the defun of some function fn has the effect of making the ``guard'' for fn be the term g and the ``measure'' be the term m. The notions of ``guard'' and ``measure'' are crucial to Acl2's definitional principle. We now briefly discuss the Acl2 definitional principle, using the following definition form which is offered as a more or less generic example. (defun fn (x y) (declare (xargs :guard (g x y) :measure (m x y))) (if (test x y) (stop x y) (step (fn (d x) y)))) Note that in our generic example, fn has just two arguments, x and y, the guard and measure terms involve both of them, and the body is a simple case split on (test x y) leading to a ``non-recursive'' branch, (stop x y), and a ``recursive'' branch. In the recursive branch, fn is called after ``decrementing'' x to (d x) and some step function is applied to the result. Of course, this generic example is quite specific in form but is intended to illustrate the more general case. Provided this definition is admissible under the logic, as outlined below, it adds the axiom to the logic Defining Axiom: (fn x y) = (if (g x y) (if (test x y) (stop x y) (step (fn (d x) y))) #) where # is a term (actually an application of the uninterpretted function symbol APPLY) about which the axioms of Acl2 tell us almost nothing. That is, for any ``actuals'' a and b, if (g a b) is true, then (fn a b) = (if (test a b) (stop a b) (step (fn (d a) b))). On the other hand, if (g a b) is not true, then the definining axiom tells us ``almost nothing'' about (fn a b). By ``almost nothing'' here we mean that we know nothing about (fn a b) that is not true of an arbitrary, undefined two argument function. For example, the axioms allow us to prove that (fn a b) = (fn a b), naturally. This defining axiom is actually implemented in the Acl2 system by a :DEFINITION rule, namely (implies (force (g x y)) (equal (fn x y) (if (test a b) (stop a b) (step (fn (d a) b))))). See :DOC definition for a discussion of how definition rules are applied. Roughly speaking, the rule causes certain instances of (fn x y) to be replaced by the corresponding instances of the body above. This is called ``opening up'' (fn x y). The instances of (fn x y) opened are chosen primarily by heuristics which determine that the recursive calls of fn in the opened body (after simplification) are more desirable than the unopened call of fn. Furthermore, if the corresponding instance of the guard (g x y) cannot be established at the time of opening, then it is assumed (see :DOC force). The system will later cause a case split in which it brings all of its resources to bear on the establishment of (g x y) in this context. Thus, if you define a function with a guard it behooves you to insure that every time that function is called Acl2 can establish that the guard is satisfied. This discussion has assumed that the definition of fn was admissible. Exactly what does that mean? First, fn must be a previously unaxiomatized function symbol (however, see :DOC ld-redefinition-action). Second, the formal parameters must be distinct variable names. Third, the guard, measure, and body should all be terms and should mention no free variables except the formal parameters. Thus, for example, body may not contain references to ``global'' or ``special'' variables; Acl2 constants or additional formals should be used instead. The final conditions on admissibility concern the termination of the recursion. Roughly put, all applications of fn satisfying the guard must terminate. More formally, the measure term m must always produce an ordinal less than e0 (``epsilon naught''), i.e., an object satisfying e0-ordinalp. See :DOC e0-ordinalp. In addition, m must decrease according the well-founded relation e0-ord-< in each recursive call, under the hypothesis that the guard g is satisfied and all the tests governing the call are satisfied. For example, for our generic definition of fn above, with measure term (m x y), two theorems must be proved. The first establishes that m produces an ordinal: (e0-ordinalp (m x y)). The second shows that m decreases in the (only) recursive call of fn: (implies (and (g x y) (not (test x y))) (e0-ord-< (m (d x) y) (m x y))). Observe that in the latter formula we must show that the ``m-size'' of (d x) and y is ``smaller than'' the m-size of x and y, provided the guard holds for x and y and the test, (test x y), in the body fails, thus leading to the recursive call (fn (d x) y). See :DOC e0-ord-< for a discussion of this notion of ``smaller than.'' It should be noted that the most commonly used ordinals are the natural numbers and that on natural numbers, e0-ord-< is just the familiar < relation. Thus, it is very common to use a measure m that returns a nonnegative integer, for then (e0-ordinalp (m x y)) becomes a simple conjecture about the type of m and the second formula above becomes a conjecture about the less-than relationship of nonnegative integer arithmetic. The most commonly used measure function is acl2-count, which computes a nonnegative integer size for all Acl2 objects. See :DOC acl2-count. Probably the most common recursive scheme in Lisp programming is when some formal is supposed to be a list and in the recursive call it is replaced by its cdr. For example, (test x y) might be simply (atom x) and (d x) might be (cdr x). In that case, (acl2-count x) is a suitable measure because the acl2-count of a cons is strictly larger than the acl2-counts of its car and cdr. Thus, ``recursion by car'' and ``recursion by cdr'' are trivially admitted if acl2-count is used as the measure and the definition protects every recursive call by a test insuring that the decremented argument is a consp. Similarly, ``recursion by 1-'' in which a positive integer formal is decremented by one in recursion, is also trivially admissible. See :DOC built-in-clauses to extend the class of trivially admissible recursive schemes. This completes the brief sketch of the Acl2 definitional principle. The following example illustrates all of the available declarations, xargs, and hints, but is completely nonsensical. (defun example (x y z a b c i j) (declare (ignore a b c) (type integer i j) (xargs :guard (symbolp x) :measure (- i j) :hints ((\"Goal\" :do-not-induct t :do-not '(generalize fertilize) :expand ((assoc x a) (member y z)) :hands-off (length binary-append) :in-theory (set-difference-theories (current-theory :here) '(assoc)) :induct (and (nth n a) (nth n b)) :use ((:instance assoc-of-append (x a) (y b) (z c)) (:functional-instance (:instance p-f (x a) (y b)) (p consp) (f assoc))))) :guard-hints ((\"Subgoal *1/3'\" :use ((:instance assoc-of-append (x a) (y b) (z c))))) :color :blue :otf-flg t)) (example-body x y z i j))~/" (list 'defun-fn (list 'quote def) 'state (list 'quote event-form))) #+acl2-logic-only (defmacro defuns (&whole event-form &rest def-lst) ;See note below ":Doc-Section Miscellaneous an alternative to MUTUAL-RECURSION~/ Example: (DEFUNS (evenlp (x) (if (consp x) (oddlp (cdr x)) t)) (oddlp (x) (if (consp x) (evenlp (cdr x)) nil)))~/ General Form: (DEFUNS defuns-tuple1 ... defuns-tuplen) is equivalent to (MUTUAL-RECURSION (DEFUN . defuns-tuple1) ... (DEFUN . defuns-tuplen)) In fact, DEFUNS is the more primitive of the two and MUTUAL-RECURSION is just a macro that expands to a call of DEFUN after stripping off the DEFUN at the car of each argument to MUTUAL-RECURSION. We provide and use MUTUAL-RECURSION rather than DEFUNS because by leaving the DEFUNs in place, MUTUAL-RECURSION forms can be processed by the Emacs TAGS program. See :DOC mutual-recursion." (list 'defuns-fn (list 'quote def-lst) 'state (list 'quote event-form))) #+acl2-logic-only (defmacro verify-termination (&whole event-form &rest lst) ":Doc-Section Events cool a hot function~/ Examples: (verify-termination fact) (verify-termination fact (declare (xargs :guard (integerp x) (>= x 0))))~/ General Forms: (verify-termination fn dcl ... dcl) (verify-termination (fn1 dcl ... dcl) (fn2 dcl ... dcl) ...) where fn and the fni are hot (:red or :pink) function symbols and all of the dcls are either DECLARE forms or documentation strings. The first form above is an abbreviation for (verify-termination (fn dcl ... dcl)) so we limit our discussion to the second form. Each of the fni must be in the same clique of mutually recursively defined functions, but not every function in the clique need be among the fni. Verify-termination attempts to establish the admissibility of the fni. Since the fni are currently hot, there are no axioms about them and it is legal to redefine them arbitrarily provided their signatures do not change. (See :DOC ld-redefinition-action.) Therefore, verify-termination retrieves their hot definitions, creates a modified definition using the dcls supplied above, and resubmits that definition. You could avoid using verify-termination by typing the new definition yourself. So in that sense, verify- termination adds no new functionality. But if you have prototyped your system in :red and tested it, you can use verify-termination to resubmit your definitions and change their :colors to :blue or :gold, addings guards and hints without having to retype or recopy the code. The defun command executed by verify-termination is obtained by retrieving the defun (or mutual-recursion) command that introduced the clique in question and then possibly modifying each definition as follows. Consider a function, fn, in the clique. If fn is not among the fni above, its definition is left unmodified. Otherwise, fn is some fni and we modify its definition by inserting into it the corresponding dcls listed with fni in the arguments to verify- termination. In addition, we throw out from the old declarations in fn the :color specification and anything that is specified in the new dcls. For example, suppose that fact was introduced with: (defun fact (n) (declare (type integer n) (xargs :color :red)) (if (= n 0) 1 (* n (fact (1- n))))). Suppose later we do (verify-termination fact) when the default-color is :gold. Then the following definition is submitted (defun fact (n) (declare (type integer n)) (if (= n 0) 1 (* n (fact (1- n))))) Observe that this is the same definition as the original one, except the old specification of the :color has been deleted so that the color now defaults to :gold. This definition will fail because the guard (integerp n) is insufficient to insure termination. We might therefore next invoke (verify-termination fact (declare (xargs :guard (>= n 0)))) which will submit the definition (defun fact (n) (declare (xargs :guard (>= n 0))) (declare (type integer n)) (if (= n 0) 1 (* n (fact (1- n))))) Observe that the declaration in the verify-termination command has been inserted into the definition. The termination proof can be carried out but this event nevertheless fails because the desired color is :gold and the system cannot prove the guard conditions for fact. Therefore, we might finally invoke (verify-termination fact (declare (xargs :guard (>= n 0) :color :blue))) which will submit (defun fact (n) (declare (xargs :guard (>= n 0) :color :blue)) (declare (type integer n)) (if (= n 0) 1 (* n (fact (1- n))))) and succeed. Sometimes you will find that it is impossible to use verify- termination because you cannot describe to it the modification you want to make on the existing hot definition. In that case you will have to submit the appropriate definition." (list 'verify-termination-fn (list 'quote lst) 'state (list 'quote event-form))) #+acl2-logic-only (defmacro verify-guards (&whole event-form name &key hints otf-flg doc) ":Doc-Section Events verify the guards of a function~/ Examples: (verify-guards flatten) (verify-guards flatten :hints ((\"Goal\" :use (:instance assoc-of-app))) :otf-flg t :doc \"string\")~/ General Form: (verify-guards name :hints hints :otf-flg otf-flg :doc doc-string) where name is the name of a :blue function, each subroutine of which is :gold, hints and otf-flg are as described in the corresponding :doc entries and doc-string, if supplied, is a string NOT beginning with ``:Doc-Section''. The three keyword arguments above are all optional. Verify-guard will attempt to prove that the guard on the named function implies the guards of all of the subroutines called in the body of the function. If successful, name is recolored :gold. If name is one of several functions in a mutually recursive clique, verify-guards will attempt to verify the guards of all of the functions. Because name is not uniquely associated with the verify-guard event (it necessarily names a previously defined function) the documenta- tion string, doc-string, is not stored in the documentation data base. Thus, we actually prohibit doc-string from having the form described in :DOC doc-string. Verify-guards must often be used when the value of a recursive call of a defined function is given as an argument to a subroutine that is guarded. An example of such a situation is given below. Suppose APP (read ``append'') has a guard requiring its first argument to be a true-listp. Consider (defun rev (x) (declare (xargs :guard (true-listp x))) (cond ((null x) nil) (t (app (rev (cdr x)) (list (car x)))))) Observe that the value of a recursive call of rev is being passed into a guarded subroutine, app. In order to verify the guards of this definition we must show that (rev (cdr x)) produces a true-listp, since that is what the guard of app requires. How do we know that (rev (cdr x)) is a true-listp? The most elegant argument is a two-step one, appealing to the following two lemmas: (1) When x is a true-listp, (cdr x) is a true-listp. (2) When z is a true-listp, (rev z) is a true-listp. But the second lemma is a generalized property of rev, the function we are defining. This property could not be stated before rev is defined and so is not known to the theorem prover when rev is defined. Therefore, we might break the admission of rev into three steps: define rev without addressing its guard verification, prove some general properties about rev, and then verify the guards. This can be done as follows: (defun rev (x) (declare (xargs :guard (true-listp x) :color :blue)) ; Note this additional xarg. (cond ((null x) nil) (t (app (rev (cdr x)) (list (car x)))))) (verify-guards rev) The Acl2 system can actually admit the original definition of rev, verifying the guards as part of the defun event. The reason is that, in this particular case, the system's generalization heuristics just happen to hit upon the lemma true-listp-rev. But in many more complicated functions it is necessary for the user to formulate the inductively provable properties before guard verification is attempted.~/" ;See note below (list 'verify-guards-fn (list 'quote name) 'state (list 'quote hints) (list 'quote otf-flg) (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro defmacro (&whole event-form &rest mdef) ;See note below. ":Doc-Section acl2::Events define a macro~/ Example Defmacros: (defmacro xor (x y) (list 'if x (list 'not y) y)) (defmacro git (sym key) (list 'getprop sym key nil ''current-acl2-world '(w state))) (defmacro one-of (x &rest rst) (declare (xargs :guard (symbolp-listp rst))) (cond ((null rst) nil) (t (list 'or (list 'eq x (list 'quote (car rst))) (list* 'one-of x (cdr rst)))))) Example Expansions: term macroexpansion (xor a b) (if a (not b) b) (xor a (foo b)) (if a (not (foo b)) (foo b)) (git 'car 'lemmas) (getprop 'car 'lemmas nil 'current-acl2-world (w state)) (one-of x a b c) (or (eq x 'a) (or (eq x 'b) (or (eq x 'c) nil))) (one-of x 1 2 3) ill-formed (guard violation)~/ General Form: (defmacro name macro-args doc-string dcl ... dcl body) where name is a new symbolic name (see :DOC name), macro-args is as described by :DOC macro-args and specifies the formals of the macro, and body is a term. Doc-string is an optional documentation string as described by :DOC doc-string. Each dcl is an optional declaration as decribed by :DOC declare except that the only xargs keyword permitted by defmacro is :guard. Macroexpansion occurs when a form is read in, i.e., before the evaluation or proof of that form is undertaken. To experiment with macroexpansion, see :DOC trans. When a form whose car is name arises as the form is read in, the arguments are bound as described in CLTL pp. 60 and 145, the guard is checked, and then the body is evaluated. The result is used in place of the original form. In Acl2, macros do not have access to STATE. That is, STATE is not among the formal parameters. This is in part a reflection of CLTL, pp. 143, ``More generally, an implementation of Common Lisp has great latitude in deciding exactly when to expand macro calls with a program. ... Macros should be written in such a way as to depend as little as possible on the execution environment to produce a correct expansion.'' In Acl2, the product of macroexpansion is independent of the current environment and is determined entirely by the macro body and the functions and constants it references. It is possible, however, to define macros that produce expansions that refer to STATE or other variables not among the macro's arguments. See the git example of :DOC defmacro.~/" (list 'defmacro-fn (list 'quote mdef) 'state (list 'quote event-form))) #+acl2-logic-only (defmacro defconst (&whole event-form name form &optional doc) ":Doc-Section acl2::Events define a constant~/ Examples: (defconst *digits* '(0 1 2 3 4 5 6 7 8 9)) (defconst *n-digits* (the unsigned-byte (length *digits*)))~/ General Form: (defconst name term doc-string) where name is a symbol beginning and ending with the character *, term is a variable-free term that is evaluated to determine the value of the constant, and doc-string is an optional documentation string, as described in :DOC doc-string. It may be of interest to note that defconst is implemented at the lisp level using defparameter, as opposed to defconstant, in order to support undoing properly.~/" (list 'defconst-fn ;See note below. (list 'quote name) (list 'quote form) 'state (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro defthm (&whole event-form name term ;See note below. &key (rule-classes '(:REWRITE)) instructions hints otf-flg doc) ":Doc-Section Events prove and name a theorem~/ Examples: (defthm assoc-of-app (equal (app (app a b) c) (app a (app b c)))) The following nonsensical example illustrates all the optional arguments and hints but is illegal because not all combinations are permitted: (defthm main (implies (hyps x y z) (concl x y z)) :rule-classes (:REWRITE :GENERALIZE) :instructions (induct prove promote (dive 1) x (dive 2) = top (drop 2) prove) :hints ((\"Goal\" :do-not-induct t :do-not '(generalize fertilize) :expand ((assoc x a) (member y z)) :hands-off (length binary-append) :in-theory (set-difference-theories (current-theory :here) '(assoc)) :induct (and (nth n a) (nth n b)) :use ((:instance assoc-of-append (x a) (y b) (z c)) (:functional-instance (:instance p-f (x a) (y b)) (p consp) (f assoc))) :by main-lemma-3)) :otf-flg t :doc \"#0[one-liner/example/details]\")~/ General Form: (defthm name term :rule-classes rule-classes :instructions instructions :hints hints :otf-flg otf-flg :doc doc-string) where name is a new symbolic name (see :DOC name), term is a term alleged to be a theorem, and rule-classes, instructions, hints, otf-flg and doc-string are as described in the corresponding :doc entries. The five keyword arguments above are all optional, however you may not supply both :instructions and :hints, since one drives the proof checker and the other drives the theorem prover. If :rule-classes is not specified, the list (:REWRITE) is used; if you wish the theorem to generate no rules, specify :rule-classes nil.~/" (list 'defthm-fn (list 'quote name) (list 'quote term) 'state (list 'quote rule-classes) (list 'quote instructions) (list 'quote hints) (list 'quote otf-flg) (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro defaxiom (&whole event-form name term &key (rule-classes '(:REWRITE)) doc) ;See note below. ":Doc-Section Events add an axiom~/ WARNING: We strongly recommend that you not add axioms. If at all possible you should use DEFUN or MUTUAL-RECURSION to define new concepts recursively or use ENCAPSULATE to constrain them constructively. Adding new axioms frequently renders the logic inconsistent. Example: (defaxiom sbar (equal t f) :rule-classes (:REWRITE :GENERALIZE) :doc \":Doc-Section ...\")~/ General Form: (defaxiom name term :rule-classes rule-classes :doc doc-string) where name is a new symbolic name (see :DOC name), term is a term intended to be a new axiom, and rule-classes and doc-string are as described in the corresponding :doc entries. The two keyword arguments are optional. If :rule-classes is not supplied, the list (:REWRITE) is used; if you wish the axiom to generate no rules, specify :rule-classes nil.~/" (list 'defaxiom-fn (list 'quote name) (list 'quote term) 'state (list 'quote rule-classes) (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro deflabel (&whole event-form name &key doc) ":Doc-Section Events build a landmark and/or add a documentation topic~/ Examples: (deflabel interp-section :doc \":Doc-Section ...\")~/ General Form: (deflabel name :doc doc-string) where name is a new symbolic name (see :DOC name) and doc-string is an optional documentation string as described by :DOC doc-string. This event adds the documentation string for symbol name to the :doc data base. By virtue of the fact that DEFLABEL is an event, it also marks the current history with the name. Thus, even undocumented labels are convenient as landmarks in a proof development. For example, you may wish to undo back through some label or compute a theory expression in terms of some labels. DEFLABEL events are never considered redundant. See :DOC redundant-events.~/" (list 'deflabel-fn ;See note below. (list 'quote name) 'state (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro deftheory (&whole event-form name expr &key doc) ":Doc-Section Events define a theory (to enable or disable a set of rules)~/ Example: (deftheory interp-theory (set-difference-theories (universal-theory :here) (universal-theory 'interp-section)))~/ General Form: (deftheory name term :doc doc-string) where name is a new symbolic name (see :DOC name), term is a term that when evaluated will produce a theory (see :DOC theories), and doc-string is an optional documentation string as described by :DOC doc-string. Except for the variable WORLD, term must contain no free variables. Term is evaluated with WORLD bound to the current world (see :DOC world) and the resulting theory is then converted to a runic theory (see :DOC theories) and associated with name. Henceforth, this runic theory is returned as the value of the theory expression (theory name).~/" (list 'deftheory-fn ;See note below. (list 'quote name) (list 'quote expr) 'state (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro in-theory (&whole event-form expr &key doc) ":Doc-Section Events designate ``current'' theory (enabling its rules)~/ Example: (in-theory (set-difference-theories (universal-theory :here) '(flatten (:executable-counterpart flatten))))~/ General Form: (in-theory term :doc doc-string) where term is a term that when evaluated will produce a theory (see :DOC theories), and doc-string is an optional documentation string not beginning with ``:Doc-Section ...''. Except for the variable WORLD, term must contain no free variables. Term is evaluated with the variable WORLD bound to the current world to obtain a theory and the corresponding runic theory (see :DOC theories) is then made the current theory. Thus, immediately after the IN-THEORY, a rule is enabled iff its rule name is a member of the runic interpretation (see :DOC theories) of some member of the value of term. See :DOC theory-functions for a list of the commonly used theory manipulation functions. Because no unique name is associated with an IN-THEORY event, there is no way we can store the documentation string doc-string in our documentation data base. Hence, we actually prohibit doc-string from having the form described in :DOC doc-string.~/" (list 'in-theory-fn ;See note below. (list 'quote expr) 'state (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro table (&whole event-form name &rest args) ":Doc-Section Events user-managed tables~/ Examples: (table tests 1 '(...)) ; set contents of tests[1] to '(...) (table tests 25) ; get contents of tests[25] (table tests) ; return table tests as an alist (table tests nil nil :clear) ; clear table tests (table tests nil (foo 7) :clear) ; set table tests to (foo 7) (table tests nil nil :guard) ; fetch the table guard (table tests nil nil :guard term) ; set the table guard~/ General Form: (table table-name key-term value-term op term) where table-name is a symbol that is the name of a (possibly new) table, key-term and value-term, if present, are arbitrary terms involving (at most) the single variable WORLD, op, if present, is one of the table operations below, and term, if present, is a term. Table returns an Acl2 ``error triple.'' The effect of table on STATE depends on op and how many arguments are presented. Some invocations actually have no effect on the Acl2 world and hence an invocation of table is not always an ``event''. We explain below, after giving some background information. The Acl2 system provides ``tables'' by which the user can associate one object with another. Tables are in essence just conventional association lists -- lists of pairs -- but the Acl2 environment provides a means of storing these lists in the ``Acl2 world'' of the current state. The Acl2 user could accomplish the same ends by using Acl2 ``global variables;'' however, limitations on global variable names are imposed to insure Acl2's soundness. By convention, no table is important to Acl2's soundness, even though some features of the system use tables, and the user is invited to make free use of tables. Because tables are stored in the Acl2 world they are restored by include-book and undone by :ubt. Many users of Nqthm requested a facility by which user data could be saved in Nqthm ``lib files'' and tables are Acl2's answer to that request. Abstractly, each table is an association list mapping ``keys'' to ``values.'' In addition, each table has a ``:guard,'' which is a terms that must be true of any key and value used. By setting the :guard on a table you may enforce an invariant on the objects in the table, e.g., that all keys are positive integers and all values are symbols. Each table has a ``name,'' which must be a symbol. Given a table name, there are six operations one might perform on the table: :put associate a value with a key (possibly changing the value currently associated with that key); :get retrieve the value associated with a key (or nil if no value has been associated with that key); :alist return an alist showing all keys and non-nil values in the table; :clear clear the table (so that every value is nil), or if val is supplied then set table to that value (which must be an alist); :guard fetch or set the :guard of the table; When the operations above suggest that the table or its :guard are modified what is actually meant is that the current state is redefined so that in it the affected table name has the appropriate properties. In such cases, the table form is an event. Table forms are commonly typed by the user while interacting with the system. :Put and :get forms are especially common. Therefore, we have adopted a positional syntax that is intended to be convenient for most applications. Essentially, some operations admit a ``short form'' of invocation. (table name key-term value-term :put) ; long form (table name key-term value-term) ; short form evaluates the key- and value-terms, obtaining two objects which we call key and value, checks that the key and value satisfy the :guard on the named table and then ``modifies'' the named table so that the value associated with key is value. When used like this, table is actually an event in the sense that it changes the Acl2 world. In general, the forms evaluated to obtain the key and value may involve the variable WORLD, which is bound to the then current world during the evaluation of the forms. However, in the special case that the table in question is named acl2-defaults-table, the key and value terms may not contain any variables. Essentially, the keys and values used in events setting the acl2-defaults-table must be explicitly given constants. See :DOC acl2-defaults-table. (table name key-term nil :get) ; long form (table name key-term) ; short form evaluates the key-term (see note below), obtaining an object, key, and returns the value associated with key in the named table (or, nil if there is no value associated with key). When used like this, table is not an event; the value is simply returned. (table name nil nil :alist) ; long form (table name) ; short form returns an alist representing the named table; for every key in the table with a non-nil associated value, the alist pairs the key and its value. The order in which the keys are presented is unspecified. When used like this, table is not an event; the alist is simply returned. (table name nil val :clear) sets the named table to the alist val, making the checks that :put makes for each key and value of val. When used like this, table is an event because it changes the Acl2 world. (table name nil nil :guard) returns the translated form of the guard of the named table. (table name nil nil :guard term) provided the named table is empty and has not yet been assigned a :guard and term (which is not evaluated) is a term that mentions at most the variables KEY, VAL and WORLD, this event sets the :guard of the named table to term. Whenever a subsequent :put occurs, term will be evaluated with KEY bound to the key argument of the :put, VAL bound to the val argument of the :put, and WORLD bound to the then current world. An error will be caused by the :put if the result of the evaluation is nil. Note that it is not allowed to change the :guard on a table once it has been explicitly set. Before the :guard is explicitly set, it is effectively just t. After it is set it can be changed only by undoing the event that set it. The purpose of this restriction is to prevent the user from changing the :guards on tables provided by other people or the system. The intuition behind the :guard mechanism on tables is to enforce invariants on the keys and values in a table, so that the values, say, can be used without runtime checking. But if the :guard of a table is sensitive to the Acl2 world, it may be possible to cause some value in the table to cease satisfying the :guard without doing any operations on the table. Consider for example the :guard ``no value in this table is the name of an event.'' As described, that is enforced each time a value is stored. Thus, 'BANG can be :put in the table provided there is no event named BANG. But once it is in the table, there is nothing to prevent the user from defining BANG as a function, causing the table to contain a value that could not be :put there anymore. Observe that not all STATE-sensitive :guards suffer this problem. The :guard ``every value is an event name'' remains invariant, courtesy of the fact that undoing back through an event name in the table would necessarily undo the :put of the name into the table. Table was designed primarily for convenient top-level use. Tables are not especially efficient. Each table is represented by an alist stored on the property list of the table name. :Get is just a getprop and assoc-equal. :Put does a getprop to the get the table alist, a put-assoc-equal to record the new association, and a putprop to store the new table alist -- plus the overhead associated with :guards and undoable events. Note that there are never duplicate keys in the resulting alist; in particular, when the operation :clear is used to install new alist, duplicate keys are removed from that alist. A table name may be any symbol whatsoever. Symbols already in use as function or theorem names, for example, may be used as table names. Symbols in use only as table names may be defined with defun, etc. Because there are no restrictions on the user's choice of table names, table names are not included among the logical names. Thus, :pe name will never display a table event (for a logical name other than :here). Either :pe name will display a ``normal'' event such as (defun name ...) or (defthm name ...) or else :pe name will cause an error indicating that name is not a logical name. This happens even if name is in use as a table name. Similarly, we do not permit table names to have documentation strings, since the same name might already have a documentation string. If you want to associate a documentation string with a table name that is being used no other way, define the name as a label and use the :doc feature of deflabel (see :DOC deflabel).~/" ; At one time the table macro expanded to several different forms, ; depending on whether it was really expected to affect world. That ; was abandoned when it was actually included in the source files ; because of the important invariant that these defmacros be ; translatable by boot-translate. (list 'table-fn ; See note below (list 'quote name) (list 'quote args) 'state (list 'quote event-form))) #+acl2-logic-only (defmacro encapsulate (&whole event-form signatures &rest cmd-lst) ":Doc-Section Events constrain some functions and/or hide some events~/ Example: (encapsulate ((an-element (lst) t)) (local (defun an-element (lst) (if (consp lst) (car lst) nil))) (local (defthm member-equal-car (implies (and lst (true-listp lst)) (member-equal (car lst) lst)))) (defthm thm1 (implies (null lst) (null (an-element lst)))) (defthm thm2 (implies (and (true-listp lst) (not (null lst))) (member-equal (an-element lst) lst))))~/ General Form: (encapsulate (signature ... signature) ev1 ... evn) where each signature is as described in :DOC signature, each signature describes a different function symbol, and each evi is an embedded event form as described in :DOC embedded-event-form. There must be at least one evi. The evi inside LOCAL special forms are called ``local'' events below. Non-local events are sometimes said to be ``exported'' by the encapsulation. To be well-formed, an ENCAPSULATE event must have the properties that each event in the body (including the local ones) can be successfully executed in sequence and that in the resulting theory, each function mentioned among the signatures was introduced via a local event and has the signature listed. In addition, the body may contain no ``local incompatibilities'' which, roughly stated, means that the non-local events must not syntactically require symbols defined by local events, except for the functions listed in the signatures. See :DOC local-incompatibility. Finally, no non-local recursive definition in the body may use in its suggested induction scheme any function symbol listed among the signatures. See :DOC subversive-inductions. The result of an ENCAPSULATE event is an extension of the logic in which the functions listed in the signatures are constrained to have the signatures listed and to satisfy the non-local theorems proved about them. Since the constraints were all theorems in the ``ephemeral'' or ``local'' theory, we are assured that the extension produced by encapsulate is sound. In essence, the local definitions of the constrained functions are just ``witness functions'' that establish the consistency of the constraints. Because those definitions are local, they are not present in the theory produced by encapsulation. Encapsulate also exports all rules generated by its non-local events, but rules generated by local events are not exported. The default color for the first event in an encapsulation is the default color ``outside'' the encapsulation. But since color changing events are permitted within the body of an encapsulate, the default color may be changed. However, color changes occurring within the body of the encapsulate are not exported. In particular, the acl2-defaults-table after an encapsulate is always the same as it was before the encapsulate, even though the encapsulate body might contain color changing events such as (RED) or (BLUE). See :DOC color. Theorems about the constrained function symbols may then be proved -- theorems whose proofs necessarily employ only the constraints. Thus, those theorems may be later functionally instantiated, as with the :functional-instance lemma instance (see :DOC lemma-instance), to derive analogous theorems about different functions, provided the constraints can be proved about the new functions. Observe that if the signatures list is empty, ENCAPSULATE may still be useful for deriving theorems to be exported whose proofs require lemmas you prefer to hide (i.e., made local). The order of the events in the vicinity of an ENCAPSULATE is confusing. We discuss it in some detail here because when logical names are being used with theory functions to compute sets of rules, it is sometimes important to know the order in which events were executed. (See :DOC logical-name and :DOC theory-functions.) What, for example, is the set of function names extant in the middle of an encapsulation? If the most recent event is PREVIOUS and then you execute an ENCAPSULATE constraining AN-ELEMENT with two non-local events in its body, THM1 and THM2, then the order of the events after the encapsulation is (reading chronologically forward): PREVIOUS, THM1, THM2, AN-ELEMENT (the ENCAPSULATE itself). Actually, between PREVIOUS and THM1 certain extensions were made to the world by the superior ENCAPSULATE, to permit AN-ELEMENT to be used as a function symbol in THM1.~/" (list 'encapsulate-fn ;See note below. (list 'quote signatures) (list 'quote cmd-lst) 'state (list 'quote event-form))) #+acl2-logic-only (defmacro include-book (&whole event-form file &key doc) ":Doc-Section Events load the events in a file~/ Example: (include-book \"my-arith\")~/ General Form: (include-book file :doc doc-string) where file is book name. See :DOC books for general information and :DOC book-name for information about book names) and doc-string is an optional documentation string as described in :DOC doc-string. If the book has no certificate (see :DOC certificate) or if its certificate is invalid, a warning is printed and the book is included anyway. This can lead to serious errors, as described in :DOC uncertified-books. If the portcullis of the certificate (see :DOC portcullis) cannot be raised in the host logical world, an error is caused and no change occurs to the logic. Otherwise, the non-local events in file are assumed. Then the keep of the certificate (see :DOC keep) is checked to insure that the correct files were read. A warning is printed if uncertified books were included. Even if no warning is printed, include-book places a burden on you, as described in :DOC certificate. If there is a compiled file for the book that was created more recently than the book itself, it is automatically loaded. Certify- book can be used to compile a book. The effect of compilation is to speed up the execution of the functions defined within the book when those functions are applied to specific values. The presence of compiled code for the functions in the book should not otherwise affect the performance of Acl2. See :DOC guard for a discussion. Include-book is similar in spirit to encapsulate in that it is a single event that ``contains'' other events, in this case the events listed in the file named. Include-book processes the non-local event forms in the file, assuming that each is admissible. Local events in the file are ignored. You may use include-book to load multiple books, creating the logical world that contains the definitions and theorems of all of them. If any non-local event of the book attempts to define a name that has already been defined -- and the book's definition is not syntactically identical to the existing definition -- the attempt to include the book fails, an error message is printed, and no change to the logical world occurs. See :DOC redundant-events for the details. When a book is included, the default color for the first event is always :GOLD. That is, the default color ``outside'' the book -- in the environment in which include-book was called -- is irrelevant to the book. Color changing events are permitted within a book (provided they are not in LOCAL forms). However, color changes within a book are not exported, i.e., at the conclusion of an include-book, the ``outside'' default color is always the same as it was before the include-book. Unlike every other event in Acl2, include-book puts a burden on you. Used improperly, include-book can be unsound in the sense that it can create an inconsistent extension of a consistent logical world. A certification mechanism is available to help you carry this burden -- but it must be understood up front that even certification is no guarantee against inconsistency here. The fundamental problem is one of file system security. See :DOC certificate for a discussion of the security issues. See :DOC certify-book for a discussion of how to certify a book." (list 'include-book-fn ;See note below. (list 'quote file) 'state (list 'quote doc) (list 'quote event-form))) #+acl2-logic-only (defmacro skip-proofs (x) ;See note below. ":Doc-Section Other skip proofs for an event~/ It is sometimes convenient to skip the proofs generated by an event, even when the intention is to perform the proofs once it has been decided that the event is one to keep. Adding events without proof frequently renders the logic inconsistent. Examples: (skip-proofs (defun foo (x) (declare (xargs :guard (true-listp x))) (if (bar x (cons (cdr x) (g x))) (cons x (foo (reverse (cdr x)))) nil))) (skip-proofs (defthm app-assoc (equal (app (app x y) z) (app x (app y z))) :hints ((\"Goal\" :induct t))))~/ General Form: (skip-proofs event) where event is any form. Typically, form is an event that normally requires some proof; see :DOC events. Note that the form still goes through the full translation process; only proofs are skipped. In fact, the effect of enclosing an event in SKIP-PROOFS is exactly the same as the effect of setting the LD special ld-skip-proofsp to T; see :DOC ld-skip-proofsp. Note that a form (defaxiom ...) is nothing more than (skip-proofs (defthm ...)).~/" (list 'state-global-let* '((ld-skip-proofsp t)) x)) #+acl2-logic-only (defmacro local (x) ;See note below ":Doc-Section Events hiding an event in an encapsulation or book~/ Examples: (local (defthm hack1 (implies # #))) (local (defun induct-hint (x y z) #))~/ General Form: (local ev) where ev is an event form. If the current color is cool (:blue or :gold) and ld-skip-proofsp is nil or t, then (local ev) is equivalent to ev. But if the current color is hot (:red or :pink) or if ld-skip-proofsp is 'include-book, then (local ev) is a no-op. Thus, if such forms are in the event list of an encapsulate event or in a book, they are processed when the encapsulation or book is checked for admissibility in :blue or :gold but are skipped when extending the host world. Such events are thus considered ``local'' to the verification of the encapsulation or book. The non-local events are the ones ``exported'' by the encapsulation or book. See :DOC encapsulate for a thorough discussion. See also :DOC local-incompatibility for a discussion of a commonly encountered problem with such event hiding: you can't make an event local if its presence is required to make sense of a non-local one. Note that events that change the color, and in fact any events that set the acl2-defaults table, are disallowed inside the scope of local. See :DOC embedded-event-form." (list 'if '(equal (ld-skip-proofsp state) 'include-book) '(mv nil nil state) (list 'if '(equal (ld-skip-proofsp state) 'initialize-acl2) '(mv nil nil state) (list 'when-cool x)))) ; Important Boot-Strapping Invariants ; If any of the above forms are modified, be sure to change the ; setting of *initial-event-defmacros* as described there. Each of ; the defmacros above is of a rigid form recognized by the function ; primordial-event-macro-and-fn. For example, there are no ; declarations and the bodies used above are simple enough to be ; translatable by boot-translate before the world is created. ; More subtly, except for local, each macro generates a call of a ; corresponding -fn function on some actuals computed from the macros ; args: THE FORMALS OF THE -fn FUNCTIONS CAN BE DETERMINED BY LOOKING ; AT THE ACTUALS! For example, we can see that the 'formals for ; 'in-theory-fn, whenever it gets defined, will be '(expr state doc). ; The function primordial-event-macro-and-fn1 computes the formals ; from the actuals. Don't change the expressions above, don't even ; change the formals to the defmacros, and don't change the formals of ; the -fns unless you understand this! ; End of *initial-event-defmacros* discussion. ; GETPROP - an efficient applicative property list replacement. ; We provide here a property list facility with applicative ; semantics. The two primitive operations are putprop and ; getprop. A ``world-alist'' is a list of ``triples'' of the ; form (symbol key . val). Putprop conses triples on to a given ; world-alist. Getprop take a symbol and key and looks for the ; first member of the given world-alist with the given symbol and ; key, returning the corresponding val, or a default if no such ; triple is found. ; In the ``usual case'', the cost of a getprop will be no more than ; the cost of a couple of get's in Common Lisp, rather than a search ; linear in the length of the given world-alist. The efficiency is ; based upon the strange ``world-name'' extra argument of getprop. ; Formally, world-name is to be regarded as a parameter of getprop ; that is simply ignored. Practically speaking, getprop uses this ; hint to check whether the given world-alist is in fact currently and ; validly represented by a set of properties on property lists. To do ; this, getprop checks that as the 'acl2-world-pair property of the ; given world-name, there is a pair whose car is (eq) the given ; world-alist. If this is the case, then the cdr of the pair, say ; world-key, is a gensymed symbol. The world-key property of any ; given symbol, symb, is an alist containing exactly those pairs (key ; . val) such that (symb key . val) is in world-alist. That is, to ; find the key property of symb it is sufficient to assoc-eq for key ; up the alist obtained by (get symb world-key). ; For a more thorough description of the issues concerning ; installation of worlds, see the discussion in interface-raw.lisp, ; under the section heading EXTENDING AND RETRACTING PROPERTY LIST ; WORLDS. ; To use getprop and putprop effectively, one must think clearly in ; terms of the usual order of Lisp evaluation. Getprop is only fast ; on worlds that have been ``installed'' as by extend-world or ; retract-world. (defun worldp (alist) #-acl2-logic-only (cond ((eq alist (w *the-live-state*)) (return-from worldp t))) (cond ((atom alist) (eq alist nil)) (t (and (consp (car alist)) (symbolp (car (car alist))) (consp (cdr (car alist))) (symbolp (cadr (car alist))) (worldp (cdr alist)))))) (defthm worldp-forward-to-assoc-eq-equal-alistp (implies (worldp x) (assoc-eq-equal-alistp x)) :rule-classes :forward-chaining) (defun putprop (symb key value world-alist) (declare (xargs :guard (and (symbolp symb) (symbolp key) (worldp world-alist)))) (cons (cons symb (cons key value)) world-alist)) ; Occasionally you will find comments of the form: ; On Metering ; Occasionally in this code you will see forms protected by ; #+acl2-metering. If you (push :acl2-metering *features*) and then ; recompile the affected forms, you will get some additional printing ; that indicates random performance meters we have found useful. ; The following two definitions support a particularly common style of ; metering we do. Suppose you have a typical tail recursive fn for ; exploring a big list ; (defun scan (lst) ; (cond (test ; finish) ; (t ; (scan (cdr lst))))) ; We often meter it with: ; (defun scan (lst) ; (cond (test ; #+acl2-metering (meter-maid 'scan 100) ; finish) ; (t ; #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt)) ; (scan (cdr lst))))) ; Where (meter-maid 'scan 100) tests meter-maid-cnt against 100 and if ; it is bigger prints a msg about 'scan. In any case, meter-maid ; resets cnt to 0. This style of metering is not very elegant because ; meter-maid-cnt ought to be initialized cleanly to 0 "at the top" and ; protected against error aborts (i.e., by binding it). But to do ; that we'd have to recode many of our tail recursive functions so ; they had preludes and lets. With our meter-maid style, we can just ; insert the metering text into the existing text and preserve the ; tail recursion and lack of initialization. Not often in metered ; runs do we abort (leaving meter-maid-cnt artificially high) and that ; results (at worst) in a spurious report on the next metered call. #-acl2-logic-only (defparameter meter-maid-cnt 0) #-acl2-logic-only (defun meter-maid (fn maximum &optional arg1 arg2 cnt) (cond ((> (or cnt meter-maid-cnt) maximum) (cond (arg2 (format t "~%Meter: ~s on ~s and ~s used ~s cycles.~%" fn arg1 arg2 (or cnt meter-maid-cnt))) (arg1 (format t "~%Meter: ~s on ~s used ~s cycles.~%" fn arg1 (or cnt meter-maid-cnt))) (t (format t "~%Meter: ~s used ~s cycles.~%" fn (or cnt meter-maid-cnt)))))) (setq meter-maid-cnt 0)) ; If we ever find this value stored under a property, then getprop acts as ; though no value was found. Thus, this value had better never be stored as a ; "legitimate" value of the property. To belabor this point: we have here a ; fundamental difference between our getprop and Lisp's get. (defconst *acl2-property-unbound* :acl2-property-unbound) (defun getprop-default (symb key default) #+acl2-logic-only (declare (ignore symb key)) #-acl2-logic-only (cond ((and (consp default) (eq (car default) :error) (consp (cdr default)) (stringp (cadr default)) (null (cddr default))) (illegal 'getprop "No property was found under symbol ~p0 for key ~p1. ~@2" (list (cons #\0 symb) (cons #\1 key) (cons #\2 (cadr default)))))) default) (defun getprop (symb key default world-name world-alist) (declare (xargs :guard (and (symbolp symb) (symbolp key) (symbolp world-name) (worldp world-alist)))) ; Note that if default has the form '(:error string) where string is a ; stringp, then in raw Lisp we execute a hard error with context ; 'getprop and string string. Otherwise (and logically in any case), ; default is what we return when there is no key property of symb. #+acl2-logic-only (cond ((null world-alist) default) ((and (eq symb (caar world-alist)) (eq key (cadar world-alist))) (let ((ans (cddar world-alist))) (if (eq ans *acl2-property-unbound*) default ans))) (t (getprop symb key default world-name (cdr world-alist)))) #-acl2-logic-only (let ((pair (get world-name 'acl2-world-pair))) (cond (pair (do ((tl world-alist (cdr tl))) ((null tl) #+acl2-metering (meter-maid 'getprop 100 symb key) nil) #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt)) (cond ((eq tl (car pair)) #+acl2-metering (meter-maid 'getprop 100 symb key) (return-from getprop (let ((temp (assoc key (get symb (cdr pair)) :test #'eq))) (cond (temp (cond ((cdr temp) (let ((ans (car (cdr temp)))) (if (eq ans *acl2-property-unbound*) (getprop-default symb key default) ans))) (t (getprop-default symb key default)))) (t (getprop-default symb key default)))))) ((and (eq symb (caar tl)) (eq key (cadar tl))) #+acl2-metering (meter-maid 'getprop 100 symb key) (return-from getprop (let ((ans (cddar tl))) (if (eq ans *acl2-property-unbound*) (getprop-default symb key default) ans))))))) (t (do ((tl world-alist (cdr tl))) ((null tl) #+acl2-metering (meter-maid 'getprop 100 symb key) nil) #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt)) (cond ((and (eq symb (caar tl)) (eq key (cadar tl))) #+acl2-metering (meter-maid 'getprop 100 symb key) (return-from getprop (let ((ans (cddar tl))) (if (eq ans *acl2-property-unbound*) (getprop-default symb key default) ans)))))))) (getprop-default symb key default))) (defun ordered-symbol-alistp (x) ; An ordered-symbol-alist is an alist whose keys are symbols which are ; in the symbol-< order. (cond ((atom x) (null x)) ((atom (car x)) nil) (t (and (symbolp (caar x)) (or (atom (cdr x)) (and (consp (cadr x)) (symbolp (caadr x)) (symbol-< (caar x) (caadr x)))) (ordered-symbol-alistp (cdr x)))))) (in-theory (disable symbol-<)) (defthm ordered-symbol-alistp-forward-to-symbol-alistp (implies (ordered-symbol-alistp x) (symbol-alistp x)) :rule-classes :forward-chaining) (defun add-pair (key value l) (declare (xargs :guard (and (symbolp key) (ordered-symbol-alistp l)))) (cond ((null l) (list (cons key value))) ((eq key (caar l)) (cons (cons key value) (cdr l))) ((symbol-< key (caar l)) (cons (cons key value) l)) (t (cons (car l) (add-pair key value (cdr l)))))) (defun remove-first-pair (key l) (declare (xargs :guard (and (symbolp key) (symbol-alistp l) (assoc-eq key l)))) (cond ((null l) nil) ((eq key (caar l)) (cdr l)) (t (cons (car l) (remove-first-pair key (cdr l)))))) (defun all-true-listp (x) (cond ((atom x) (eq x nil)) (t (and (true-listp (car x)) (all-true-listp (cdr x)))))) (defthm all-true-listp-forward-to-true-listp (implies (all-true-listp x) (true-listp x)) :rule-classes :forward-chaining) (defun getprops1 (alist) ; Each element of alist is of the form (key val1 ... valk), i.e., key is bound ; to a stack of vali's. We transform each element to (key . val1), i.e., each ; key is bound to the top-most vali. An empty stack or a top value of ; *acl2-property-unbound* means there is no binding for key. (declare (xargs :guard (all-true-listp alist))) (cond ((null alist) nil) ((or (null (cdar alist)) (eq (car (cdar alist)) *acl2-property-unbound*)) (getprops1 (cdr alist))) (t (cons (cons (caar alist) (cadar alist)) (getprops1 (cdr alist)))))) (defun getprops (symb world-name world-alist) ; returns all of the properties of symb in world-alist, as a list of ; key-value pairs, sorted according to ordered-symbol-alistp. We ; respect the *acl2-property-unbound* convention. (declare (xargs :guard (and (symbolp symb) (symbolp world-name) (worldp world-alist)) :color :red)) #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt)) (cond #-acl2-logic-only ((eq world-alist (car (get world-name 'acl2-world-pair))) #+acl2-metering (meter-maid 'getprops 100 symb) (sort (getprops1 (get symb (cdr (get world-name 'acl2-world-pair)))) #'(lambda (x y) (symbol-< (car x) (car y))))) ((null world-alist) #+acl2-metering (meter-maid 'getprops 100 symb) nil) ((eq symb (caar world-alist)) (let ((alist (getprops symb world-name (cdr world-alist)))) (if (eq (cddar world-alist) *acl2-property-unbound*) (if (assoc-eq (cadar world-alist) alist) (remove-first-pair (cadar world-alist) alist) alist) (add-pair (cadar world-alist) (cddar world-alist) alist)))) (t (getprops symb world-name (cdr world-alist))))) (verify-termination getprops (declare (xargs :color :blue))) (defthm ascii-<-l-irreflexive (implies (and (eqlable-listp x) (integerp i)) (not (ascii-<-l x x i)))) (defthm ascii-<-irreflexive (implies (stringp s) (not (ascii-< s s)))) (in-theory (disable ascii-<)) (encapsulate () (local (defthm member-equal-is-member (implies (eqlable-listp x) (equal (member-equal a x) (member a x)))) ) (local (defthm not-member-cdr-member-lemma (implies (and (member x1 (cdr (member a x2))) (eqlable-listp x2)) (member x1 x2))) ) (local (defthm not-member-cdr-member (implies (and (no-duplicatesp x) (member a (cdr (member b x))) (force (eqlable-listp x))) (not (member b (cdr (member a x)))))) ) (defthm ascii-<-l-asymmetric (implies (and (eqlable-listp x1) (eqlable-listp x2) (integerp i) (ascii-<-l x1 x2 i)) (not (ascii-<-l x2 x1 i))) :hints (("Goal" :in-theory (disable member)))) (defthm symbol-<-asymmetric (implies (and (symbolp sym1) (symbolp sym2) (symbol-< sym1 sym2)) (not (symbol-< sym2 sym1))) :hints (("Goal" :in-theory (set-difference-theories (enable ascii-< symbol-<) '(ascii-<-l))))) (local (defthm member-cdr-transitive (implies (and (member a (cdr (member b x))) (member b (cdr (member c x))) (no-duplicatesp x) (eqlable-listp x)) (member a (cdr (member c x)))))) (defthm ascii-<-l-transitive (implies (and (ascii-<-l x y i) (ascii-<-l y z j) (integerp i) (integerp j) (integerp k) (character-lst x) (character-lst y) (character-lst z)) (ascii-<-l x z k)) :hints (("Goal" :induct t :in-theory (disable member)))) (in-theory (disable ascii-<-l)) (defthm symbol-<-transitive (implies (and (symbol-< x y) (symbol-< y z) (symbolp x) (symbolp y) (symbolp z)) (symbol-< x z)) :hints (("Goal" :in-theory (enable symbol-< ascii-<)))) (local (defthm some-member-cdr-member (implies (and (eqlable-listp x) (not (equal a b)) (member a x) (member b x) (not (member a (cdr (member b x))))) (member b (cdr (member a x)))))) (defthm ascii-<-l-trichotomy (implies (and (not (ascii-<-l x y i)) (integerp i) (integerp j) (standard-char-listp x) (standard-char-listp y)) (iff (ascii-<-l y x j) (not (equal x y)))) :hints (("Goal" :in-theory (set-difference-theories (enable ascii-<-l standard-char-p standard-char-listp) '(member)) :induct t))) (local (defthm equal-coerce (implies (and (stringp x) (stringp y)) (equal (equal (coerce x 'list) (coerce y 'list)) (equal x y))) :hints (("Goal" :use ((:instance coerce-inverse-2 (x x)) (:instance coerce-inverse-2 (x y))) :in-theory (disable coerce-inverse-2))))) (local (defthm symbol-equality-rewrite (implies (and (symbolp s1) (symbolp s2) (equal (symbol-name s1) (symbol-name s2)) (equal (symbol-package-name s1) (symbol-package-name s2))) (equal (equal s1 s2) t)) :hints (("Goal" :use symbol-equality)))) (defthm symbol-<-trichotomy (implies (and (symbolp x) (symbolp y) (not (symbol-< x y))) (iff (symbol-< y x) (not (equal x y)))) :hints (("Goal" :in-theory (enable symbol-< ascii-<)))) (defthm ordered-symbol-alistp-remove-first-pair (implies (and (ordered-symbol-alistp l) (symbolp key) (assoc-eq key l)) (ordered-symbol-alistp (remove-first-pair key l)))) (defthm symbol-<-irreflexive (implies (symbolp x) (not (symbol-< x x))) :hints (("Goal" :use ((:instance symbol-<-asymmetric (sym1 x) (sym2 x))) :in-theory (disable symbol-<-asymmetric)))) (defthm ordered-symbol-alistp-add-pair (implies (and (ordered-symbol-alistp gs) (symbolp w5)) (ordered-symbol-alistp (add-pair w5 w6 gs)))) (defthm ordered-symbol-alistp-getprops (implies (and (worldp w) (symbolp world-name) (symbolp key)) (ordered-symbol-alistp (getprops key world-name w))) :hints (("Goal" :in-theory (enable symbol-<)))) (local (defthm ordered-symbol-alistp-implies-symbol-alistp (implies (ordered-symbol-alistp x) (symbol-alistp x)))) (local (defthm symbol-alistp-implies-alistp (implies (symbol-alistp x) (alistp x)))) (verify-guards getprops) ) (defun has-propsp1 (alist exceptions) ; This function is only called from raw lisp code in has-propsp. Alist is the ; alist of Acl2 properties stored on the property list of some symbol. As ; such, each element of alist is of the form (prop val1 val2 ... valk) where ; val1 is the most recently stored value of the property prop for that symbol. ; We here check that each val1 is *acl2-property-unbound* (unless prop is among ; exceptions). (declare (xargs :guard (and (assoc-eq-equal-alistp alist) (true-listp exceptions)))) (cond ((null alist) nil) ((or (null (cdar alist)) (eq (cadar alist) *acl2-property-unbound*) (member-eq (caar alist) exceptions)) (has-propsp1 (cdr alist) exceptions)) (t t))) (defun has-propsp (symb exceptions world-name world-alist known-unbound) ; We return t iff symb has properties other than those listed in exceptions. (declare (xargs :guard (and (symbolp symb) (symbolp world-name) (worldp world-alist) (true-listp exceptions) (true-listp known-unbound)))) #+acl2-metering (setq meter-maid-cnt (1+ meter-maid-cnt)) (cond #-acl2-logic-only ((eq world-alist (car (get world-name 'acl2-world-pair))) #+acl2-metering (meter-maid 'has-propsp 100 symb) (has-propsp1 (get symb (cdr (get world-name 'acl2-world-pair))) exceptions)) ((null world-alist) #+acl2-metering (meter-maid 'has-propsp 100 symb) nil) ((or (not (eq symb (caar world-alist))) (member-eq (cadar world-alist) known-unbound)) (has-propsp symb exceptions world-name (cdr world-alist) known-unbound)) ((eq (cddar world-alist) *acl2-property-unbound*) (has-propsp symb exceptions world-name (cdr world-alist) (cons (cadar world-alist) known-unbound))) (t t))) (defun extend-world (name wrld) ; Logically speaking, this function is a no-op that returns wrld. ; Practically speaking, it changes the Lisp property list ; state so that future getprops on name and wrld will be fast. ; However, wrld must be an extension of the current world installed ; under name, or else a hard error occurs. Finally, if name is ; 'current-acl2-world, then no changes are made, since we do not want ; the user to smash our world. #+acl2-logic-only (declare (ignore name)) #+acl2-logic-only wrld #-acl2-logic-only (cond ((eq name 'current-acl2-world) wrld) (t (extend-world1 name wrld)))) ;;; Since retract-world1 is defined in another file, and shouldn't be ;;; needed for the toothbrush, I've deleted the #-acl2-logic-only ;;; definition of retract-world. #| (defun retract-world (name wrld) ; Logically speaking, this function is a no-op that returns wrld. ; Practically speaking, it changes the Lisp property list ; state so that future getprops on name and wrld will be fast. ; However, wrld must be a retraction of the current world installed ; under name, or else a hard error occurs. Finally, if name is ; 'current-acl2-world, then no changes are made, since we do not want ; the user to smash our world. #+acl2-logic-only (declare (ignore name)) #+acl2-logic-only wrld #-acl2-logic-only (cond ((eq name 'current-acl2-world) wrld) (t (retract-world1 name wrld)))) |# (defun global-val (var wrld) ; If you are tempted to access a global variable value with getprop ; directly, so you can specify your own default value, it suggests ; that you have not initialized the global variable. See the ; discussion in primordial-world-globals. Follow the discipline of ; always initializing and always accessing with global-val. (declare (xargs :guard (and (symbolp var) (worldp wrld)))) (getprop var 'global-value '(:error "GLOBAL-VAL didn't find a value. Initialize this ~ symbol in PRIMORDIAL-WORLD-GLOBALS.") 'current-acl2-world wrld)) ; THEORY PROTO-PRIMITIVES ; Thus far it has been impossible to use the :in-theory hint in ; defthm and defun -- unless one wants to quote a theory -- because ; there are no primitives for getting all the names in the world. ; We here define the necessary basic functions, just so we can ; conveniently disable. See the extended discussion of theories ; in "other-events.lisp" where deftheory is defined. (defun function-symbolp (sym wrld) ; Sym must be a symbolp. We return t if sym is a function symbol and ; nil otherwise. We exploit the fact that every function symbol has a ; formals property. Of course, the property may be NIL so when we ; seek it we default to t so we can detect the absence of the ; property. Of course, if someone were to putprop 'formals t we would ; therefore claim the symbol weren't a function-symbolp. This fact is ; exploited when we prepare the world for the redefinition of a ; symbol. If for some reason you change the default, you must change ; it there too. It would be a good idea to search for 'formals t. (declare (xargs :guard (and (symbolp sym) (worldp wrld)))) (not (eq (getprop sym 'formals t 'current-acl2-world wrld) t))) (defun set-difference-equal (l1 l2) (declare (xargs :guard (and (true-listp l1) (true-listp l2)))) (cond ((null l1) nil) ((member-equal (car l1) l2) (set-difference-equal (cdr l1) l2)) (t (cons (car l1) (set-difference-equal (cdr l1) l2))))) ; ARRAYS - efficient applicative arrays. ; We provide functions for accessing and updating both one and two ; dimensional arrays, with applicative semantics, but good access time ; to the most recently updated copy and usually constant update time. ; We first describe the one dimensional array data type. From the ; formal point of view, an array is simply an alist, i.e. a list of ; pairs. With one exception, the key (i.e., the car) of each pair is ; a nonnegative integer. However each array must have (at least) one ; pair whose car is :header and whose cdr is a keyword list, whose ; keys include :dimensions, :maximum-length, and :default. Thus, for ; example, the list '((1 . 2) (:header :dimensions (3) :maximum-length ; 7 :default a) (0 . 6)) represents the sequence #s(6 2 7). In the ; case of a one dimensional array, the dimension is a list of length ; one which is a nonnegative integer one greater than the maximum ; permitted index. (Other keywords, e.g. :purpose, for ; identification, are permitted and ignored.) Formally speakign, to ; find the value of a non-negative integer key in such an alist, we ; search the alist (with the function aref1) for the first pair whose ; car matches the key. If such a pair is found, then aref1 returns ; the cdr of the pair; otherwise aref1 returns the value associated ; with the :default key. It is illegal to give aref1 an an index ; equal to or greater than the car of the value associated with the ; :dimensions key. In the normal case, updating happens by simply ; consing a new pair on to the alist with the function aset1. ; However, when the list resulting from such a cons has length greater ; than the value associated with the :maximum-length key, the alist is ; ``compressed'' back to an alist of minimal length, but with the same ; aref1 search semantics. ; For efficiency, the user is asked to call the array functions with ; an additional argument, a symbol, called the ``name'' of the given ; array. From the point of view of the formal semantics, the name ; argument is simply and completely ignored. However, as with the ; implementation of property lists described above, the name provides ; a hint about where to find a ``real'' Common Lisp array that may ; currently represent the given alist, in which case an array access ; can go quite quickly because the real array may be accessed ; directly. ; A further requirement for fast access is that the user initially ; alert the implementation to the desire to make fast accesses by ; calling the function compress1 on the array (and the desired name). ; compress1 then associates with the alist (under the name) a ``real'' ; array. compress1 returns a list that begins with the header and has ; its other elements in key-ascending order, with aref1-irrelevant ; pairs deleted. If the alist is already in this normal form, then no ; consing is done. If there is already an array associated with the ; given name, and if it happens to have the desired length, then no ; array allocation is done but instead that array is ``stolen''. ; In the usual case, whenever an array is updated (with aset1), the ; ``real'' array which acts as its shadow and supports efficient ; access, is set to support the ``new'' array, and no longer supports ; the ``old'' array. Thus one must, for efficiency's sake, be ; extremely conscious of the usual order of Common Lisp evaluation. ; For two dimensional arrays, the value of the key :dimensions should ; be a list of two positive integers and the aset2 and aref2 function ; take two indices. ; We require that array indices fit into 32 bits so that some ; compilers can lay down faster code. In the case of two dimensional ; arrays, we require that the product of legal indices fit into 32 ; bits. (defconst *maximum-positive-32-bit-integer* (1- (expt 2 31))) ; For 1 and 2 dimensional arrays, there may be a property, ; 'acl2-array, stored under a symbol name. If so, this property has ; is a list of length four, (object actual-array to-go-array header), ; where object is an alist; actual-array, is the current ``real'' ; array associated with object under name; to-go-array is an array of ; length one whose content is the number of additional conses that may ; be added before compresses is required; and header is the first pair ; beginning with :header in object. (to-go-array is kept as an array ; rather than as a mere integer in order to avoid number boxing.) (defun bounded-integer-alistp (l n) ; Check that l is a true-list of pairs, (n . x), where each n is ; either :header or a nonnegative integer less than n. (cond ((atom l) (null l)) (t (and (consp (car l)) (let ((key (caar l))) (and (or (eq key :header) (and (integerp key) (integerp n) (>= key 0) (< key n))) (bounded-integer-alistp (cdr l) n))))))) (defthm bounded-integer-alistp-forward-to-eqlable-alistp (implies (bounded-integer-alistp x n) (eqlable-alistp x)) :rule-classes :forward-chaining) (defun keyword-listp (l) (cond ((atom l) (null l)) (t (and (keywordp (car l)) (consp (cdr l)) (keyword-listp (cddr l)))))) (defthm keyword-listp-forward-to-true-listp (implies (keyword-listp x) (true-listp x)) :rule-classes :forward-chaining) (defun assoc-keyword (key l) (declare (xargs :guard (keyword-listp l))) (cond ((eq l nil) nil) ((eq key (car l)) l) (t (assoc-keyword key (cddr l))))) ; The following seems useful, though at this point its use isn't clear. (defthm keyword-listp-assoc-keyword (implies (keyword-listp l) (keyword-listp (assoc-keyword key l))) :rule-classes ((:forward-chaining :trigger-terms ((assoc-keyword key l))))) (defthm consp-assoc-eq-1 (implies (and (symbolp name) (alistp l)) (or (consp (assoc-eq name l)) (equal (assoc-eq name l) nil))) :rule-classes :type-prescription) (defthm consp-assoc-eq-2 (implies (symbol-alistp l) (or (consp (assoc-eq name l)) (equal (assoc-eq name l) nil))) :rule-classes :type-prescription) #-acl2-logic-only (defun slow-array-warning (fn nm) (format *error-output* "~%~%**********************************************************~%~ Slow Array Access! A call of ~a on an array named~%~ ~a is being executed slowly. See :DOC slow-array-warning~%~ **********************************************************~%~%" fn nm)) (deflabel arrays :doc ":Doc-Section Miscellaneous an introduction to Acl2 arrays.~/ For a detailed presentation of Acl2 arrays, type :more. Related topics include:~/ Acl2 provides relatively efficient 1- and 2-dimensional arrays. Arrays are awkward to provide efficiently in an applicative language because the programmer rightly expects to be able to ``modify'' an array object with the effect of changing the behavior of the element accessing function on that object. This, of course, does not make any sense in an applicative setting. The element accessing function is, after all, a function, and its behavior on a given object is immutable. To ``modify'' an array object in an applicative setting we must actually produce a new array object. Arranging for this to be done efficiently is a challenge to the implementors of the language. In addition, the programmer accustomed to the von Neumann view of arrays must learn how to use immutable applicative arrays efficiently. In this note we explain 1-dimensional arrays. In particular, we explain briefly how to create, access, and ``modify'' them, how they are implemented, and how to program with them. 2-dimensional arrays are dealt with by analogy. The Logical Description of Acl2 Arrays An Acl2 1-dimensional array is an object that associates arbitrary objects with certain integers, called ``indices.'' Every array has a dimension, dim, which is a positive integer. The indices of an array are the consecutive integers from 0 through dim-1. To obtain the object associated with the index i in an array a, one uses (aref1 name a i). Name is a symbol that is irrelevant to the semantics of aref1 but affects the speed with which it computes. We will talk more about array ``names'' later. To produce a new array object that is like a but which associates val with index i, one uses (aset1 name a i val). An Acl2 1-dimensional array is actually an alist. There is no special Acl2 function for creating arrays; they are generally built with the standard list processing functions LIST and CONS. However, there is a special Acl2 function, called compress1, for speeding up access to the elements of such an alist. We discuss compress1 later. One element of the alist must be the ``header'' of the array. The header of a 1-dimensional array with dimension dim is of the form: (:HEADER :DIMENSIONS (dim) :MAXIMUM-LENGTH max :DEFAULT obj :NAME name). Obj may be any object and is called the ``default value'' of the array. Max must be an integer greater than dim. Name must be a symbol. The :DEFAULT and :NAME entries are optional; if :DEFAULT is omitted, the default value is nil. The function HEADER, when given a name and a 1- or 2-dimensional array, returns the header of the array. The functions DIMENSIONS, MAXIMUM-LENGTH, and DEFAULT are similar and return the corresponding fields of the header of the array. The role of the :DIMENSIONS field is obvious: it specifies the legal indices into the array. The roles played by the :MAXIMUM-LENGTH and :DEFAULT fields are described below. Aside from the header, the other elements of the alist must each be of the form (i . val), where i is an integer and 0 <= i < dim, and val is an arbitrary object. (Aref1 name a i) is guarded so that name must be a symbol, a must be an array and i must be an index into a. The value of (aref1 name a i) is either (cdr (assoc i a)) or else is the default value of a, depending on whether there is a pair in a whose car is i. Note that name is irrelevant to the value of an aref1 expression. You might :pe aref1 to see how simple the definition is. (Aset1 name a i val) is guarded analogously to the aref1 expression. The value of the aset1 expression is essentially (cons (cons i val) a). Again, name is irrelevant. Note (aset1 name a i val) is an array, a', with the property that (aref1 name a' i) is val and, except for index i, all other indices into a' produce the same value as in a. Note also that if a is viewed as an alist (which it is) the pair ``binding'' i to its old value is in a' but ``covered up'' by the new pair. Thus, the length of an array grows by one when aset1 is done. Because aset1 covers old values with new ones, an array produced by a sequence of aset1 calls may have many irrelevant pairs in it. The function compress1 removes these irrelevant pairs. Thus, (compress1 name a) returns an array that is equivalent (vis-a-vis aref1) to a but which may be shorter. For technical reasons, the alist returned by compress1 may also list the pairs in a different order than listed in a. To prevent arrays from growing excessively long due to repeated aset1 operations, aset1 actually calls compress1 on the new alist whenever the length of the new alist exceeds the :maximum-length entry, max, in the header of the array. See :pe aset1. This is primarily just a mechanism for freeing up cons space consumed while doing aset1 operations. This completes the logical description of 1-dimensional arrays. 2-dimensional arrays are analogous. The :dimensions entry of the header of a 2-dimensional array should be (dim1 dim2). A pair of indices, i and j, are legal iff 0 <= i < dim1 and 0 <= j < dim2. The :maximum-length must be greater than dim1*dim2. Aref2, aset2, and compress2 are like their counterparts but take an additional index argument. Finally, the pairs in a 2-dimensional array are of the form ((i . j) . val). The Implementation of Acl2 Arrays Aref1 is essentially assoc. If aref1 were implemented naively the time taken to access an array element would be linear in the dimension of the array and the number of ``assignments'' to it (the number of aset1 calls done to create the array from the initial alist). This is intolerable; arrays are ``supposed'' to provide constant-time access and change. The apparently irrelevant names associated with Acl2 arrays allow us to provide constant-time access and change when arrays are used in ``conventional'' ways. The implementation of arrays makes it clear what we mean by ``conventional.'' Recall that array names are symbols. Behind the scenes, Acl2 associates two objects with each Acl2 array name. The first object is called the ``semantic value'' of the name and is an alist. The second object is called the ``raw lisp array'' and is a Common Lisp array. When (compress1 name alist) builds a new alist, a', it sets the semantic value of name to that new alist. Furthermore, it creates a Common Lisp array and writes into it all of the index/value pairs of a', initializing unassigned indices with the default value. This array becomes the raw lisp array of name. Compress1 then returns a', the semantic value, as its result, as required by the definition of compress1. When (aref1 name a i) is invoked, aref1 first determines whether the semantic value of name is a (i.e., is eq to the alist a). If so, aref1 can determine the ith element of a by invoking Common Lisp's aref function on the raw lisp array associated with name. Note that no linear search of the alist a is required; the operation is done in constant time and involves retrieval of two global variables, an eq test and jump, and a raw lisp array access. In fact, an Acl2 array access of this sort is about 5 times slower than a C array access. On the other hand, if name has no semantic value or if it is different from a, then aref1 determines the answer by linear search of a as suggested by the assoc-like definition of aref1. Thus, aref1 always returns the axiomatically specified result. It returns in constant time if the array being accessed is the current semantic value of the name used. The ramifications of this are discussed after we deal with aset1. When (aset1 name a i val) is invoked, aset1 does two conses to create the new array. Call that array a'. It will be returned as the answer. (In this discussion we ignore the case in which aset1 does a compress1.) However, before returning aset1 determines if name's semantic value is a. If so, it makes the new semantic value of name be a' and it smashes the raw lisp array of name with val at index i, before returning a' as the result. Thus, after doing an aset1 and obtaining a new semantic value a', all aref1s on that new array will be fast. Any aref1s on the old semantic value, a, will be slow. To understand the performance implications of this design, consider the chronological sequence in which Acl2 (Common Lisp) evaluates expressions: basically inner-most first, left-to-right, call-by-value. An array use, such as (aref1 name a i), is ``fast'' (constant-time) if the alist supplied, a, is the value returned by the most recently executed compress1 or aset1 on the name supplied. In the functional expression of ``conventional'' array processing, all uses of an array are fast. The :NAME field of the header of an array is completely irrelevant. Our convention is to store in that field the symbol we mean to use as the name of the raw lisp array. But no Acl2 function inspects :NAME and its primary value is that it allows the user, by inspecting the semantic value of the array -- the alist -- to recall the name of the raw array that probably holds that value. We say ``probably'' since there is no enforcement that the alist was compressed under the name in the header or that all asets used that name. Such enforcement would be inefficient. Some Programming Examples In the following examples we will use Acl2 ``global variables'' to hold several arrays. See :DOC @ and :DOC assign. Let the state global variable A be the 1-dimensional compressed array of dimension 5 constructed below. ACL2 Gold>(assign A (compress1 'demo '((:HEADER :DIMENSIONS (5) :MAXIMUM-LENGTH 15 :DEFAULT UNINITIALIZED :NAME DEMO) (0 . ZERO)))) Then (aref1 'demo (@ A) 0) is ZERO and (aref1 'demo (@ A) 1) is UNINITIALIZED. Now execute ACL2 Gold>(assign B (aset1 'demo (@ A) 1 'one)) Then (aref1 'demo (@ B) 0) is ZERO and (aref1 'demo (@ B) 1) is ONE. All of the aref1s done so far have been ``fast.'' Note that we now have two array objects, one in the global variable A and one in the global variable B. B was obtained by assigning to A. That assignment does not affect the alist A because this is an applicative language. Thus, (aref1 'demo (@ A) 1) must STILL be UNINITIALIZED. And if you execute that expression in Acl2 you will see that indeed it is. However, a rather ugly comment is printed, namely that this array access is ``slow.'' The reason it is slow is that the raw lisp array associated with the name DEMO is the array we are calling B. To access the elements of A, aref1 must now do a linear search. Any reference to A as an array is now ``unconventional;'' in a conventional language like Ada or Common Lisp it would simply be impossible to refer to the value of the array before the assignment that produced our B. Now let us define a function that counts how many times a given object, x, occurs in an array. For simplicity, we will pass in the name and highest index of the array: ACL2 Gold>(defun cnt (name a i x) (declare (xargs :guard (and (array1p name a) (integerp i) (>= i -1) (< i (car (dimensions name a)))) :color :blue :measure (+ 1 i))) (cond ((= i -1) 0) ((equal x (aref1 name a i)) (1+ (cnt name a (1- i) x))) (t (cnt name a (1- i) x)))) To determine how many times ZERO appears in (@ B) we can execute: ACL2 Gold>(cnt 'demo (@ B) 4 'ZERO) The answer is 1. How many times does UNINITIALIZED appear in (@ B)? ACL2 Gold>(cnt 'demo (@ B) 4 'UNINITIALIZED) The answer is 3, because positions 2, 3 and 4 of the array contain that default value. Now imagine that we want to assign 'TWO to index 2 and then count how many times the 2nd element of the array occurs in the array. This specification is actually ambiguous. In assigning to B we produce a new array, which we might call c. Do we mean to count the occurrences in c of the 2nd element of B or the 2nd element of c? That is, do we count the occurrences of UNINITIALIZED or the occurrences of TWO? If we mean the former the correct answer is 2 (positions 3 and 4 are UNINITIALIZED in c); if we mean the latter, the correct answer is 1 (there is only one occurrence of TWO in c). Below are Acl2 renderings of the two meanings, which we call [former] and [latter]. (cnt 'demo (aset1 'demo (@ B) 2 'two) 4 (aref1 'demo (@ B) 2)) ; [former] (let ((c (aset1 'demo (@ B) 2 'two))) ; [latter] (cnt 'demo c 4 (aref1 'demo c 2))) Note that in [former] we create c in the second argument of the call to cnt (although we do not give it a name) and then refer to B in the fourth argument. This is unconventional because the second reference to B in [former] is no longer the semantic value of demo. While Acl2 computes the correct answer, namely 2, the execution of the aref1 expression in [former] is done slowly. A conventional rendering with the same meaning is (let ((x (aref1 'demo (@ B) 2))) ; [fast former] (cnt 'demo (aset1 'demo (@ B) 2 'two) 4 x)) which fetches the 2nd element of B before creating c by assignment. It is important to understand that [former] and [fast former] mean exactly the same thing: both count the number of occurrences of UNINITIALIZED in c. Both are legal Acl2 and both compute the same answer, 2. Indeed, we can symbolically transform [fast former] into [former] merely by substitution the binding of x for x in the body of the let. But [fast former] can be evaluated faster than [former] because all of the references to demo use the then-current semantic value of demo, which is B in the first line and c throughout the execution of the cnt in the second line. [Fast former] is the preferred form, both because of its execution speed and its clarity. If you were writing in a conventional language you would have to write something like [fast former] because there is no way to refer to the 2nd element of the old value of B after smashing B unless it had been saved first. We turn now to [latter]. It is both clear and efficient. It creates c by assignment to B and then it fetches the 2nd element of c, TWO, and proceeds to count the number of occurrences in c. The answer is 1. [Latter] is a good example of typical Acl2 array manipulation: after the assignment to B that creates c, c is used throughout. It takes a while to get used to this because most of us have grown accustomed to the peculiar semantics of arrays in conventional languages. For example, in raw lisp we might have written something like (cnt 'demo (aset 'demo b 2 'two) 4 (aref 'demo b 2)) which sort of resembles [former] but actually has the semantics of [latter] because the b from which aref fetches the 2nd element is not the same b used in the aset! The aset b is destroyed by the aset and b henceforth refers to the array produced by the aset, as written more clearly in [latter]. Finally, a word of warning to users who wish to experiment with [former], [latter] and [fast former]. Suppose you have just created B with the assignment shown above, ACL2 Gold>(assign B (aset1 'demo (@ A) 1 'one)) If you then evaluate [former] in Acl2 it will complain that the aref1 is slow and compute the answer, as discussed. Then suppose you evaluate [latter] in Acl2. From our discussion you might expect it to execute fast -- i.e., issue no complaint. But in fact you will find that it complains repeatedly. The problem is that the evaluation of [former] changed the semantic value of demo so that it is no longer B. To try the experiment correctly you must make B be the semantic value of demo again before the next example is evaluated. One way to do that is to execute ACL2 Gold>(assign b (compress1 'demo (@ b))) before each expression. Because of issues like this it is often hard to experiment with Acl2 arrays at the top-level. We find it easier to write functions which use arrays correctly and efficiently than to so use them interactively. This last assignment also illustrates a very common use of compress1. While it was introduced as a means of removing irrelevant pairs from an array built up by repeated assignments, it is actually most useful as a way of insuring fast access to the elements of an array. Many array processing tasks can be divided into two parts. During the first part the array is built. During the second part the array is used extensively but not modified. If your programming task can be so divided, it might be appropriate to construct the array entirely with list processing, thereby saving the cost of maintaining the semantic value of the name while few references are being made. Once the alist has stabilized, it might be worthwhile to treat it as an array by calling compress1, thereby gaining constant time access to it. Acl2's theorem prover uses this technique in connection with its implementation of the notion of whether a rune is disabled or not. Associated with every rune is a unique integer index, called its ``nume.'' When each rule is stored, the corresponding nume is stored as a component of the rule. Theories are lists of runes and membership in the ``current theory'' indicates that the corresponding rule is enabled. But these lists are very long and membership is a linear-time operation. So just before a proof begins we map the list of runes in the current theory into an alist that pairs the corresponding numes with t. Then we compress this alist into an array. Thus, given a rule we can obtain its nume (because it is a component) and then determine in constant time whether it is enabled. The array is never modified during the proof, i.e., aset1 is never used in this example. From the logical perspective this code looks quite odd: we have replaced a linear-time membership test with an apparently linear-time assoc after going to the trouble of mapping from a list of runes to an alist of numes. But because the alist of numes is an array, the ``apparently linear-time assoc'' is more apparent than real; the operation is constant-time.") (deflabel slow-array-warning :doc ":Doc-Section arrays a warning issued when arrays are used inefficiently~/ If you use Acl2 arrays you may sometimes see a SLOW ARRAY warning. We here explain what that warning means and some likely ``mistakes'' it may signify.~/ The discussion in :DOC arrays defines what we mean by the semantic value of a name. As noted there, behind the scenes Acl2 maintains the invariant that with some names there is associated a pair consisting of an Acl2 array alist, called the semantic value of the name, and an equivalent raw lisp array. Access to Acl2 array elements, as in (aref1 name alist i), is executed in constant time when the array alist is the semantic value of the name, because we can just use the corresponding raw lisp array to obtain the answer. Aset1 and compress1 modify the raw lisp array appropriately to maintain the invariant. If aref1 is called on a name and alist, and the alist is not the then-current semantic value of the name, the correct result is computed but it requires linear time because the alist must be searched. When this happens, aref1 prints a SLOW ARRAY warning message to the comment window. Aset1 behaves similarly because the array it returns will cause the SLOW ARRAY warning every time it is used. From the purely logical perspective there is nothing ``wrong'' about such use of arrays and it may be spurious of us to print a warning message. But because arrays are generally used to achieve efficiency, the SLOW ARRAY warning often means the user's intentions are not being realized. Sometimes merely performance expectations are not met; but the message may mean that the functional behavior of the program is different than intended. Here are some ``mistakes'' that might cause this behavior. In the following we suppose the message was printed by aset1 about an array named name. Suppose the alist supplied aset1 is alist. (1) Compress1 was never called on name and alist. That is, perhaps you created an alist that is an array1p and then proceeded to access it with aref1 but never gave Acl2 the chance to create a raw lisp array for it. After creating an alist that is intended for use as an array, you must do (compress1 name alist) and pass the resulting alist' as the array. (2) Name is misspelled. Perhaps the array was compressed under the name 'delta-1 but accessed under 'delta1? (3) An aset1 was done to modify alist, producing a new array, alist', but you subsequently used alist as an array. Inspect all (aset1 name ...) occurrences and make sure that the alist modified is never used subsequently (either in that function or any other). It is good practice to adopt the following syntactic style. Suppose the alist you are manipulating is the value of the local variable ALIST. Suppose at some point in a function definition you wish to modify alist with aset1. Then write (let ((ALIST (aset1 name ALIST i val))) ...) and make sure that the subsequent function body is entirely within the scope of the let. Any uses of ALIST subsequently will refer to the new alist and it is impossible to refer to the old alist. Note that if you write (foo (let ((alist (aset1 name alist i val))) ...) ; arg 1 (bar alist)) ; arg 2 you have broken the rules, because in arg 1 you have modified alist but in arg 2 you refer to the old value. An appropriate rewriting is to lift the let out: (let ((alist (aset1 name alist alist i val))) (foo ... ; arg 1 (bar alist))) ; arg 2 Of course, this may not mean the same thing. (4) A function which takes alist as an argument and modifies it with aset1 fails to return the modified version. This is really the same as (3) above, but focuses on function interfaces. If a function takes an array alist as an argument and the function uses aset1 (or a subfunction uses aset1, etc), then the function probably ``ought'' to return the result produced by aset1. The reasoning is as follows. If the array is passed into the function, then the caller is holding the array. After the function modifies it, the caller's version of the array is obsolete. If the caller is going to make further use of the array, it must obtain the latest version, i.e., that produced by the function.") (defun array1p (name l) ":Doc-Section Arrays recognize a 1-dimensional array~/ Example Form: (array1p 'delta1 a)~/ General Form: (array1p name alist) where name and alist are arbitrary objects. This functions returns t if alist is a 1-dimensional Acl2 array. Otherwise it returns nil. The function operates in constant time if alist is the semantic value of name. See :DOC arrays." #-acl2-logic-only (cond ((symbolp name) (let ((prop (get name 'acl2-array))) (cond ((and prop (eq l (car prop))) (return-from array1p (= 1 (array-rank (cadr prop))))))))) ; Note: This function does not use the header, dimensions, and maximum-length ; functions, but obtains their results through duplication of code. The reason ; is that we want those functions to have array1p or array2p as guards, so they ; can't be introduced before array1p. The reason we want this function in ; their guards, even though it is overly strong, is as follows. Users who use ; aref1 guard their functions with arrayp1 and then start proving theorems. ; The theorems talk about dimensions, etc. If dimensions, etc., are guarded ; with weaker things (like keyword-listp) then you find yourself either having ; to open up array1p or forward chain from it. But array1p is fairly hideous. ; So we intend to keep it disabled and regard it as the atomic test that it is ; ok to use array processing functions. (and (symbolp name) (alistp l) (let ((header-keyword-list (cdr (assoc-eq :header l)))) (and (keyword-listp header-keyword-list) (let ((dimensions (cadr (assoc-keyword :dimensions header-keyword-list))) (maximum-length (cadr (assoc-keyword :maximum-length header-keyword-list)))) (and (true-listp dimensions) (equal (length dimensions) 1) (integerp (car dimensions)) (integerp maximum-length) (< 0 (car dimensions)) (<= (car dimensions) maximum-length) (<= maximum-length *maximum-positive-32-bit-integer*) (bounded-integer-alistp l (car dimensions)))))))) (defthm array1p-forward (implies (array1p name l) (and (symbolp name) (alistp l) (keyword-listp (cdr (assoc-eq :header l))) (true-listp (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) (equal (length (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) 1) (integerp (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (integerp (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))) (< 0 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (<= (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))) (<= (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))) *maximum-positive-32-bit-integer*) (bounded-integer-alistp l (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))))) :rule-classes :forward-chaining) (defthm array1p-linear (implies (array1p name l) (and (< 0 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (<= (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))) (<= (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))) *maximum-positive-32-bit-integer*))) :rule-classes :linear) (defun bounded-integer-alistp2 (l i j) (cond ((atom l) (null l)) (t (and (consp (car l)) (let ((key (caar l))) (and (or (eq key :header) (and (consp key) (let ((i1 (car key)) (j1 (cdr key))) (and (integerp i1) (integerp j1) (integerp i) (integerp j) (>= i1 0) (< i1 i) (>= j1 0) (< j1 j))))))) (bounded-integer-alistp2 (cdr l) i j))))) (defun assoc2 (i j l) (declare (xargs :guard (and (integerp i) (integerp j)))) (if (atom l) nil (if (and (consp (car l)) (consp (caar l)) (eql i (caaar l)) (eql j (cdaar l))) (car l) (assoc2 i j (cdr l))))) (defun array2p (name l) ":Doc-Section Arrays recognize a 2-dimensional array~/ Example Form: (array2p 'delta1 a)~/ General Form: (array2p name alist) where name and alist are arbitrary objects. This functions returns t if alist is a 2-dimensional Acl2 array. Otherwise it returns nil. The function operates in constant time if alist is the semantic value of name. See :DOC arrays." #-acl2-logic-only (cond ((symbolp name) (let ((prop (get name 'acl2-array))) (cond ((and prop (eq l (car prop)) (return-from array2p (= 2 (array-rank (cadr prop)))))))))) (and (symbolp name) (alistp l) (let ((header-keyword-list (cdr (assoc-eq :header l)))) (and (keyword-listp header-keyword-list) (let ((dimensions (cadr (assoc-keyword :dimensions header-keyword-list))) (maximum-length (cadr (assoc-keyword :maximum-length header-keyword-list)))) (and (true-listp dimensions) (equal (length dimensions) 2) (let ((d1 (car dimensions)) (d2 (cadr dimensions))) (and (integerp d1) (integerp d2) (integerp maximum-length) (< 0 d1) (< 0 d2) (<= (* d1 d2) maximum-length) (<= maximum-length *maximum-positive-32-bit-integer*) (bounded-integer-alistp2 l d1 d2))))))))) (defthm array2p-forward (implies (array2p name l) (and (symbolp name) (alistp l) (keyword-listp (cdr (assoc-eq :header l))) (true-listp (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) (equal (length (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) 2) (integerp (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (integerp (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (integerp (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))) (< 0 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (< 0 (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (<= (* (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))) (<= (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))) *maximum-positive-32-bit-integer*) (bounded-integer-alistp2 l (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))))) :rule-classes :forward-chaining) (defthm array2p-linear (implies (array2p name l) (and (< 0 (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (< 0 (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (<= (* (car (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) (cadr (cadr (assoc-keyword :dimensions (cdr (assoc-eq :header l)))))) (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l))))) (<= (cadr (assoc-keyword :maximum-length (cdr (assoc-eq :header l)))) *maximum-positive-32-bit-integer*))) :rule-classes :linear) #| (in-theory (disable array1p array2p)) |# (defun header (name l) (declare (xargs :guard (or (array1p name l) (array2p name l)))) ":Doc-Section Arrays return the header of a 1- or 2-dimensional array~/ Example Form: (header 'delta1 a)~/ General Form: (header name alist) where name is arbitrary and alist is a 1- or 2-dimensional array. This function returns the header of the array alist. The function operates in virtually constant time if alist is the semantic value of name. See :DOC arrays." #+acl2-logic-only (assoc-eq :header l) ; In the usual case, this function will take constant time regardless ; of where the header is in the alist. This makes the related ; functions for getting the fields of the header fast, too. #-acl2-logic-only (let ((prop (get name 'acl2-array))) (cond ((and prop (eq l (car prop))) (cadddr prop)) (t (assoc-eq :header l))))) (defun dimensions (name l) ":Doc-Section Arrays return the :DIMENSIONS from the header of a 1- or 2-dimensional array~/ Example Form: (dimensions 'delta1 a)~/ General Form: (dimensions name alist) where name is arbitrary and alist is a 1- or 2-dimensional array. This function returns the dimensions list of the array alist. That list will either be of the form (dim1) or (dim1 dim2), depending on whether alist is a 1- or 2-dimensional array. Dim1 and dim2 will be integers and are each one greater than the maximum legal corresponding index. Thus, if DIMENSIONS returns, say, '(100) for an array a named 'delta1, then (aref1 'delta1 a 99) is legal but (aref1 'delta1 a 100) violates the guards on aref1. DIMENSIONS operates in virtually constant time if alist is the semantic value of name. See :DOC arrays." (declare (xargs :guard (or (array1p name l) (array2p name l)))) (cadr (assoc-keyword :dimensions (cdr (header name l))))) (defun maximum-length (name l) ":Doc-Section Arrays return the :MAXIMUM-LENGTH from the header of a 1- or 2-dimensional array~/ Example Form: (maximum-length 'delta1 a)~/ General Form: (maximum-length name alist) where name is an arbitrary object and alist is a 1- or 2-dimensional array. This function returns the contents of the :MAXIMUM-LENGTH field of the HEADER of alist. Whenever an ASET1 or ASET2 would cause the length of the alist to exceed its maximum length, a COMPRESS1 or COMPRESS2 is done automatically to remove irrelevant pairs from the array. MAXIMUM-LENGTH operates in virtually constant time if alist is the semantic value of name. See :DOC arrays." (declare (xargs :guard (or (array1p name l) (array2p name l)))) (cadr (assoc-keyword :maximum-length (cdr (header name l))))) (defun default (name l) ":Doc-Section Arrays return the :DEFAULT from the header of a 1- or 2-dimensional array~/ Example Form: (default 'delta1 a)~/ General Form: (default name alist) where name is an arbitrary object and alist is a 1- or 2-dimensional array. This function returns the contents of the :DEFAULT field of the HEADER of alist. When AREF1 or AREF2 is used to obtain a value for an index (or index pair) not bound in alist, the default value is returned instead. Thus, the array alist may be thought of as having been initialized with the default value. DEFAULT operates in virtually constant time if alist is the semantic value of name. See :DOC arrays." (declare (xargs :guard (or (array1p name l) (array2p name l)))) (cadr (assoc-keyword :default (cdr (header name l))))) (defthm consp-assoc-1 (implies (and (eqlablep name) (alistp l)) (or (consp (assoc name l)) (equal (assoc name l) nil))) :rule-classes :type-prescription) (defthm consp-assoc-2 (implies (eqlable-alistp l) (or (consp (assoc name l)) (equal (assoc name l) nil))) :rule-classes :type-prescription) (defun aref1 (name l n) ":Doc-Section Arrays access the elments of a 1-dimensional array~/ Example Form: (aref1 'delta1 a (+ i k))~/ General Form: (aref1 name alist index) where name is a symbol, alist is a 1-dimensional array and index is a legal index into alist. This function returns the value associated with index in alist, or else the default value of the array. See :DOC arrays for details. This function executes in virtually constant time if alist is in fact the ``semantic value'' associated with name (see :DOC arrays). When it is not, aref1 must do a linear search through alist. In that case the correct answer is returned but a SLOW ARRAY comment is printed to the comment window. See :DOC slow-array-warning." #+acl2-logic-only (declare (xargs :guard (and (array1p name l) (integerp n) (>= n 0) (< n (car (dimensions name l)))))) #+acl2-logic-only (let ((x (assoc n l))) (cond ((null x) (default name l)) (t (cdr x)))) ; We are entitled to make the following declaration because of the ; guard. #-acl2-logic-only (declare (type (unsigned-byte 31) n)) #-acl2-logic-only (let ((prop (get name 'acl2-array))) (cond ((eq l (car prop)) (svref (the simple-vector (car (cdr prop))) n)) (t (slow-array-warning 'aref1 name) (let ((x (assoc n l))) (cond ((null x) (default name l)) (t (cdr x)))))))) (defun compress11 (name l i n default) (declare (xargs :guard (and (array1p name l) (integerp i) (integerp n) (<= i n)) :measure (- n i))) (cond ((= i n) nil) (t (let ((pair (assoc i l))) (cond ((or (null pair) (equal (cdr pair) default)) (compress11 name l (+ i 1) n default)) (t (cons pair (compress11 name l (+ i 1) n default)))))))) #-acl2-logic-only (defconstant *invisible-array-mark* 'acl2_invisible::|An Invisible Array Mark|) (defun compress1 (name l) ":Doc-Section Arrays remove irrelevant pairs from a 1-dimensional array~/ Example Form: (compress1 'delta1 a)~/ General Form: (compress1 name alist) where name is a symbol and alist is a 1-dimensional array named name. See :DOC arrays for details. Logically speaking, this function removes irrelevant pairs from alist, possibly shortening it. The function returns a new array, alist', of the same name and dimension as alist, that, under aref1, is everywhere equal to alist. That is, (aref1 name alist' i) is (aref1 name alist i), for all legal indices i. Alist' may be shorter than alist and the non-irrelevant pairs may occur in a different order than in alist. Practically speaking, this function plays an important role in the efficient implementation of aref1. In addition to creating the new array, alist', compress1 makes that array the ``semantic value'' of name and allocates a raw lisp array to name. For each legal index, i, that raw lisp array contains (aref1 name alist' i) in slot i. Thus, subsequent aref1 operations can be executed in virtually constant time provided they are given name and the alist' returned by the most recently executed compress1 or aset1 on name. See :DOC arrays." #+acl2-logic-only (declare (xargs :guard (array1p name l))) #+acl2-logic-only (cons (header name l) (compress11 name l 0 (car (dimensions name l)) (default name l))) #-acl2-logic-only (let* ((old (get name 'acl2-array)) (header (header name l)) (length (car (cadr (assoc-keyword :dimensions (cdr header))))) (maximum-length (cadr (assoc-keyword :maximum-length (cdr header)))) (default (cadr (assoc-keyword :default (cdr header)))) old-car ar in-order) ; Get an array that is all filled with the special mark ; *invisible-array-mark*. (cond ((and old (= 1 (array-rank (cadr old))) (= (length (cadr old)) length)) (setq old-car (car old)) (setf (car old) *invisible-array-mark*) (setq ar (cadr old)) (do ((i (1- length) (1- i))) ((< i 0)) (declare (fixnum i)) (setf (svref ar i) *invisible-array-mark*))) (t (setq ar (make-array length :initial-element *invisible-array-mark*)))) ; Store the value of each pair under its key (unless it is covered by ; an earlier pair with the same key). (do ((tl l (cdr tl))) ((null tl)) (let ((index (caar tl))) (cond ((eq index :header) nil) ((eq *invisible-array-mark* (svref ar index)) (setf (svref ar index) (cdar tl)))))) ; Determine whether l is already is in normal form (header first, ; strictly ascending keys, no default values, no extra header.) (setq in-order t) (cond ((eq (caar l) :header) (do ((tl (cdr l) (cdr tl))) (nil) (cond ((or (eq (caar tl) :header) (eq (car (cadr tl)) :header)) (setq in-order nil) (return nil)) ((null (cdr tl)) (return nil)) ((or (>= (the (unsigned-byte 31) (caar tl)) (the (unsigned-byte 31) (car (cadr tl)))) (equal (cdr (car tl)) default)) (setq in-order nil) (return nil))))) (t (setq in-order nil))) (let ((num 1) x max-ar) (declare (fixnum num)) ; In one pass, set x to the value to be returned, put defaults into the array ; where the invisible mark still sits, and calculate the length of x. (cond (in-order (do ((i (1- length) (1- i))) ((< i 0)) (declare (fixnum i)) (let ((val (svref ar i))) (cond ((eq *invisible-array-mark* val) (setf (svref ar i) default)) (t (setq num (the fixnum (1+ num))))))) (setq x l)) (t (do ((i (1- length) (1- i))) ((< i 0)) (declare (fixnum i)) (let ((val (svref ar i))) (cond ((eq *invisible-array-mark* val) (setf (svref ar i) default)) ((equal val default) nil) (t (push (cons i val) x) (setq num (the fixnum (1+ num))))))) (setq x (cons header x)))) (cond (old (setq max-ar (caddr old)) (setf (aref (the (array (unsigned-byte 31) (*)) max-ar) 0) (the (unsigned-byte 31) (- maximum-length num)))) (t (setq max-ar (make-array 1 :initial-contents (list (- maximum-length num)) :element-type '(unsigned-byte 31))))) (cond (old (setf (cadr old) ar) (setf (cadddr old) header) ; If the old car is equal to x, then we put the old pointer back into the ; car of the 'acl2-array property rather than the new pointer. ; This has the good effect of preserving the validity of any old ; copies of the array. It is clear the code below is correct, since ; we are putting down an equal structure in place of a newly consed up ; one. But why go out of our way? Why not just (setf (car old) x)? ; In fact, once upon a time, that is what we did. But it bit us when ; we tried to prove theorems in a post-:init world. ; When Acl2 is loaded the Common Lisp global constant ; *type-set-binary-+-table* is defined by (defconst & (compress2 ...)). ; It is set to some list, here called ptr1, built by compress2 (which ; contains code analogous to that we are documenting here in ; compress1). When ptr1 is built it is stored as the car of the ; 'acl2-array property of the array name 'type-set-binary-+-table, because at ; the time Acl2 is loaded, there is no old 'acl2-array property on ; that name. Suppose we then :init, loading the Acl2 source code into ; the current Acl2 world. That will execute the same defconst, in ; the acl2-logic-only setting. Compress2 is called and will build a ; new structure, ptr2 (called x in this code). Upon finishing, it ; will (according to the code here) find that ptr2 is equal to ptr1 ; and will put ptr1 into the car of the 'acl2-array property of ; 'type-set-binary-+-table. It will return ptr1. That will become the value ; of the 'const getprop of '*type-set-binary-+-table* in the ; current-acl2-world. When that world is installed, we will note that ; a non-virgin name, *type-set-binary-+-table*, is being defconst'd and so ; we will DO NOTHING, leaving ptr1 as the value of the Common Lisp ; global contant *type-set-binary-+-table*. So, because of the code below, ; all logical copies of this array are represented by ptr1. ; In the old days, compress2 put ptr2 into the car of the 'acl2-array ; property of 'type-set-binary-+-table. It returned ptr2, which thus became ; the value of the 'const getprop of '*type-set-binary-+-table*. When ; that world was installed, we noted that a non-virgin name was being ; defconst'd and we DID NOTHING, leaving ptr1 as the value of the ; global constant *type-set-binary-+-table*. Subsequent references to ; *type-set-binary-+-table* in our type-set code, e.g., as occurred when one ; tried to prove theorems about + after an :init, provoked the ; slow-array-warning. ; This preservation (eq) of the old array is also crucial to the way ; recompress-global-enabled-structure works. That function extracts ; the :theory-array from the current global-enabled-structure -- said ; theory-array having been produced by a past call of compress1 and ; hence guaranteed to be sorted etc. It calls compress1 on it, which ; side-effects the underlying von Neumann array but returns the very ; same (eq) structure. We then discard that structure, having only ; wanted the side effect! Before we exploited this, we had to cons up ; a new global-enabled-structure and rebind 'global-enabled-stucture ; in the world. This had the bad effect of sometimes putting multiple ; bindings of that variable. (setf (car old) (cond ((equal old-car x) old-car) (t x))) (car old)) (t (setf (get name 'acl2-array) (list x ar max-ar header)) x))))) (defthm array1p-cons (implies (and (< n (caadr (assoc-keyword :dimensions (cdr (assoc-eq :header l))))) (not (< n 0)) (integerp n) (array1p name l)) (array1p name (cons (cons n val) l))) :hints (("Goal" :in-theory (enable array1p)))) (defun aset1 (name l n val) ":Doc-Section Arrays set the elments of a 1-dimensional array~/ Example Form: (aset1 'delta1 a (+ i k) 27)~/ General Form: (aset1 name alist index val) where name is a symbol, alist is a 1-dimensional array named name, index is a legal index into alist, and val is an arbitrary object. See :DOC arrays for details. Roughly speaking this function ``modifies'' alist so that the value associated with index is val. More precisely, it returns a new array, alist', of the same name and dimension as alist that, under aref1, is everywhere equal to alist except at index where the result is val. That is, (aref1 name alist' i) is (aref1 name alist i) for all legal indices i except index, where (aref1 name alist' i) is val. In order to ``modify'' alist, aset1 conses a new pair onto the front. If the length of the resulting alist exceeds the :MAXIMUM-LENGTH entry in the array header, aset1 compresses the array as with compress1. It is generally expected that the ``semantic value'' of name will be alist (see :DOC arrays). This function operates in virtually constant time whether this condition is true or not (unless the compress operation is required). But the value returned by this function cannot be used efficiently by subsequent aset1 operations unless alist is the semantic value of name when aset1 is executed. Thus, if the condition is not true, aset1 prints a SLOW ARRAY warning to the comment window. See :DOC slow-array-warning." #+acl2-logic-only (declare (xargs :guard (and (array1p name l) (integerp n) (>= n 0) (< n (car (dimensions name l)))))) #+acl2-logic-only (let ((l (cons (cons n val) l))) (cond ((> (length l) (maximum-length name l)) (compress1 name l)) (t l))) #-acl2-logic-only (declare (type (unsigned-byte 31) n)) #-acl2-logic-only (let ((prop (get name 'acl2-array))) (cond ((eq l (car prop)) (let* ((ar (cadr prop)) (to-go (aref (the (array (unsigned-byte 31) (*)) (caddr prop)) 0))) (declare (type (unsigned-byte 31) to-go) (simple-vector ar)) (cond ((eql (the (unsigned-byte 31) to-go) 0) (setf (car prop) *invisible-array-mark*) (setf (aref ar n) val) (let* ((header (cadddr prop)) (length (car (cadr (assoc-keyword :dimensions (cdr header))))) (maximum-length (cadr (assoc-keyword :maximum-length (cdr header)))) (default (cadr (assoc-keyword :default (cdr header)))) (x nil) (num 1)) (declare (fixnum num length)) (declare (type (unsigned-byte 31) maximum-length)) (do ((i (1- length) (1- i))) ((< i 0)) (declare (fixnum i)) (let ((val (svref ar (the fixnum i)))) (cond ((equal val default) nil) (t (push (cons i val) x) (setq num (the fixnum (1+ num))))))) (setq x (cons header x)) (setf (aref (the (array (unsigned-byte 31) (*)) (caddr prop)) 0) (the (unsigned-byte 31) (- maximum-length num))) (setf (car prop) x) x)) (t (let ((x (cons (cons n val) l))) (setf (car prop) x) (setf (svref (the simple-vector ar) n) val) (setf (aref (the (array (unsigned-byte 31) (*)) (caddr prop)) 0) (the (unsigned-byte 31) (1- to-go))) x))))) (t (let ((l (cons (cons n val) l))) (slow-array-warning 'aset1 name) (cond ((> (length l) (maximum-length name l)) (compress1 name l)) (t l))))))) (defun aref2 (name l i j) ":Doc-Section Arrays access the elments of a 2-dimensional array~/ Example Form: (aref2 'delta1 a i j)~/ General Form: (aref2 name alist i j) where name is a symbol, alist is a 2-dimensional array and i and j are legal indices into alist. This function returns the value associated with (i . j) in alist, or else the default value of the array. See :DOC arrays for details. This function executes in virtually constant time if alist is in fact the ``semantic value'' associated with name (see :DOC arrays). When it is not, aref2 must do a linear search through alist. In that case the correct answer is returned but a SLOW ARRAY comment is printed to the comment window. See :DOC slow-array-warning." #+acl2-logic-only (declare (xargs :guard (and (array2p name l) (integerp i) (>= i 0) (< i (car (dimensions name l))) (integerp j) (>= j 0) (< j (cadr (dimensions name l)))))) #+acl2-logic-only (let ((x (assoc2 i j l))) (cond ((null x) (default name l)) (t (cdr x)))) #-acl2-logic-only (declare (type (unsigned-byte 31) i j)) #-acl2-logic-only (let ((prop (get name 'acl2-array))) (cond ((eq l (car prop)) (aref (the (array t (* *)) (car (cdr prop))) i j)) (t (slow-array-warning 'aref2 name) (let ((x (assoc2 i j l))) (cond ((null x) (default name l)) (t (cdr x)))))))) (defun compress211 (name l i x j default) (declare (xargs :guard (and (array2p name l) (integerp x) (integerp i) (integerp j) (<= x j)) :measure (- j x))) (cond ((= x j) nil) (t (let ((pair (assoc2 i x l))) (cond ((or (null pair) (equal (cdr pair) default)) (compress211 name l i (+ 1 x) j default)) (t (cons pair (compress211 name l i (+ 1 x) j default)))))))) (defun compress21 (name l n i j default) (declare (xargs :guard (and (array2p name l) (integerp n) (integerp i) (integerp j) (<= n i) (<= 0 j)) :measure (- i n))) (cond ((= n i) nil) (t (append (compress211 name l n 0 j default) (compress21 name l (+ n 1) i j default))))) (defun compress2 (name l) ":Doc-Section Arrays remove irrelevant pairs from a 2-dimensional array~/ Example Form: (compress2 'delta1 a)~/ General Form: (compress2 name alist) where name is a symbol and alist is a 2-dimensional array named name. See :DOC arrays for details. Logically speaking, this function removes irrelevant pairs from alist, possibly shortening it. The function returns a new array, alist', of the same name and dimension as alist, that, under aref2, is everywhere equal to alist. That is, (aref2 name alist' i j) is (aref2 name alist i j), for all legal indices i and j. Alist' may be shorter than alist and the non-irrelevant pairs may occur in a different order in alist' than in alist. Practically speaking, this function plays an important role in the efficient implementation of aref2. In addition to creating the new array, alist', compress2 makes that array the ``semantic value'' of name and allocates a raw lisp array to name. For all legal indices, i and j, that raw lisp array contains (aref2 name alist' i j) in slot i,j. Thus, subsequent aref2 operations can be executed in virtually constant time provided they are given name and the alist' returned by the most recently executed compress2 or aset2 on name. See :DOC arrays." #+acl2-logic-only (declare (xargs :guard (array2p name l))) #+acl2-logic-only (cons (header name l) (compress21 name l 0 (car (dimensions name l)) (cadr (dimensions name l)) (default name l))) #-acl2-logic-only (let* ((old (get name 'acl2-array)) (header (header name l)) (dimension1 (car (cadr (assoc-keyword :dimensions (cdr header))))) (dimension2 (cadr (cadr (assoc-keyword :dimensions (cdr header))))) (maximum-length (cadr (assoc-keyword :maximum-length (cdr header)))) (default (cadr (assoc-keyword :default (cdr header)))) old-car ar in-order) ; Get an array that is filled with the special mark *invisible-array-mark*. (cond ((and old (= 2 (array-rank (cadr old))) (and (= dimension1 (array-dimension (cadr old) 0)) (= dimension2 (array-dimension (cadr old) 1)))) (setq old-car (car old)) (setf (car old) *invisible-array-mark*) (setq ar (cadr old)) (let ((ar ar)) (declare (type (array t (* *)) ar)) (do ((i (1- dimension1) (1- i))) ((< i 0)) (declare (fixnum i)) (do ((j (1- dimension2) (1- j))) ((< j 0)) (declare (fixnum j)) (setf (aref ar i j) *invisible-array-mark*))))) (t (setq ar (make-array (list dimension1 dimension2) :initial-element *invisible-array-mark*)))) (let ((ar ar)) (declare (type (array t (* *)) ar)) ; Store the value of each pair under its key (unless it is covered by ; an earlier pair with the same key). (do ((tl l (cdr tl))) ((null tl)) (let ((index (caar tl))) (cond ((eq index :header) nil) ((eq *invisible-array-mark* (aref ar (the fixnum (car index)) (the fixnum (cdr index)))) (setf (aref ar (the fixnum (car index)) (the fixnum (cdr index))) (cdar tl)))))) ; Determine whether l is already in normal form (header first, ; strictly ascending keys, no default values, n extra header.) (setq in-order t) (cond ((eq (caar l) :header) (do ((tl (cdr l) (cdr tl))) (nil) (cond ((or (eq (caar tl) :header) (eq (car (cadr tl)) :header)) (setq in-order nil) (return nil)) ((null (cdr tl)) (return nil)) ((or (> (the (unsigned-byte 31) (caaar tl)) (the (unsigned-byte 31) (caaadr tl))) (and (= (the (unsigned-byte 31) (caaar tl)) (the (unsigned-byte 31) (caaadr tl))) (> (the (unsigned-byte 31) (cdaar tl)) (the (unsigned-byte 31) (cdaadr tl)))) (equal (cdr (car tl)) default)) (setq in-order nil) (return nil))))) (t (setq in-order nil))) (let ((x nil) (num 1) max-ar) (declare (type (unsigned-byte 31) num)) ; In one pass, set x to the value to be returned, put defaults into the array ; where the invisible mark still sits, and calculate the length of x. (cond (in-order (do ((i (1- dimension1) (1- i))) ((< i 0)) (declare (fixnum i)) (do ((j (1- dimension2) (1- j))) ((< j 0)) (declare (fixnum j)) (let ((val (aref ar i j))) (cond ((eq *invisible-array-mark* val) (setf (aref ar i j) default)) (t (setq num (the (unsigned-byte 31) (1+ num)))))))) (setq x l)) (t (do ((i (1- dimension1) (1- i))) ((< i 0)) (declare (fixnum i)) (do ((j (1- dimension2) (1- j))) ((< j 0)) (declare (fixnum j)) (let ((val (aref ar i j))) (cond ((eq *invisible-array-mark* val) (setf (aref ar i j) default)) ((equal val default) nil) (t (push (cons (cons i j) val) x) (setq num (the (unsigned-byte 31) (1+ num)))))))) (setq x (cons header x)))) (cond (old (setq max-ar (caddr old)) (setf (aref (the (array (unsigned-byte 31) (*)) max-ar) 0) (the (unsigned-byte 31) (- maximum-length num)))) (t (setq max-ar (make-array 1 :initial-contents (list (- maximum-length num)) :element-type '(unsigned-byte 31))))) (cond (old (setf (cadr old) ar) (setf (cadddr old) header) (setf (car old) (cond ((equal old-car x) old-car) (t x))) (car old)) (t (setf (get name 'acl2-array) (list x ar max-ar header)) x)))))) (defthm consp-assoc2 (implies (and (integerp i) (integerp j)) (or (consp (assoc2 i j l)) (equal (assoc2 i j l) nil))) :rule-classes :type-prescription) (defthm array2p-cons (implies (and (< j (cadr (dimensions name l))) (not (< j 0)) (integerp j) (< i (car (dimensions name l))) (not (< i 0)) (integerp i) (array2p name l)) (array2p name (cons (cons (cons i j) val) l))) :hints (("Goal" :in-theory (enable array2p)))) (defun aset2 (name l i j val) ":Doc-Section Arrays set the elments of a 2-dimensional array~/ Example Form: (aset2 'delta1 a i j 27)~/ General Form: (aset2 name alist i j val) where name is a symbol, alist is a 2-dimensional array named name, i and j are legal indices into alist, and val is an arbitrary object. See :DOC arrays for details. Roughly speaking this function ``modifies'' alist so that the value associated with (i . j) is val. More precisely, it returns a new array, alist', of the same name and dimension as alist that, under aref2, is everywhere equal to alist except at (i . j) where the result is val. That is, (aref2 name alist' x y) is (aref2 name alist x y) for all legal indices x y except i and j where (aref2 name alist' i j) is val. In order to ``modify'' alist, aset2 conses a new pair onto the front. If the length of the resulting alist exceeds the :MAXIMUM-LENGTH entry in the array header, aset2 compresses the array as with compress1. It is generally expected that the ``semantic value'' of name will be alist (see :DOC arrays). This function operates in virtually constant time whether this condition is true or not (unless the compress operation is required). But the value returned by this function cannot be used efficiently by subsequent aset2 operations unless alist is the semantic value of name when aset2 is executed. Thus, if the condition is not true, aset2 prints a SLOW ARRAY warning to the comment window. See :DOC slow-array-warning." #+acl2-logic-only (declare (xargs :guard (and (array2p name l) (integerp i) (>= i 0) (< i (car (dimensions name l))) (integerp j) (>= j 0) (< j (cadr (dimensions name l)))))) #+acl2-logic-only (let ((l (cons (cons (cons i j) val) l))) (cond ((> (length l) (maximum-length name l)) (compress2 name l)) (t l))) #-acl2-logic-only (declare (type (unsigned-byte 31) i j)) #-acl2-logic-only (let ((prop (get name 'acl2-array))) (cond ((eq l (car prop)) (let* ((ar (car (cdr prop))) (to-go (aref (the (array (unsigned-byte 31) (*)) (caddr prop)) 0))) (declare (type (unsigned-byte 31) to-go)) (declare (type (array t (* *)) ar)) (cond ((eql (the (unsigned-byte 31) to-go) 0) (setf (car prop) *invisible-array-mark*) (setf (aref ar i j) val) (let* ((header (cadddr prop)) (d1 (car (cadr (assoc-keyword :dimensions (cdr header))))) (d2 (cadr (cadr (assoc-keyword :dimensions (cdr header))))) (maximum-length (cadr (assoc-keyword :maximum-length (cdr header)))) (default (cadr (assoc-keyword :default (cdr header)))) (x nil) (num 1)) (declare (type (unsigned-byte 31) num d1 d2 maximum-length)) (do ((i (1- d1) (1- i))) ((< i 0)) (declare (fixnum i)) (do ((j (1- d2) (1- j))) ((< j 0)) (declare (fixnum j)) (let ((val (aref ar (the fixnum i) (the fixnum j)))) (cond ((equal val default) nil) (t (push (cons (cons i j) val) x) (setq num (the (unsigned-byte 31) (1+ num)))))))) (setq x (cons header x)) (setf (aref (the (array (unsigned-byte 31) (*)) (caddr prop)) 0) (the (unsigned-byte 31) (- maximum-length num))) (setf (car prop) x) x)) (t (let ((x (cons (cons (cons i j) val) l))) (setf (car prop) x) (setf (aref ar i j) val) (setf (aref (the (array (unsigned-byte 31) (*)) (caddr prop)) 0) (the (unsigned-byte 31) (1- to-go))) x))))) (t (let ((l (cons (cons (cons i j) val) l))) (slow-array-warning 'aset2 name) (cond ((> (length l) (maximum-length name l)) (compress2 name l)) (t l))))))) ; MULTIPLE VALUES, done our way, not Common Lisp's way. ; We implement an efficient mechanism for returning multiple values, ; with an applicative semantics. Formally, the macro mv is just the ; same as ``list''; one can use it to return a list of arbitrary ; objects. However, the translator for Acl2 checks that mv is in fact ; only used to return values to mv-let, a special form of let which ; picks out the members of a list but does not hold on to the cdrs of ; the list. Because mv-let does not hold on to cdrs, we are able to ; implement mv so that the list is never actually consed up. Instead, ; the elements of the list are passed to mv-let in global locations. ; *number-of-return-values* may be increased (but not reduced) to be ; as high as required to increase the allowed number of Acl2 return ; values. However, if it is increased, the entire Acl2 system must be ; recompiled. Currently, the first 10 locations are handled specially ; in releases of AKCL past 206. #-acl2-logic-only (progn (defconstant *number-of-return-values* 32) (defparameter *return-values* (let (ans) (do ((i *number-of-return-values* (1- i))) ((= i 0)) (push (intern (format nil "*return-value-~a*" i)) ans)) ans)) (defmacro declare-return-values () (cons 'progn (declare-return-values1))) (defun declare-return-values1 () (mapcar #'(lambda (v) `(defvar ,v)) *return-values*)) (eval-when (load eval compile) (declare-return-values)) (defun in-akcl-with-mv-set-and-ref () (member :akcl-set-mv *features*)) (defconstant *akcl-mv-ref-and-set-inclusive-upper-bound* 9) (defmacro special-location (i) (cond ((or (not (integerp i)) (< i 1)) (acl2::interface-er "Macro calls of special-location must have an explicit ~ positive integer argument, which is not the case with ~p0." i)) ((> i *number-of-return-values*) (acl2::interface-er "Not enough built-in return values.")) (t (nth (1- i) *return-values*)))) (defmacro set-mv (i v) (cond ((or (not (integerp i)) (< i 1)) (interface-er "The first argument to a macro call of set-mv must be ~ an explicit positive integer, but that is not the case ~ with ~A." i)) ((and (in-akcl-with-mv-set-and-ref) (<= i *akcl-mv-ref-and-set-inclusive-upper-bound*)) `(system::set-mv ,i ,v)) (t `(setf (special-location ,i) ,v)))) (defmacro mv-ref (i) (cond ((or (not (integerp i)) (< i 1)) (interface-er "The argument to macro calls of mv-ref must be an ~ explicit positive integer, but that is not the case with ~p0." i)) ((and (in-akcl-with-mv-set-and-ref) (<= i *akcl-mv-ref-and-set-inclusive-upper-bound*)) `(system::mv-ref ,i)) (t `(special-location ,i)))) (defmacro mv-refs (i) `(case ,i ,@(let (ans) (do ((j *number-of-return-values* (1- j))) ((= j 0)) (push `(,j (list ,@(let (ans) (do ((k j (1- k))) ((= k 0)) (push `(mv-ref ,k) ans)) ans))) ans)) ans) (otherwise (interface-er "Not enough return values.")))) ) (defun cdrn (x i) (declare (xargs :guard (and (integerp i) (<= 0 i)))) (cond ((eql i 0) x) (t (cdrn (list 'cdr x) (- i 1))))) (defun make-nths (args call i) (declare (xargs :guard (and (true-listp args) (integerp i)))) (cond ((null args) nil) (t (cons (list (car args) (list 'nth i call)) (make-nths (cdr args) call (+ i 1)))))) #-acl2-logic-only (defparameter *most-recent-multiplicity* 1) #-acl2-logic-only (defun mv-bindings (lst) ; Gensym a var for every element of lst except the last and pair ; that var with its element in a doublet. Return the list of doublets. (cond ((null (cdr lst)) nil) (t (cons (list (gensym) (car lst)) (mv-bindings (cdr lst)))))) #-acl2-logic-only (defun mv-set-mvs (bindings i) (cond ((null bindings) nil) (t (cons `(set-mv ,i ,(caar bindings)) (mv-set-mvs (cdr bindings) (1+ i)))))) (defmacro mv (&rest l) #+acl2-logic-only (cons 'list l) #-acl2-logic-only ; In an earlier version of the mv macro, we had a terrible bug. ; (mv a b ... z) expanded to ; (LET ((#:G1 a)) ; (SET-MV 1 b) ; ... ; (SET-MV k z) ; (SETQ *MOST-RECENT-MULTIPLICITY* 3) ; #:G1) ; Note that if the evaluation of z uses multiple values then it ; overwrites the earlier SET-MV. Now this expansion is safe if there ; are only two values because the only SET-MV is done after the second ; value is computed. If there are three or more value forms, then ; this expansion is also safe if all but the first two are atomic. ; For example, (mv & & (killer)) is unsafe because (killer) may ; overwrite the SET-MV, but (mv & & STATE) is safe because the ; evaluation of an atomic form is guaranteed not to overwrite SET-MV ; settings. In general, all forms after the second must be atomic for ; the above expansion to be used. (cond ((atom-listp (cddr l)) ; We use the old expansion because it is safe and more efficient. (let ((v (gensym))) `(let ((,v ,(car l))) ,@(let (ans) (do ((tl (cdr l) (cdr tl)) (i 1 (1+ i))) ((null tl)) (push `(set-mv ,i ,(car tl)) ans)) (nreverse ans)) (setq *most-recent-multiplicity* ,(length l)) ,v))) (t ; We expand (mv a b ... y z) to ; (LET ((#:G1 a) ; (#:G2 b) ; ... ; (#:Gk y)) ; (SET-MV k z) ; (SET-MV 1 #:G2) ; ... ; (SET-MV k-1 #:Gk) ; (SETQ *MOST-RECENT-MULTIPLICITY* k) ; #:G1) (let ((bindings (mv-bindings l))) `(let ,bindings (set-mv ,(1- (length l)) ,(car (last l))) ,@(mv-set-mvs (cdr bindings) 1) (setq *most-recent-multiplicity* ,(length l)) ,(caar bindings)))))) (defmacro mv-let (&rest rst) ; Warning: If the final logical form of a translated mv-let is ; changed, be sure to reconsider translated-acl2-unwind-protectp. ":Doc-Section Miscellaneous calling multi-valued Acl2 functions~/ Example Form: (mv-let (x y z) ; local variables (mv 1 2 3) ; multi-valued expression (declare (ignore y)) ; optional declarations (cons x z)) ; body The form above binds the three ``local variables,'' x, y, and z, to the three results returned by the multi-valued expression and then evaluates the body. The result is '(1 . 3). The second local, y, is declared ignored. The multi-valued expression can be any Acl2 expression that returns k results, where k is the number of local variables listed. Often however it is simply the application of a k-valued function. Mv-let is the standard way to invoke a multi-valued function when the caller must manipulate the vector of results returned.~/ General Form: (mv-let (var1 ... vark) term body) or (mv-let (var1 ... vark) term (declare ...) ... (declare ...) body) where the vari are distinct variables, term is a term that returns k results and mentions only variables bound in the environment containing the mv-let expression, and body is a term mentioning only the vari and variables bound in the environment containing the mv-let. Each vari must occur in body unless it is declared ignored in one of the optional declare forms. The value of the mv-let term is the result of evaluating body in an environment in which the vari are bound, in order, to the k results obtained by evaluating term in the environment containing the mv-let. Here is an extended example that illustrates both the definition of a multi-valued function and the use of mv-let to call it. Consider a simple binary tree whose interior nodes are conses and whose leaves are non-conses. Suppose we often need to know the number, n, of interior nodes of such a tree, the list, syms, of symbols that occur as leaves, and the list, ints, of integers that occur as leaves. (Observe that there may be leaves that are neither symbols nor integers.) Using a multi-valued function we can collect all three results in one pass. Here is the first of two definitions of the desired function. This definition is ``primitive recursive'' in that it has only one argument and that argument is reduced in size on every recursion. (defun count-and-collect (x) ; We return three results, (mv n syms ints) as described above. (cond ((atom x) ; X is a leaf. Thus, there are 0 interior nodes, and depending on ; whether x is a symbol, an integer, or something else, we return ; the list containing x in as the appropriate result. (cond ((symbolp x) (mv 0 (list x) nil)) ((integerp x)(mv 0 nil (list x))) (t (mv 0 nil nil)))) (t ; X is an interior node. First we process the car, binding n1, syms1, and ; ints1 to the answers. (mv-let (n1 syms1 ints1) (count-and-collect (car x)) ; Next we process the cdr, binding n2, syms2, and ints2. (mv-let (n2 syms2 ints2) (count-and-collect (car x)) ; Finally, we compute the answer for x from those obtained for its car ; and cdr, remembering to increment the node count by one for x itself. (mv (1+ (+ n1 n2)) (append syms1 syms2) (append ints1 ints2))))))) This use of multiple values to ``do several things at once'' is very common in Acl2. However, the function above is inefficient because it appends syms1 to syms2 and ints1 to ints2, copying the list structures of syms1 and ints1 in the process. By adding ``accumulators'' to the function, we can make the code more efficient. (defun count-and-collect1 (x n syms ints) (cond ((atom x) (cond ((symbolp x) (mv n (cons x syms) ints)) ((integerp x) (mv n syms (cons x ints))) (t (mv n syms ints)))) (t (mv-let (n2 syms2 ints2) (count-and-collect1 (cdr x) (1+ n) syms ints) (count-and-collect1 (car x) n2 syms2 ints2))))) We claim that (count-and-collect x) returns the same triple of results as (count-and-collect1 x 0 nil nil). The reader is urged to study this claim until convinced that it is true and that the latter method of computing the results is more efficient. One might try proving the theorem (defthm count-and-collect-theorem (equal (count-and-collect1 x 0 nil nil) (count-and-collect x))). Hint: The inductive proof requires attacking a more general theorem." #+acl2-logic-only (list* 'let (make-nths (car rst) (cadr rst) 0) (cddr rst)) #-acl2-logic-only (cond ((> (length (car rst)) (+ 1 *number-of-return-values*)) (interface-er "Need more *return-values*. Increase ~ *number-of-return-values* and recompile Acl2.")) (t `(let ((,(car (car rst)) (prog1 ,(cadr rst) (setq *most-recent-multiplicity* 1))) ,@(let (ans) (do ((tl (cdr (car rst)) (cdr tl)) (i 1 (1+ i))) ((null tl)) (push (list (car tl) `(mv-ref ,i)) ans)) (nreverse ans))) ,@ (cddr rst))))) #-acl2-logic-only ; In aref and aset, we cheat by sometimes not returning a value. ?? ; Is this really still true? Hence, we need to make sure that the ; second value gets set. Thus: (eval-when (load) (mv 1 2)) (defun ascii-code (x) (declare (xargs :guard (and (characterp x) (standard-char-p x)))) #+acl2-logic-only (cdr (assoc x '((#\Tab . 9) (#\Newline . 10) (#\Page . 12) (#\Space . 32) (#\Rubout . 127) (#\! . 33) (#\" . 34) (#\# . 35) (#\$ . 36) (#\% . 37) (#\& . 38) (#\' . 39) (#\( . 40) (#\) . 41) (#\* . 42) (#\+ . 43) (#\, . 44) (#\- . 45) (#\. . 46) (#\/ . 47) (#\0 . 48) (#\1 . 49) (#\2 . 50) (#\3 . 51) (#\4 . 52) (#\5 . 53) (#\6 . 54) (#\7 . 55) (#\8 . 56) (#\9 . 57) (#\: . 58) (#\; . 59) (#\< . 60) (#\= . 61) (#\> . 62) (#\? . 63) (#\@ . 64) (#\A . 65) (#\B . 66) (#\C . 67) (#\D . 68) (#\E . 69) (#\F . 70) (#\G . 71) (#\H . 72) (#\I . 73) (#\J . 74) (#\K . 75) (#\L . 76) (#\M . 77) (#\N . 78) (#\O . 79) (#\P . 80) (#\Q . 81) (#\R . 82) (#\S . 83) (#\T . 84) (#\U . 85) (#\V . 86) (#\W . 87) (#\X . 88) (#\Y . 89) (#\Z . 90) (#\[ . 91) (#\\ . 92) (#\] . 93) (#\^ . 94) (#\_ . 95) (#\` . 96) (#\a . 97) (#\b . 98) (#\c . 99) (#\d . 100) (#\e . 101) (#\f . 102) (#\g . 103) (#\h . 104) (#\i . 105) (#\j . 106) (#\k . 107) (#\l . 108) (#\m . 109) (#\n . 110) (#\o . 111) (#\p . 112) (#\q . 113) (#\r . 114) (#\s . 115) (#\t . 116) (#\u . 117) (#\v . 118) (#\w . 119) (#\x . 120) (#\y . 121) (#\z . 122) (#\{ . 123) (#\| . 124) (#\} . 125) (#\~ . 126)))) #-acl2-logic-only (the (integer 0 127) (aref (the (array fixnum (*)) *char-to-ascii*) (the fixnum (char-code (the character x)))))) (defthm ascii-code-nonnegative-integerp (implies (and (characterp x) (standard-char-p x)) (and (integerp (ascii-code x)) (<= 0 (ascii-code x)))) :rule-classes :type-prescription :hints (("Goal" :in-theory (enable standard-char-p)))) #| (in-theory (disable ascii-code)) |# (deflabel state :doc ":Doc-Section Miscellaneous the von Neumannesque Acl2 state object~/ Acl2 supports several facilities of a truly von Neumannesque state machine character, including file io and global variables. Logically speaking, the state is a true list of the 14 components described by typing :more. There is a ``current'' state object at the top-level of the Acl2 command loop. This object is understood to be the value of what would otherwise be the free variable STATE appearing in top-level input. When any command returns a state object as one of its values, that object becomes the new current state. But Acl2 provides von Neumann style speed for state operations by maintaining only one physical (as opposed to logical) state object. Operations on the state are in fact destructive. This implementation does not violate the applicative semantics because we enforce certain draconian syntactic rules regarding the use of state objects. For example, one cannot ``hold on'' to an old state, access the components of a state arbitrarily, or ``modify'' a state object without passing it on to subsequent state-sensitive functions.~/ Every routine that uses the state facilities (e.g. does io, or calls a routine that does io), must be passed a ``state object.'' And a routine must return a state object if the routine modifies the state in any way. Rigid syntactic rules governing the use of state objects are enforced by the function translate, through which all Acl2 user input first passes. State objects can only be ``held'' in the formal parameter STATE, never in any other formal parameter and never in any structure (excepting a multiple-values return list field which is always a state object). State objects can only be accessed with the primitives we specifically permit. Thus, for example, one cannot ask, in code to be executed, for the length of STATE or the CAR of STATE. In the statement and proof of theorems, there are no syntactic rules prohibiting abitrary treatment of state objects. Logically speaking, a state object is a true list whose members are as follows: OPEN-INPUT-CHANNELS, an alist with keys that are symbols in package \"ACL2-INPUT-CHANNEL\". The value (cdr) of each pair has the form ((:header type file-name open-time) . elements), where type is one of :character, :byte, or :object and elements is a list of things of the corresponding type, i.e. characters, integers of type (mod 255), or Lisp objects in our theory. File-name is a string. Open-time is an integer. See :DOC io. OPEN-OUTPUT-CHANNELS, an alist with keys that are symbols in package \"ACL2-OUTPUT-CHANNEL\". The value of a pair has the form ((:header type file-name open-time) . current-contents). See :DOC io. GLOBAL-TABLE, an alist associating symbols (to be used as ``global variables'') with values. See :DOC assign and :DOC @. T-STACK, a list of abritrary objects accessed and changed by the functions AREF-T-STACK and ASET-T-STACK. 32-BIT-INTEGER-STACK, a list of arbitrary 32-bit-integers accessed and changed by the functions AREF-32-BIT-INTEGER-STACK and ASET-32-BIT-INTEGER-STACK. BIG-CLOCK-ENTRY, an integer, that is used logically to bound the amount of effort spent to evaluate a quoted form. IDATES, a list of dates and times, used to implement the function PRINT-CURRENT-IDATE, which prints the date and time. RUN-TIMES, a list of integers, used to implement the functions that let Acl2 report how much time was used, but inaccessible to the user. FILE-CLOCK, an integer that is increased on every file opening and closing and used to maintain the consistency of the io primitives. READABLE-FILES, an alist whose keys have the form (string type time), where string is a file name and time is an integer. The value of associated with such a key is a list of characters, bytes, or objects, according to type. The time field is used in the following way: when it comes time to open a file for input, we will only look for a file of the specified name and type whose time field is that of file-clock. This permits us to have a ``probe-file'' aspect to open-file: one can ask for a file, find it does not exist, but come back later and find that it does now exist. WRITTEN-FILES, an alist whose keys have the form (string type time1 time2), where string is a file name, type is one of :character, :byte or :object, and time1 and time2 are integers. Time1 and time2 correspond to the file-clock time at which the channel for the file was opened and closed. This field is write-only; the only operation that affects this field is close-output-channel, which conses a new entry on the front. READ-FILES, a list of the form (string type time1 time2), where string is a file name and time1 and time2 were the times at which the file was opened for reading and closed. This field is write only. WRITEABLE-FILES, an alist whose keys have the form (string type time). To open a file for output, we require that the name, type, and time be on this list. LIST-ALL-PACKAGE-NAMES-LST, a list of true-lists. Roughly speaking, the car of this list is the list of all package names known to this Common Lisp right now and the cdr of this list is the value of of this state variable after you look at its car. The function, LIST-ALL-PACKAGE-NAMES, which takes the state as an argument, returns the car and cdrs the lst (returning a new state too). This essentially gives Acl2 access to what is provided by CLTL's LIST-ALL-PACKAGES. DEFPKG uses this feature to insure that the about-to-be-created package is new in this lisp. Thus, for example, in AKCL it is impossible to create the package \"COMPILER\" with DEFPKG because it is on the list, while in Lucid that package name is not initially on the list.~/") (defun update-nth (key val l) (declare (xargs :guard (true-listp l)) (type (integer 0 *) key)) (cond ((= key 0) (cons val (cdr l))) (t (cons (car l) (update-nth (1- key) val (cdr l)))))) (defun 32-bit-integerp (x) (and (integerp x) (<= x *maximum-positive-32-bit-integer*) (>= x (+ (- *maximum-positive-32-bit-integer*) -1)))) (defthm 32-bit-integerp-forward-to-integerp (implies (32-bit-integerp x) (integerp x)) :rule-classes :forward-chaining) (defun rational-lst (l) (cond ((atom l) (equal l nil)) (t (and (rationalp (car l)) (rational-lst (cdr l)))))) (defthm rational-lst-forward-to-true-listp (implies (rational-lst x) (true-listp x)) :rule-classes :forward-chaining) (defun integer-lst (l) (cond ((atom l) (equal l nil)) (t (and (integerp (car l)) (integer-lst (cdr l)))))) (defthm integer-lst-forward-to-rational-lst (implies (integer-lst x) (rational-lst x)) :rule-classes :forward-chaining) (defun 32-bit-integer-lst (l) (cond ((atom l) (equal l nil)) (t (and (32-bit-integerp (car l)) (32-bit-integer-lst (cdr l)))))) (defthm 32-bit-integer-lst-forward-to-integer-lst (implies (32-bit-integer-lst x) (integer-lst x)) :rule-classes :forward-chaining) ; Observe that even though we are defining the primitive accessors and ; updaters for states, we do not use the formal parameter STATE as an ; argument. This is discussed in STATE-STATE below. (defun open-input-channels (st) (declare (xargs :guard (true-listp st))) (nth 0 st)) (defun update-open-input-channels (x st) (declare (xargs :guard (true-listp st))) (update-nth 0 x st)) (defun open-output-channels (st) (declare (xargs :guard (true-listp st))) (nth 1 st)) (defun update-open-output-channels (x st) (declare (xargs :guard (true-listp st))) (update-nth 1 x st)) (defun global-table (st) (declare (xargs :guard (true-listp st))) (nth 2 st)) (defun update-global-table (x st) (declare (xargs :guard (true-listp st))) (update-nth 2 x st)) (defun t-stack (st) (declare (xargs :guard (true-listp st))) (nth 3 st)) (defun update-t-stack (x st) (declare (xargs :guard (true-listp st))) (update-nth 3 x st)) (defun 32-bit-integer-stack (st) (declare (xargs :guard (true-listp st))) (nth 4 st)) (defun update-32-bit-integer-stack (x st) (declare (xargs :guard (true-listp st))) (update-nth 4 x st)) (defun big-clock-entry (st) (declare (xargs :guard (true-listp st))) (nth 5 st)) (defun update-big-clock-entry (x st) (declare (xargs :guard (true-listp st))) (update-nth 5 x st)) (defun idates (st) (declare (xargs :guard (true-listp st))) (nth 6 st)) (defun update-idates (x st) (declare (xargs :guard (true-listp st))) (update-nth 6 x st)) (defun run-times (st) (declare (xargs :guard (true-listp st))) (nth 7 st)) (defun update-run-times (x st) (declare (xargs :guard (true-listp st))) (update-nth 7 x st)) (defun file-clock (st) (declare (xargs :guard (true-listp st))) (nth 8 st)) (defun update-file-clock (x st) (declare (xargs :guard (true-listp st))) (update-nth 8 x st)) (defun readable-files (st) (declare (xargs :guard (true-listp st))) (nth 9 st)) (defun written-files (st) (declare (xargs :guard (true-listp st))) (nth 10 st)) (defun update-written-files (x st) (declare (xargs :guard (true-listp st))) (update-nth 10 x st)) (defun read-files (st) (declare (xargs :guard (true-listp st))) (nth 11 st)) (defun update-read-files (x st) (declare (xargs :guard (true-listp st))) (update-nth 11 x st)) (defun writeable-files (st) (declare (xargs :guard (true-listp st))) (nth 12 st)) (defun list-all-package-names-lst (st) (declare (xargs :guard (true-listp st))) (nth 13 st)) (defun update-list-all-package-names-lst (x st) (declare (xargs :guard (true-listp st))) (update-nth 13 x st)) ; Warning: The following list must satisfy the predicate ordered-symbol-alistp ; above if build-state is to built a state-p. (defconst *initial-global-table* ; Keep this list in alphabetic order as per ordered-symbol-alistp. `((accumulated-ttree . nil) (accumulated-warnings . nil) (certify-book-file . nil) (current-acl2-world . nil) (connected-book-directory . nil) ; set-cbd couldn't have put this! (current-package . "ACL2") (eviscerate-hide-terms . nil) (gstackp . nil) (include-book-action-on-uncertified-books . (warn . nil)) (inhibit-output-lst . (summary)) ; Without this setting, initialize-acl2 ; will print a summary for each event. ; Exit-boot-strap-mode sets this list ; to nil. (ld-level . 0) (ld-skip-proofsp . nil) (ld-redefinition-action . nil) (more-doc-max-lines . 45) (more-doc-min-lines . 35) (more-doc-state . nil) (old-style-forcing . nil) (packages-created-by-defpkg . nil) (print-doc-start-column . 15) (prompt-function . default-print-prompt) (proofs-co . acl2-output-channel::standard-character-output-0) (standard-co . acl2-output-channel::standard-character-output-0) (standard-oi . acl2-output-channel::standard-object-input-0) (timer-alist . nil) (translate-error-depth . -1) (triple-print-prefix . " ") (undone-worlds-kill-ring . (nil nil nil)) ; By making the above list of nils be of length n you can arrange for Acl2 to ; save n worlds for undoing undos. If n is 0, no undoing of undos is possible. ; If n is 1, the last undo can be undone. (untouchables . nil) (wormhole-name . nil))) ; The initial value of the timer alist is irrelevant because we set it ; before we use it. (defun all-boundp (alist1 alist2) (declare (xargs :guard (and (eqlable-alistp alist1) (eqlable-alistp alist2)))) (cond ((null alist1) t) ((assoc (caar alist1) alist2) (all-boundp (cdr alist1) alist2)) (t nil))) (defun known-package-alistp (x) (cond ((atom x) (null x)) (t (and (consp (car x)) (stringp (caar x)) (symbolp-listp (cdar x)) (known-package-alistp (cdr x)))))) (defthm known-package-alistp-forward-to-all-true-listp-and-alistp (implies (known-package-alistp x) (and (all-true-listp x) (alistp x))) :rule-classes :forward-chaining) (defun timer-alistp (x) ; A timer-alistp is an alist binding symbols to lists of rationals. (cond ((atom x) (equal x nil)) ((and (consp (car x)) (symbolp (caar x)) (rational-lst (cdar x))) (timer-alistp (cdr x))) (t nil))) (defthm timer-alistp-forward-to-all-true-listp-and-symbol-alistp (implies (timer-alistp x) (and (all-true-listp x) (symbol-alistp x))) :rule-classes :forward-chaining) (defun typed-io-lst (l typ) (cond ((atom l) (equal l nil)) (t (and (case typ (:character (characterp (car l))) (:byte (and (integerp (car l)) (<= 0 (car l)) (< (car l) 256))) (:object t) (otherwise nil)) (typed-io-lst (cdr l) typ))))) (defthm typed-io-lst-forward-to-true-listp (implies (typed-io-lst x typ) (true-listp x)) :rule-classes :forward-chaining) (defconst *file-types* '(:character :byte :object)) (defun open-channel1 (l) (and (true-listp l) (consp l) (let ((header (car l))) (and (true-listp header) (equal (length header) 4) (eq (car header) :header) (member-eq (cadr header) *file-types*) (stringp (caddr header)) (integerp (cadddr header)) (typed-io-lst (cdr l) (cadr header)))))) (defthm open-channel1-forward-to-true-listp-and-consp (implies (open-channel1 x) (and (true-listp x) (consp x))) :rule-classes :forward-chaining) (defun open-channel-lst (l) ; The following guard seems reasonable (and is certainly necessary, or at least ; some guard is) since open-channels-p will tell us that we're looking at an ; ordered-symbol-alistp. (declare (xargs :guard (alistp l))) (if (null l) t (and (open-channel1 (cdr (car l))) (open-channel-lst (cdr l))))) (defun open-channels-p (x) (and (ordered-symbol-alistp x) (open-channel-lst x))) (defthm open-channels-p-forward (implies (open-channels-p x) (and (ordered-symbol-alistp x) (all-true-listp x))) :rule-classes :forward-chaining) (defun file-clock-p (x) (integerp x)) (defthm file-clock-p-forward-to-integerp (implies (file-clock-p x) (integerp x)) :rule-classes :forward-chaining) (defun readable-file (x) (and (true-listp x) (consp x) (let ((key (car x))) (and (true-listp key) (equal (length key) 3) (stringp (car key)) (member (cadr key) *file-types*) (integerp (caddr key)) (typed-io-lst (cdr x) (cadr key)))))) (defthm readable-file-forward-to-true-listp-and-consp (implies (readable-file x) (and (true-listp x) (consp x))) :rule-classes :forward-chaining) (defun readable-files-lst (x) (cond ((atom x) (equal x nil)) (t (and (readable-file (car x)) (readable-files-lst (cdr x)))))) (defthm readable-files-lst-forward-to-all-true-listp-and-alistp (implies (readable-files-lst x) (and (all-true-listp x) (alistp x))) :rule-classes :forward-chaining) (defun readable-files-p (x) (readable-files-lst x)) (defthm readable-files-p-forward-to-readable-files-lst (implies (readable-files-p x) (readable-files-lst x)) :rule-classes :forward-chaining) (defun written-file (x) (and (true-listp x) (consp x) (let ((key (car x))) (and (true-listp key) (equal (length key) 4) (stringp (car key)) (integerp (caddr key)) (integerp (cadddr key)) (member (cadr key) *file-types*) (typed-io-lst (cdr x) (cadr key)))))) (defthm written-file-forward-to-true-listp-and-consp (implies (written-file x) (and (true-listp x) (consp x))) :rule-classes :forward-chaining) (defun written-file-lst (x) (cond ((atom x) (equal x nil)) (t (and (written-file (car x)) (written-file-lst (cdr x)))))) (defthm written-file-lst-forward-to-all-true-listp-and-alistp (implies (written-file-lst x) (and (all-true-listp x) (alistp x))) :rule-classes :forward-chaining) (defun written-files-p (x) (written-file-lst x)) (defthm written-files-p-forward-to-written-file-lst (implies (written-files-p x) (written-file-lst x)) :rule-classes :forward-chaining) (defun read-file-lst1 (x) (and (true-listp x) (equal (length x) 4) (stringp (car x)) (member (cadr x) *file-types*) (integerp (caddr x)) (integerp (cadddr x)))) (defthm read-file-lst1-forward-to-true-listp-and-consp (implies (read-file-lst1 x) (and (true-listp x) (consp x))) :rule-classes :forward-chaining) (defun read-file-lst (x) (cond ((atom x) (equal x nil)) (t (and (read-file-lst1 (car x)) (read-file-lst (cdr x)))))) (defthm read-file-lst-forward-to-all-true-listp (implies (read-file-lst x) (all-true-listp x)) :rule-classes :forward-chaining) (defun read-files-p (x) (read-file-lst x)) (defthm read-files-p-forward-to-read-file-lst (implies (read-files-p x) (read-file-lst x)) :rule-classes :forward-chaining) (defun writeable-file-lst1 (x) (and (true-listp x) (equal (length x) 3) (stringp (car x)) (member (cadr x) *file-types*) (integerp (caddr x)))) (defthm writeable-file-lst1-forward-to-true-listp-and-consp (implies (writeable-file-lst1 x) (and (true-listp x) (consp x))) :rule-classes :forward-chaining) (defun writeable-file-lst (x) (cond ((atom x) (equal x nil)) (t (and (writeable-file-lst1 (car x)) (writeable-file-lst (cdr x)))))) (defthm writeable-file-lst-forward-to-all-true-listp (implies (writeable-file-lst x) (all-true-listp x)) :rule-classes :forward-chaining) (defun writeable-files-p (x) (writeable-file-lst x)) (defthm writeable-files-p-forward-to-writeable-file-lst (implies (writeable-files-p x) (writeable-file-lst x)) :rule-classes :forward-chaining) (defun state-p1 (x) #-acl2-logic-only (cond ((live-state-p x) (return-from state-p1 t))) (and (true-listp x) (equal (length x) 13) (open-channels-p (open-input-channels x)) (open-channels-p (open-output-channels x)) (ordered-symbol-alistp (global-table x)) (all-boundp *initial-global-table* (global-table x)) (worldp (cdr (assoc 'current-acl2-world (global-table x)))) (symbol-alistp (getprop 'acl2-defaults-table 'table-alist nil 'current-acl2-world (cdr (assoc 'current-acl2-world (global-table x))))) (timer-alistp (cdr (assoc 'timer-alist (global-table x)))) (known-package-alistp (getprop 'known-package-alist 'global-value nil 'current-acl2-world (cdr (assoc 'current-acl2-world (global-table x))))) (true-listp (t-stack x)) (32-bit-integer-lst (32-bit-integer-stack x)) (integerp (big-clock-entry x)) (integer-lst (idates x)) (rational-lst (run-times x)) (file-clock-p (file-clock x)) (readable-files-p (readable-files x)) (written-files-p (written-files x)) (read-files-p (read-files x)) (writeable-files-p (writeable-files x)) (all-true-listp (list-all-package-names-lst x)))) (defthm state-p1-forward (implies (state-p1 x) (and (true-listp x) (equal (length x) 13) (open-channels-p (nth 0 x)) (open-channels-p (nth 1 x)) (ordered-symbol-alistp (nth 2 x)) (all-boundp *initial-global-table* (nth 2 x)) (worldp (cdr (assoc 'current-acl2-world (nth 2 x)))) (symbol-alistp (getprop 'acl2-defaults-table 'table-alist nil 'current-acl2-world (cdr (assoc 'current-acl2-world (nth 2 x))))) (timer-alistp (cdr (assoc 'timer-alist (nth 2 x)))) (known-package-alistp (getprop 'known-package-alist 'global-value nil 'current-acl2-world (cdr (assoc 'current-acl2-world (nth 2 x))))) (true-listp (nth 3 x)) (32-bit-integer-lst (nth 4 x)) (integerp (nth 5 x)) (integer-lst (nth 6 x)) (rational-lst (nth 7 x)) (file-clock-p (nth 8 x)) (readable-files-p (nth 9 x)) (written-files-p (nth 10 x)) (read-files-p (nth 11 x)) (writeable-files-p (nth 12 x)) (all-true-listp (nth 13 x)))) :rule-classes :forward-chaining ;; The hints can speed us up from over 40 seconds to less than 2. :hints (("Goal" :in-theory (disable nth length open-channels-p ordered-symbol-alistp all-boundp worldp assoc timer-alistp known-package-alistp true-listp 32-bit-integer-lst integer-lst rational-lst file-clock-p readable-files-p written-files-p read-files-p writeable-files-p all-true-listp)))) (defun state-p (state-state) (state-p1 state-state)) ; Let us use state-p1 in our theorem-proving. (in-theory (disable state-p1)) ; The following could conceivably be useful before rewriting a literal ; containing state-p. (defthm state-p-implies-and-forward-to-state-p1 (implies (state-p state-state) (state-p1 state-state)) :rule-classes (:forward-chaining :rewrite)) ; On STATE-STATE ; No one should imagine calling any of the state accessors or updaters ; in executable code. These fields are all ``magic'' in some sense, ; in that they don't actually exist -- or, to put it more accurately, ; we do not represent them concretely as the Acl2 objects we alleged ; them to be in the axioms. In some cases, we might have gone to the ; trouble of supporting these things, at considerable cost, e.g. ; keeping a giant list of all characters printed this year. In other ; cases, such as big-clock-entry, the cost of support would have been ; intuitively equivalent to infinite: no Acl2. ; The user should be grateful that he can even indirectly access these ; fields at all in executable code, and should expect to study the ; means of access with excruciating pain and care. Although the ; fields of states may be THOUGHT of as ordinary logical objects (e.g. ; in theorems), the severe restriction on runtime access to them is ; the PRICE ONE PAYS for (a) high efficiency and (b) real-time ; effects. ; How do we prevent the user from applying, say, big-clock-entry, to ; the live state? Well, that is pretty subtle. We simply make the ; formal parameter to written-files be ST rather than STATE. ; Translate enforces the rule that a function must (and may) get a ; state object in a given argument if (and only if) the position is ; the STATE-IN position. And, with only one exception, the STATE-IN ; position is always calculated by noting which formal is called ; STATE. So by giving written-files ST and never reseting its ; STATE-IN, we prevent it from being fed the live state (or any state) ; in code (such as defuns and top-level commands) where we are ; checking the use of state. (In theorems, anything goes.) As noted, ; this is the price one pays. ; So what is the exception to the rule that STATE-IN is determined by ; STATE's position? The exception is managed by super-defun-wart and ; is intimately tied up with the use of STATE-STATE. The problem is ; that even though we don't permit written-files to be called by the ; user, we wish to support some functions (like close-output-channel) ; which do take state as an argument, which may be called by the user ; and which -- logically speaking -- are defined in terms of ; written-files. ; So consider close-output-channel. We would like to make its second ; parameter be STATE. But it must pass that parameter down to ; written-files in the logical code that defines close-output-channel. ; If that happened, we would get a translate error upon trying to ; define close-output-channel, because we would be passing STATE into ; a place (namely ST) where no state was allowed. So we use ; STATE-STATE instead. But while that lets close-output-channel be ; defined, it doesn't let the user apply it to state. However, after ; the definitional principle has translated the body and during the ; course of its storage of the many properties of the newly defined ; function, it calls super-defun-wart which asks "is this one of the ; special functions I was warned about?" If so, it sets STATE-IN (and ; possibly STATE-OUT) for the function properly. A fixed number of ; functions are so built into super-defun-wart, which knows the ; location of the state-like argument and value for each of them. ; Once super-defun-wart has done its job, state must be supplied to ; close-output-channel, where expected. ; "But," you ask, "if state is supplied doesn't is find its way down ; to written-files and then cause trouble because written files isn't ; expecting the live state?" Yes, it would cause trouble if it ever ; got there, but it doesn't. Becasue for each of the functions that ; use STATE-STATE and are known to super-defun-wart, we provide raw ; lisp code to do the real work. That is, there are two definitions ; of close-output-channel. One, the logical one, is read in ; #+acl2-logic-only mode and presents the prissy logical definition in ; terms of written-files. This definition gets processed during our ; system initialization and generates the usual properties about a ; defined function that allow us to do theorem proving about the ; function. The other, in #-acl2-logic-only, is raw Lisp that knows ; how to close a channel when its given one in the live state. ; So the convention is that those functions (all defined in ; axioms.lisp) which (a) the user is permitted to call with real ; states but which (b) can only be logically defined in terms of calls ; to the primitive state accessors and updaters are (i) defined with ; STATE-STATE as a formal parameter, (ii) have their property list ; smashed appropriately for state-in and state-out right right after ; their admission, to reflect their true state character, and (iii) ; are operationally defined with raw lisp at some level between the ; defun and the use of the primitive state accessors and updaters. ; We need the following theorem to make sure that we cannot introduce ; via build-state something that fails to be a state. (defmacro build-state (&key open-input-channels open-output-channels global-table t-stack 32-bit-integer-stack (big-clock '4000000) idates run-times (file-clock '1) readable-files written-files read-files writeable-files list-all-package-names-lst) (list 'build-state1 (list 'quote open-input-channels) (list 'quote open-output-channels) (list 'quote (or global-table *initial-global-table*)) (list 'quote t-stack) (list 'quote 32-bit-integer-stack) (list 'quote big-clock) (list 'quote idates) (list 'quote run-times) (list 'quote file-clock) (list 'quote readable-files) (list 'quote written-files) (list 'quote read-files) (list 'quote writeable-files) (list 'quote list-all-package-names-lst))) (defconst *default-state* (list nil nil *initial-global-table* nil nil 4000000 nil nil 1 nil nil nil nil)) (defun build-state1 (open-input-channels open-output-channels global-table t-stack 32-bit-integer-stack big-clock idates run-times file-clock readable-files written-files read-files writeable-files list-all-package-names-lst) (declare (xargs :guard (state-p1 (list open-input-channels open-output-channels global-table t-stack 32-bit-integer-stack big-clock idates run-times file-clock readable-files written-files read-files writeable-files list-all-package-names-lst)))) ; The purpose of this function is to provide a means for constructing ; a state other than the live state. (let ((s (list open-input-channels open-output-channels global-table t-stack 32-bit-integer-stack big-clock idates run-times file-clock readable-files written-files read-files writeable-files list-all-package-names-lst))) (cond ((state-p1 s) s) (t *default-state*)))) ; The following theorem is here to assure that built-state will always ; return something satifying state-p. If this theorem fails, change ; *default-state*. ; Although the two following functions are only identity functions ; from the logical point of view, in the von Neumann machinery ; implementation they are potentially dangerous and should not ; be used anywhere besides trans-eval. (defun coerce-state-to-object (state-state) state-state) (defun coerce-object-to-state (state-state) state-state) ; GLOBALS #-acl2-logic-only (defun strip-numeric-postfix (sym) (coerce (reverse (do ((x (reverse (coerce (symbol-name sym) 'list)) (cdr x))) ((or (null x) (eq (car x) #\-)) (cdr x)))) 'string)) (defun global-table-cars1 (state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (state-p1 state-state))) #-acl2-logic-only (cond ((live-state-p state-state) (return-from global-table-cars1 (let (ans) (dolist (pair (global-val 'known-package-alist (w *the-live-state*))) (do-symbols (sym (find-package (concatenate 'string *global-package-prefix* (car pair)))) (cond ((boundp sym) (push (intern (symbol-name sym) (car pair)) ans))))) (sort ans (function symbol-<)))))) (strip-cars (global-table state-state))) (defun global-table-cars (state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (state-p1 state-state))) (global-table-cars1 state-state)) #-acl2-logic-only (defun what-is-the-global-state () ; This function is for cosmetics only and is not called by ; anything else. It tells you what you are implicitly passing ; in at the global-table field when you run with *the-live-state*. (list (list :open-input-channels (let (ans) (do-symbols (sym (find-package "ACL2-INPUT-CHANNEL")) (cond ((and (get sym *open-input-channel-key*) (get sym *open-input-channel-type-key*)) (push (cons sym (list (get sym *open-input-channel-type-key*) (strip-numeric-postfix sym))) ans)))) (sort ans (function (lambda (x y) (symbol-< (car x) (car y))))))) (list :open-output-channels (let (ans) (do-symbols (sym (find-package "ACL2-OUTPUT-CHANNEL")) (cond ((and (get sym *open-output-channel-key*) (get sym *open-output-channel-type-key*)) (push (cons sym (list (get sym *open-output-channel-type-key*) (strip-numeric-postfix sym))) ans)))) (sort ans (function (lambda (x y) (symbol-< (car x) (car y))))))) (list :global-table (global-table-cars *the-live-state*)) (list :t-stack (let (ans) (do ((i (1- *t-stack-length*) (1- i))) ((< i 0)) (push (aref-t-stack i *the-live-state*) ans)) ans)) (list :32-bit-integer-stack (let (ans) (do ((i (1- *32-bit-integer-stack-length*) (1- i))) ((< i 0)) (push (aref-32-bit-integer-stack i *the-live-state*) ans)) ans)) (list :big-clock '?) (list :idates '?) (list :run-times '?) (list :file-clock *file-clock*) (list :readable-files '?) (list :written-files '?) (list :read-files '?) (list :writeable-files '?) (list :list-all-package-names-lst '?))) #-acl2-logic-only (defun global-symbol (x) (intern (symbol-name x) (find-package (concatenate 'string *global-package-prefix* (package-name (symbol-package x)))))) (defun boundp-global1 (x state-state) (declare (xargs :guard (and (symbolp x) (state-p1 state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (return-from boundp-global1 (boundp (global-symbol x))))) (cond ((assoc x (global-table state-state)) t) (t nil))) (defun boundp-global (x state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (symbolp x) (state-p1 state-state)))) (boundp-global1 x state-state)) (defmacro f-boundp-global (x st) #-acl2-logic-only (cond ((and (consp x) (eq 'quote (car x)) (symbolp (cadr x)) (null (cddr x))) (let ((s (gensym))) `(let ((,s ,st)) (declare (special ,(global-symbol (cadr x)))) (cond ((eq ,s *the-live-state*) (boundp ',(global-symbol (cadr x)))) (t (boundp-global ,x ,s)))))) (t `(boundp-global ,x ,st))) #+acl2-logic-only (list 'boundp-global x st)) (defun delete-pair (x l) (declare (xargs :guard (and (symbolp x) (eqlable-alistp l)))) (cond ((null l) nil) ((eq x (caar l)) (cdr l)) (t (cons (car l) (delete-pair x (cdr l)))))) (defun makunbound-global (x state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. ; This function is not very fast because it calls global-symbol. A ; faster version could easily be created. (declare (xargs :guard (and (symbolp x) (state-p1 state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (cond ((boundp-global1 x state-state) ; If the variable is not bound, then the makunbound below doesn't do ; anything and we don't have to save undo information. (Furthermore, ; there is nothing to save.) (push-wormhole-undo-formi 'put-global x (get-global x state-state)))))) (makunbound (global-symbol x)) (return-from makunbound-global *the-live-state*))) (update-global-table (delete-pair x (global-table state-state)) state-state)) (defun get-global (x state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (symbolp x) (state-p1 state-state) (boundp-global1 x state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (return-from get-global (symbol-value (the symbol (global-symbol x)))))) (cdr (assoc x (global-table state-state)))) (defmacro f-get-global (x st) #-acl2-logic-only (cond ((and (consp x) (eq 'quote (car x)) (symbolp (cadr x)) (null (cddr x))) (let ((s (gensym))) `(let ((,s ,st)) (declare (special ,(global-symbol (cadr x)))) (cond ((live-state-p ,s) ,(global-symbol (cadr x))) (t (get-global ,x ,s)))))) (t `(get-global ,x ,st))) #+acl2-logic-only (list 'get-global x st)) (defun put-global (key value state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (symbolp key) (state-p1 state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (cond ((boundp-global1 key state-state) (push-wormhole-undo-formi 'put-global key (get-global key state-state))) (t (push-wormhole-undo-formi 'makunbound-global key nil))))) (set (global-symbol key) value) (return-from put-global state-state))) (update-global-table (add-pair key value (global-table state-state)) state-state)) (defmacro f-put-global (key value st) #-acl2-logic-only (cond ((and (consp key) (eq 'quote (car key)) (symbolp (cadr key)) (null (cddr key))) (let ((v (gensym)) (s (gensym))) `(let ((,v ,value) (,s ,st)) (cond ((live-state-p ,s) (cond (*wormholep* (cond ((boundp-global1 ,key ,s) (push-wormhole-undo-formi 'put-global ,key (get-global ,key ,s))) (t (push-wormhole-undo-formi 'makunbound-global ,key nil))))) (let () (declare (special ,(global-symbol (cadr key)))) (setq ,(global-symbol (cadr key)) ,v) ,s)) (t (put-global ,key ,v ,s)))))) (t `(put-global ,key ,value ,st))) #+acl2-logic-only (list 'put-global key value st)) ; We now define state-global-let*, which lets us "bind" state ; globals. (defun symbol-doublet-listp (lst) ; This function returns t iff lst is a true-list and each element is ; a doublet of the form (symbolp anything). (cond ((atom lst) (eq lst nil)) (t (and (consp (car lst)) (symbolp (caar lst)) (consp (cdar lst)) (null (cddar lst)) (symbol-doublet-listp (cdr lst)))))) (defun state-global-let*-get-globals (bindings) ; This function is used to generate code for the macroexpansion of ; state-global-let*. Roughly speaking, it returns a list, lst, of f-get-global ; forms that fetch the values of the variables we are about to smash. The ; expansion of state-global-let* will start with (LET ((temp (LIST ,@lst))) ; ...) and we will use the value of temp to restore the globals after the ; execution of the body. ; Now there is a subtlety. Some of the vars we are to "bind" might NOT be ; already bound in state. So we don't want to call f-get-global on them until ; we know they are bound, and for those that are not, "restoring" their old ; values means making them unbound again. So a careful specification of the ; value of temp (i.e., the value of (LIST ,@lst) where lst is what we are ; producing here) is that it is a list in 1:1 correspondence with the vars ; bound in bindings such that the element corresponding to the var x is nil if ; x is unbound in the pre-body state and is otherwise a singleton list ; containing the value of x in the pre-body state. (declare (xargs :guard (symbol-doublet-listp bindings))) (cond ((null bindings) nil) (t (cons `(if (boundp-global ',(caar bindings) state) (list (f-get-global ',(caar bindings) state)) nil) (state-global-let*-get-globals (cdr bindings)))))) (defun state-global-let*-put-globals (bindings) ; This function is used to generate code for the macroexpansion of ; state-global-let*. It generates a list of f-put-globals that will set the ; bound variables in bindings to their desired local values. We insist that ; those initialization forms not mention the temporary variable ; state-global-let* uses to hang onto the restoration values. (declare (xargs :guard (symbol-doublet-listp bindings))) (cond ((null bindings) nil) (t (cons `(f-put-global ',(caar bindings) (check-vars-not-free (state-global-let*-cleanup-lst) ,(cadar bindings)) state) (state-global-let*-put-globals (cdr bindings)))))) (defun state-global-let*-cleanup (bindings cdr-expr) ; This function is used to generate code for the macroexpansion of ; state-global-let*. We generate a list of forms that when executed will ; restore the "bound" variables to their original values, using the list of ; restoration values. Recall that each restoration value is either a nil, ; indicating the variable was unbound, or a singleton listing the original ; value. We are generating that code. Cdr-expr is the expression that when ; evaluated will return the tail of the restoration values list that begins ; with the value for the first variable in bindings. It is initially the value ; of the temporary variable used by state-global-let* and is symbolically ; CDRd ever time we recurse here. ; Note: Once upon a time we used a recursive function to do the cleanup. It ; essentially swept through the names of the state globals as it swept through ; the list of their initial values and did an f-put-global on each (here ; ignoring the unbound variable problem). That was dangerous because it ; violated the rules that f-put-global was only called on a quoted var. Those ; rules allow translate to enforce untouchables. To get away with it, we had ; to exempt that function from translate's restrictions on f-put-global. We ; thought we could regain security by then putting that function name on ; untouchables. But since calls to that function were laid down in macros, it ; can't be untouchable if the user is to use the macros. So we did it this ; way, which makes each f-put-global explicit and needs no special treatement. (declare (xargs :guard (alistp bindings))) (cond ((null bindings) nil) (t (cons `(if (car ,cdr-expr) (f-put-global ',(caar bindings) (car (car ,cdr-expr)) state) (makunbound-global ',(caar bindings) state)) (state-global-let*-cleanup (cdr bindings) `(cdr ,cdr-expr)))))) (defmacro state-global-let* (bindings body) ; A typical use is (state-global-let* (( ) ... ( )) ; ) Bindings thus are in the style of let*. Body must return an error ; triple. The meaning of this form is to smash the global values of the ; "bound" variables with f-put-global, execute body, restore the values to ; their previous values, and return the triple produced by body (with its state ; as modified by the restoration). Because we use acl2-unwind-protect, the ; restoration is guaranteed even in the face of aborts. The "bound" variables ; may initially be unbound in state and restoration means to make them unbound ; again. ; Note: This function is a generalization of the now obsolete ; WITH-STATE-GLOBAL-BOUND. (declare (xargs :guard (and (symbol-doublet-listp bindings) (no-duplicatesp (strip-cars bindings))))) `(let ((state-global-let*-cleanup-lst (list ,@(state-global-let*-get-globals bindings)))) (acl2-unwind-protect "state-global-let*" (pprogn ,@(state-global-let*-put-globals bindings) (check-vars-not-free (state-global-let*-cleanup-lst) ,body)) (pprogn ,@(state-global-let*-cleanup bindings 'state-global-let*-cleanup-lst) state) (pprogn ,@(state-global-let*-cleanup bindings 'state-global-let*-cleanup-lst) state)))) ; With state-global-let* defined, we may now define a few more primitives. #+acl2-logic-only (skip-proofs (progn (defun logand (i j) (declare (xargs :guard (and (integerp i) (integerp j)) :measure (abs i))) (cond ((eql i 0) 0) ((eql j 0) 0) ((eql i -1) j) ((eql j -1) i) (t (let ((x (* 2 (logand (floor i 2) (floor j 2))))) (+ x (cond ((evenp i) 0) ((evenp j) 0) (t 1))))))) (defun lognand (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (lognot (logand i j))) (defun logior (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (lognot (logand (lognot i) (lognot j)))) (defun logorc1 (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logior (lognot i) j)) (defun logorc2 (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logior i (lognot j))) (defun logandc1 (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logand (lognot i) j)) (defun logandc2 (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logand i (lognot j))) (defun logeqv (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (logand (logorc1 i j) (logorc1 j i))) (defun logxor (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (lognot (logeqv i j))) (defun lognor (i j) (declare (xargs :guard (and (integerp i) (integerp j)))) (lognot (logior i j))) (defun logtest (x y) ; p. 360 of CLtL2 (declare (xargs :guard (and (integerp x) (integerp y)))) (not (zerop (logand x y)))) ) ) ; PRINTING and READING (deflabel io :doc ":Doc-Section Miscellaneous input/output facilities in ACL2~/ Example: (mv-let (channel state) (open-input-channel \"foo.lisp\" :object state) (mv-let (eofp obj state) (read-object channel state) (. . (let ((state (close-input-channel channel state))) (mv final-ans state))..)))~/ Acl2 supports input and output facilities equivalent to a subset of those found in Common Lisp. Acl2 does not support random access files or bidirectional streams. In Common Lisp, input and output are to or from objects of type stream. In Acl2, input and output are to or from objects called channels, which are actually symbols. Although a channel is a symbol, one may think of it intuitively as corresponding to a Common Lisp stream. Channels are in one of two Acl2 packages, \"ACL2-INPUT-CHANNEL\" and \"ACL2-OUTPUT-CHANNEL\". When one ``opens'' a file one gets back a channel whose symbol-name is the file name passed to open, postfixed with -n, where n is a counter that is incremented every time an open or close occurs. There are three channels which are open from the beginning and which cannot be closed: acl2-input-channel::standard-character-input-0 acl2-input-channel::standard-object-input-0 acl2-input-channel::standard-character-output-0 All three of these are really Common Lisp's *standard-input* or *standard-output*, appropriately. For convenience, three global variables are bound to these rather tedious channel names *standard-ci* *standard-oi* *standard-co* Common Lisp permits one to open a stream for several different kinds of io, e.g. character or byte. Acl2 permits an additional type called ``object''. In Acl2 an ``io-type'' is a keyword, either :character, :byte, or :object. When one opens a file, one specifies a type, which determines the kind of io operations that can be done on the channel returned. The types :character and :byte are familiar. Type :object is an abstraction not found in Common Lisp. An :object file is a file of Lisp objects. One uses read-object to read from :object files and print-object to print to :object files. (The reading and printing are really done with the Common Lisp read and print functions.) File-names are strings. Acl2 does not support the Common Lisp type pathname. Here are the signatures of the Acl2 io functions. See :DOC signature. Input Functions: (open-input-channel (file-name io-type state) (mv channel state)) (open-input-channel-p (channel io-type state) boolean) (close-input-channel (channel state) state) (read-char$ (channel state) (mv char/nil state)) (peek$ (channel state) boolean) (read-byte$ (channel state) (mv byte/nil state)) (read-object (channel state) (mv eof-read-flg obj-read state)) Output Functions: (open-output-channel (file-name io-type state) (mv channel state)) (open-output-channel-p (channel io-type state) boolean) (close-output-channel (channel state) state) (princ$ (obj channel state) state) (write-byte$ (byte channel state) state) (print-object (obj channel state) state) When one enters Acl2 with (LP), input and output are taken from *standard-oi* to *standard-co*. Because these are synonyms for *standard-input* and *standard-output*, one can drive Acl2 io off of arbitrary Common Lisp streams, bound to *standard-input* and *standard-output* before entry to Acl2.~/") (defun digit-to-char (n) (declare (xargs :guard (and (integerp n) (<= 0 n) (<= n 9)))) (case n (0 #\0) (1 #\1) (2 #\2) (3 #\3) (4 #\4) (5 #\5) (6 #\6) (7 #\7) (8 #\8) (otherwise #\9))) (skip-proofs (defun explode-nonnegative-integer (n ans) (declare (xargs :guard (and (integerp n) (>= n 0)))) (cond ((= n 0) (cond ((null ans) '(#\0)) (t ans))) (t (explode-nonnegative-integer (floor n 10) (cons (digit-to-char (mod n 10)) ans))))) ) (skip-proofs (defun explode-atom (x) (declare (xargs :guard (or (acl2-numberp x) (characterp x) (stringp x) (symbolp x)))) (cond ((rationalp x) (cond ((integerp x) (cond ((< x 0) (cons #\- (explode-nonnegative-integer (- x) nil))) (t (explode-nonnegative-integer x nil)))) (t (append (explode-atom (numerator x)) (cons #\/ (explode-nonnegative-integer (denominator x) nil)))))) ((complex-rationalp x) (list* #\# #\C #\( (append (explode-atom (realpart x)) (cons #\Space (append (explode-atom (imagpart x)) '(#\))))))) ((characterp x) (list x)) ((stringp x) (coerce x 'list)) (t (coerce (symbol-name x) 'list)))) ) (defthm all-true-listp-forward-to-true-listp-assoc-eq (implies (and (symbol-alistp l) (all-true-listp l)) (true-listp (assoc-eq key l))) :rule-classes :type-prescription) (defthm true-listp-cadr-assoc-eq-for-open-channels-p (implies (open-channels-p alist) (true-listp (cadr (assoc-eq key alist)))) :rule-classes ((:forward-chaining :trigger-terms ((cadr (assoc-eq key alist)))))) ; It is important to disable nth in order for the rule state-p1-forward to ; work. (in-theory (disable nth open-channels-p)) (defun open-input-channel-p1 (channel typ state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state) (member-eq typ *file-types*)))) #-acl2-logic-only (cond ((live-state-p state-state) (return-from open-input-channel-p1 (and (get channel *open-input-channel-key*) (eq (get channel *open-input-channel-type-key*) typ))))) (let ((pair (assoc-eq channel (open-input-channels state-state)))) (and pair (eq (cadr (car (cdr pair))) typ)))) (defun open-output-channel-p1 (channel typ state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state) (member-eq typ *file-types*)))) #-acl2-logic-only (cond ((live-state-p state-state) (return-from open-output-channel-p1 (and (get channel *open-output-channel-key*) (eq (get channel *open-output-channel-type-key*) typ))))) (let ((pair (assoc-eq channel (open-output-channels state-state)))) (and pair (eq (cadr (car (cdr pair))) typ)))) (defun open-input-channel-p (channel typ state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state) (member-eq typ *file-types*)))) (open-input-channel-p1 channel typ state-state)) (defun open-output-channel-p (channel typ state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state) (member-eq typ *file-types*)))) (open-output-channel-p1 channel typ state-state)) (defun open-output-channel-any-p1 (channel state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state)))) (or (open-output-channel-p1 channel :character state-state) (open-output-channel-p1 channel :byte state-state) (open-output-channel-p1 channel :object state-state))) (defun open-output-channel-any-p (channel state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state)))) (open-output-channel-any-p1 channel state-state)) (defun open-input-channel-any-p1 (channel state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state)))) (or (open-input-channel-p1 channel :character state-state) (open-input-channel-p1 channel :byte state-state) (open-input-channel-p1 channel :object state-state))) (defun open-input-channel-any-p (channel state-state) (declare (xargs :guard (and (symbolp channel) (state-p1 state-state)))) (open-input-channel-any-p1 channel state-state)) (skip-proofs (defun princ$ (x channel state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. ; The Acl2 princ$ does not handle conses because we are unsure what ; the specification of the real Common Lisp princ is concerning the ; insertion of spaces and newlines into the resulting text. For ; example, if *print-pretty* is T, heavens only knows what Common Lisp ; will do. (declare (xargs :guard (and (or (acl2-numberp x) (characterp x) (stringp x) (symbolp x)) (state-p1 state-state) (symbolp channel) (open-output-channel-p1 channel :character state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond ((and *wormholep* (not (eq channel *standard-co*))) ; If the live state is protected, then we allow output only to the ; *standard-co* channel. This is a little unexpected. The intuitive ; arrangement would be to allow output only to a channel whose actual ; stream was pouring into the wormhole window. Unfortunately, we do not ; know a good way to determine the ultimate stream to which a synonym ; stream is directed and hence cannot implement the intuitive ; arrangement. Instead we must assume that if *the-live-state- ; protected* is non-nil, then the standard channels have all been ; directed to acceptable streams and that doing i/o on them will not ; affect the streams to which they are normally directed. (wormhole-er 'princ$ (list x channel)))) (let ((stream (get-output-stream-from-channel channel))) (princ x stream) (cond ((eql x #\Newline) (force-output stream))) (return-from princ$ *the-live-state*)))) (let ((entry (cdr (assoc-eq channel (open-output-channels state-state))))) (update-open-output-channels (add-pair channel (cons (car entry) (revappend (explode-atom x) (cdr entry))) (open-output-channels state-state)) state-state))) ) (defun write-byte$ (x channel state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (integerp x) (>= x 0) (< x 256) (state-p1 state-state) (symbolp channel) (open-output-channel-p1 channel :byte state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond ((and *wormholep* (not (eq channel *standard-co*))) (wormhole-er 'write-byte$ (list x channel)))) (let ((stream (get-output-stream-from-channel channel))) (write-byte x stream) (return-from write-byte$ *the-live-state*)))) (let ((entry (cdr (assoc-eq channel (open-output-channels state-state))))) (update-open-output-channels (add-pair channel (cons (car entry) (cons x (cdr entry))) (open-output-channels state-state)) state-state))) (defun print-object (x channel state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. ; We believe that if in a single Common Lisp session, one prints and ; an object and then reads it back in with print-object and ; read-object, one will get back an equal object under the assumptions ; that (a) the package structure has not changed between the print and ; the read and (b) that *package* has the same binding. On a ; toothbrush, all calls of defpackage will occur before any ; read-objecting or print-objecting, so the package structure will be ; the same. It is up to the user to set current-package back ; to what it was at print time if he hopes to read back in the ; same object. (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-output-channel-p1 channel :object state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* ; There is no standard object output channel and hence this channel is ; directed to some unknown user-specified sink and we can't touch it. (wormhole-er 'print-object (list x channel)))) (let ((stream (get-output-stream-from-channel channel))) (declare (special acl2_global_acl2::current-package)) (let ((*package* (find-package (current-package *the-live-state*))) (*print-base* 10) (*print-circle* nil) (*print-escape* t) #+CLTL2 (*print-lines* nil) #+CLTL2 (*print-miser-width* nil) #+CLTL2 (*print-pprint-dispatch* nil) #+CLTL2 (*print-readably* t) #+CLTL2 (*print-right-margin* nil) (*readtable* *acl2-readtable*) (*print-radix* nil) *print-pretty* *print-level* *print-length* (*print-case* :upcase)) (print x stream) (force-output stream))) (return-from print-object *the-live-state*))) (let ((entry (cdr (assoc-eq channel (open-output-channels state-state))))) (update-open-output-channels (add-pair channel (cons (car entry) (cons x (cdr entry))) (open-output-channels state-state)) state-state))) #-acl2-logic-only (defmacro get-input-stream-from-channel (channel) (list 'get channel (list 'quote *open-input-channel-key*) (list 'quote *non-existent-stream*))) #-acl2-logic-only (defmacro get-output-stream-from-channel (channel) (list 'get channel (list 'quote *open-output-channel-key*) (list 'quote *non-existent-stream*))) ; We start the file-clock at one to avoid any possible confusion with ; the wired in standard-input/output channels, whose names end with ; "-0". #-acl2-logic-only (defparameter *file-clock* 1) (skip-proofs (defun make-input-channel (file-name clock) (declare (xargs :guard (and (rationalp clock) (standard-char-listp (explode-atom clock)) (stringp file-name) (standard-char-listp (coerce file-name 'list))))) (intern (coerce (append (coerce file-name 'list) (cons '#\- (explode-atom clock))) 'string) "ACL2-INPUT-CHANNEL")) ) (skip-proofs (defun make-output-channel (file-name clock) (declare (xargs :guard (and (rationalp clock) (standard-char-listp (explode-atom clock)) (stringp file-name) (standard-char-listp (coerce file-name 'list))))) (intern (coerce (append (coerce file-name 'list) (cons '#\- (explode-atom clock))) 'string) "ACL2-OUTPUT-CHANNEL")) ) ; We here set up the property list of the three channels that are open ; at the beginning. The order of the setfs and the superfluous call ; of symbol-name are to arrange, in AKCL, for the stream component to ; be first on the property list. #-acl2-logic-only (eval-when (load eval compile) (symbol-name 'acl2-input-channel::standard-object-input-0) (setf (get 'acl2-input-channel::standard-object-input-0 *open-input-channel-type-key*) :object) (setf (get 'acl2-input-channel::standard-object-input-0 *open-input-channel-key*) (make-synonym-stream '*standard-input*)) (symbol-name 'acl2-input-channel::standard-character-input-0) (setf (get 'acl2-input-channel::standard-character-input-0 *open-input-channel-type-key*) :character) (setf (get 'acl2-input-channel::standard-character-input-0 *open-input-channel-key*) (make-synonym-stream '*standard-input*)) (symbol-name 'acl2-output-channel::standard-character-output-0) (setf (get 'acl2-output-channel::standard-character-output-0 *open-output-channel-type-key*) :character) (setf (get 'acl2-output-channel::standard-character-output-0 *open-output-channel-key*) (make-synonym-stream '*standard-output*))) (skip-proofs (defun open-input-channel (file-name typ state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (stringp file-name) (member-eq typ *file-types*) (state-p1 state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'open-input-channel (list file-name typ)))) (return-from open-input-channel (progn (setq *file-clock* (1+ *file-clock*)) ; We do two different opens here because the default :element-type is ; different in CLTL and CLTL2. (let ((stream (case typ ((:character :object) (open file-name :direction :input :if-does-not-exist nil)) (:byte (open file-name :direction :input :element-type '(unsigned-byte 8) :if-does-not-exist nil)) (otherwise (interface-er "Illegal input-type ~p0." typ))))) (cond ((null stream) (mv nil *the-live-state*)) (t (let ((channel (make-input-channel file-name *file-clock*))) (symbol-name channel) (setf (get channel *open-input-channel-type-key*) typ) (setf (get channel *open-input-channel-key*) stream) (mv channel *the-live-state*))))))))) (let ((state-state (update-file-clock (1+ (file-clock state-state)) state-state))) (let ((pair (assoc-equal (list file-name typ (file-clock state-state)) (readable-files state-state)))) (cond (pair (let ((channel (make-input-channel file-name (file-clock state-state)))) (mv channel (update-open-input-channels (add-pair channel (cons (list :header typ file-name (file-clock state-state)) (cdr pair)) (open-input-channels state-state)) state-state)))) (t (mv nil state-state)))))) ) (defthm nth-update-nth (implies (and (integerp m) (>= m 0) (integerp n) (>= n 0) (true-listp l)) (equal (nth m (update-nth n val l)) (if (equal m n) val (nth m l)))) :hints (("Goal" :in-theory (enable nth)))) (defun close-input-channel (channel state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (not (member-eq channel '(acl2-input-channel::standard-character-input-0 acl2-input-channel::standard-object-input-0))) (state-p1 state-state) (symbolp channel) (open-input-channel-any-p1 channel state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'close-input-channel (list channel)))) (return-from close-input-channel (progn (setq *file-clock* (1+ *file-clock*)) (let ((stream (get channel *open-input-channel-key*))) (remprop channel *open-input-channel-key*) (remprop channel *open-input-channel-type-key*) (close stream)) *the-live-state*)))) (let ((state-state (update-file-clock (1+ (file-clock state-state)) state-state))) (let ((header-entries (cdr (car (cdr (assoc-eq channel (open-input-channels state-state))))))) (let ((state-state (update-read-files (cons (list (cadr header-entries) ; file-name (car header-entries) ; type (caddr header-entries) ; open-time (file-clock state-state)) ; close-time (read-files state-state)) state-state))) (let ((state-state (update-open-input-channels (delete-pair channel (open-input-channels state-state)) state-state))) state-state))))) (skip-proofs (defun open-output-channel (file-name typ state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. ; It is possible to get an error when opening an output file. We ; consider that a resource error for purposes of the story. (declare (xargs :guard (and (stringp file-name) (member-eq typ *file-types*) (state-p1 state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'open-output-channel (list file-name typ)))) (return-from open-output-channel (progn (setq *file-clock* (1+ *file-clock*)) (let* ((stream (case typ ((:character :object) (open file-name :direction :output)) (:byte (open file-name :direction :output :element-type '(unsigned-byte 8))) (otherwise (interface-er "Illegal output-type ~p0." typ)))) (channel (make-output-channel file-name *file-clock*))) (symbol-name channel) (setf (get channel *open-output-channel-type-key*) typ) (setf (get channel *open-output-channel-key*) stream) (mv channel *the-live-state*)))))) (let ((state-state (update-file-clock (1+ (file-clock state-state)) state-state))) (cond ((member-equal (list file-name typ (file-clock state-state)) (writeable-files state-state)) (let ((channel (make-output-channel file-name (file-clock state-state)))) (mv channel (update-open-output-channels (add-pair channel (cons (list :header typ file-name (file-clock state-state)) nil) (open-output-channels state-state)) state-state)))) (t (mv nil state-state))))) ) (defun close-output-channel (channel state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (not (eq channel 'acl2-output-channel::standard-character-output-0)) (state-p1 state-state) (symbolp channel) (open-output-channel-any-p1 channel state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'close-output-channel (list channel)))) (return-from close-output-channel (progn (setq *file-clock* (1+ *file-clock*)) (let ((str (get channel *open-output-channel-key*))) (remprop channel *open-output-channel-key*) (remprop channel *open-output-channel-type-key*) (close str)) *the-live-state*)))) (let ((state-state (update-file-clock (1+ (file-clock state-state)) state-state))) (let* ((pair (assoc-eq channel (open-output-channels state-state))) (header-entries (cdr (car (cdr pair))))) (let ((state-state (update-written-files (cons (cons (list (cadr header-entries) ; file-name (car header-entries) ; type (caddr header-entries) ; open-time (file-clock state-state)) ; close-time (cdr (cdr pair))) ; stuff written (written-files state-state)) state-state))) (let ((state-state (update-open-output-channels (delete-pair channel (open-output-channels state-state)) state-state))) state-state))))) #-acl2-logic-only (defmacro legal-acl2-character-p (x) (let ((ch (gensym))) (list 'let (list (list ch x)) (subst ch 'ch '(let ((i (the (integer 0 127) (aref (the (array fixnum (*)) *char-to-ascii*) (the fixnum (char-code (the character ch))))))) (declare (type (mod 128) i)) (/= i 0)))))) (defun read-char$ (channel state-state) ; read-char$ differs from read-char in several ways. It returns an ; mv-list of two values, the second being state. There are no eof ; args. Rather, nil is returned instead of character if there is no ; more input. ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-input-channel-p1 channel :character state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond ((and *wormholep* (not (eq channel *standard-ci*))) (wormhole-er 'read-char$ (list channel)))) (return-from read-char$ (let ((ch (read-char (get-input-stream-from-channel channel) nil nil))) (cond ((and ch (not (legal-acl2-character-p ch))) (interface-er "Illegal character read: ~p0 with code ~p1." ch (char-code ch))) (t (mv ch *the-live-state*))))))) (let ((entry (cdr (assoc-eq channel (open-input-channels state-state))))) (mv (car (cdr entry)) (update-open-input-channels (add-pair channel (cons (car entry) (cdr (cdr entry))) (open-input-channels state-state)) state-state)))) (defun peek-char$ (channel state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-input-channel-p1 channel :character state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond ((and *wormholep* (not (eq channel *standard-ci*))) (wormhole-er 'peek-char$ (list channel)))) (return-from peek-char$ (let ((ch (peek-char nil (get-input-stream-from-channel channel) nil nil))) (cond ((and ch (not (legal-acl2-character-p ch))) (interface-er "Illegal character peeked at: ~p0 with code ~p1." ch (char-code ch))) (t ch)))))) (let ((entry (cdr (assoc-eq channel (open-input-channels state-state))))) (car (cdr entry)))) (defun read-byte$ (channel state-state) ; read-byte$ differs from read-byte in several ways. It returns an ; mv-list of two values, the second being state. There are no eof ; args. Rather, nil is returned instead if there is no more input. ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-input-channel-p1 channel :byte state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'read-byte$ (list channel)))) (return-from read-byte$ (mv (read-byte (get-input-stream-from-channel channel) nil nil) *the-live-state*)))) (let ((entry (cdr (assoc-eq channel (open-input-channels state-state))))) (mv (car (cdr entry)) (update-open-input-channels (add-pair channel (cons (car entry) (cdr (cdr entry))) (open-input-channels state-state)) state-state)))) #-acl2-logic-only (defconstant *read-object-eof* (cons nil nil)) (defun read-object (channel state-state) ; read-object is somewhat like read. It returns an mv-list of three ; values: the first is a flag that is true iff the read happened at ; eof, the second is the object read (or nil if eof), and the third is ; state. ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (state-p1 state-state) (symbolp channel) (open-input-channel-p1 channel :object state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond ((and *wormholep* (not (eq channel *standard-oi*))) (wormhole-er 'read-object (list channel)))) (return-from read-object (let* ((*package* (find-package (current-package *the-live-state*))) (*readtable* *acl2-readtable*) #+CLTL2 (*read-eval* nil) (*read-suppress* nil) (*read-base* 10) (obj (read (get-input-stream-from-channel channel) nil *read-object-eof*))) (cond ((eq obj *read-object-eof*) (mv t nil state-state)) (t (chk-bad-lisp-object obj nil) (mv nil obj state-state))))))) (let ((entry (cdr (assoc-eq channel (open-input-channels state-state))))) (cond ((cdr entry) (mv nil (car (cdr entry)) (update-open-input-channels (add-pair channel (cons (car entry) (cdr (cdr entry))) (open-input-channels state-state)) state-state))) (t (mv t nil state-state))))) (defconst *suspiciously-first-numeric-chars* '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\- #\. #\^ #\_)) (defconst *slashable-chars* '(#\Newline #\Space #\" #\# #\' #\( #\) #\, #\. #\: #\; #\\ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\|)) (defun some-slashable (l) (declare (xargs :guard (character-lst l))) (cond ((null l) nil) ((member (car l) *slashable-chars*) t) (t (some-slashable (cdr l))))) (skip-proofs (defun prin1-with-slashes1 (l slash-char channel state) (declare (xargs :guard (and (character-lst l) (characterp slash-char) (state-p state) (symbolp channel) (open-output-channel-p channel :character state)))) (cond ((null l) state) (t (pprogn (cond ((or (equal (car l) #\\) (equal (car l) slash-char)) (princ$ #\\ channel state)) (t state)) (princ$ (car l) channel state) (prin1-with-slashes1 (cdr l) slash-char channel state))))) ) (skip-proofs (defun prin1-with-slashes (s slash-char channel state) (declare (xargs :guard (and (stringp s) (characterp slash-char) (state-p state) (symbolp channel) (open-output-channel-p channel :character state)))) #-acl2-logic-only (cond ((live-state-p state) ; We don't check *wormholep* here because it is checked in ; princ$ which is called first on each branch below. (let ((n (length (the string s)))) (declare (fixnum n)) (do ((i 0 (1+ i))) ((= i n)) (declare (fixnum i)) (let ((ch (aref (the string s) i))) (cond ((or (eql ch #\\) (eql ch slash-char)) (progn (princ$ #\\ channel state) (princ$ ch channel state))) (t (princ$ ch channel state)))))) (return-from prin1-with-slashes state))) (prin1-with-slashes1 (coerce s 'list) slash-char channel state)) ) #-acl2-logic-only (defconstant *slashable-array* (make-array char-code-limit :initial-element nil)) #-acl2-logic-only (eval-when (load) (dolist (ch *slashable-chars*) (setf (aref *slashable-array* (char-code ch)) t))) #-acl2-logic-only (defconstant *suspiciously-first-numeric-array* (make-array char-code-limit :initial-element nil)) #-acl2-logic-only (eval-when (load) (dolist (x *suspiciously-first-numeric-chars*) (setf (aref *suspiciously-first-numeric-array* (char-code x)) t))) (defun may-need-slashes (x) (declare (xargs :guard (stringp x))) #+acl2-logic-only (let ((l (coerce x 'list))) (or (null l) (and (member (car l) *suspiciously-first-numeric-chars*) (not (member (car (last l)) '(#\+ #\-)))) (some-slashable l))) #-acl2-logic-only (let* ((s x) (n (length (the string s)))) (declare (fixnum n)) (declare (type string s)) (or (= n 0) (and (svref *suspiciously-first-numeric-array* (the fixnum (char-code (aref (the string s) 0)))) (not (member (aref (the string s) (1- n)) '(#\+ #\-)))) (let (flg) (do ((i 0 (1+ i))) ((= i n)) (declare (fixnum i)) (let ((ch (char-code (aref (the string s) i)))) (declare (fixnum ch)) (cond ((svref *slashable-array* ch) (setq flg t))))) flg)))) ; T-STACK #-acl2-logic-only (progn (defparameter *t-stack* (make-array 5)) (defparameter *t-stack-length* 0) ) (defun t-stack-length1 (state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (state-p1 state-state))) #-acl2-logic-only (cond ((live-state-p state-state) (return-from t-stack-length1 *t-stack-length*))) (length (t-stack state-state))) (defun t-stack-length (state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (state-p1 state-state))) (t-stack-length1 state-state)) (defun make-list-ac (n val ac) (declare (xargs :guard (and (integerp n) (>= n 0)))) (cond ((= n 0) ac) (t (make-list-ac (1- n) val (cons val ac))))) #+acl2-logic-only (defmacro make-list (size &key initial-element) "Creates and returns a list of size elements, each of which is initialized to the :initial-element (which defaults to NIL). Size must be a nonnegative integer." `(make-list-ac ,size ,initial-element nil)) (defun extend-t-stack (n val state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (type (integer (0) *) n) (xargs :guard (state-p1 state-state))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'extend-t-stack (list n val)))) (let ((new-length (+ *t-stack-length* n))) (cond ((> new-length (length (the simple-vector *t-stack*))) (cond ((> (* 2 new-length) array-dimension-limit) (interface-er "Resource error. Attempt to create too ~ ~ large a stack."))) (let ((new-length new-length)) (declare (fixnum new-length)) (let ((new-array (make-array (* 2 new-length)))) (declare (simple-vector new-array)) (do ((i (1- *t-stack-length*) (1- i))) ((< i 0)) (declare (fixnum i)) (setf (svref new-array i) (svref *t-stack* i))) (setq *t-stack* new-array))))) (let ((new-length new-length)) (declare (fixnum new-length)) (do ((i *t-stack-length* (1+ i))) ((= i new-length)) (declare (fixnum i)) (setf (svref *t-stack* i) val)) (setq *t-stack-length* new-length))) (return-from extend-t-stack state-state))) (update-t-stack (append (t-stack state-state) (make-list-ac n val nil)) state-state)) (defun first-n-ac (i l ac) (declare (type (integer 0 *) i) (xargs :guard (and (true-listp l) (true-listp ac)))) (cond ((= i 0) (reverse ac)) (t (first-n-ac (1- i) (cdr l) (cons (car l) ac))))) (defun shrink-t-stack (n state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (type (integer 0 *) n) (xargs :guard (state-p1 state-state))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'shrink-t-stack (list n)))) (let ((old *t-stack-length*) (new (max 0 (- *t-stack-length* n)))) (declare (fixnum old new)) (setq *t-stack-length* new) (do ((i new (1+ i))) ((= i old)) (declare (fixnum i)) (setf (svref *t-stack* i) nil))) (return-from shrink-t-stack *the-live-state*))) (update-t-stack (first-n-ac (max 0 (- (length (t-stack state-state)) n)) (t-stack state-state) nil) state-state)) (defun aref-t-stack (i state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. #-acl2-logic-only (declare (fixnum i)) (declare (xargs :guard (and (integerp i) (>= i 0) (state-p1 state-state) (< i (t-stack-length1 state-state))))) (cond #-acl2-logic-only ((live-state-p state-state) (svref *t-stack* (the fixnum i))) (t (nth i (t-stack state-state))))) (defun aset-t-stack (i val state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. #-acl2-logic-only (declare (fixnum i)) (declare (xargs :guard (and (integerp i) (>= i 0) (state-p1 state-state) (< i (t-stack-length1 state-state))))) (cond #-acl2-logic-only ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'aset-t-stack (list i val)))) (setf (svref *t-stack* (the fixnum i)) val) state-state) (t (update-t-stack (update-nth i val (t-stack state-state)) state-state)))) ; 32-bit-integer-stack #-acl2-logic-only (progn (defparameter *32-bit-integer-stack* (make-array 5 :element-type '(signed-byte 32))) (defparameter *32-bit-integer-stack-length* 0) ) (defun 32-bit-integer-stack-length1 (state-state) (declare (xargs :guard (state-p1 state-state))) #-acl2-logic-only (cond ((live-state-p state-state) (return-from 32-bit-integer-stack-length1 *32-bit-integer-stack-length*))) (length (32-bit-integer-stack state-state))) (defun 32-bit-integer-stack-length (state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (state-p1 state-state))) (32-bit-integer-stack-length1 state-state)) (defun extend-32-bit-integer-stack (n val state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (xargs :guard (and (32-bit-integerp val) (integerp n) (> n 0) (state-p1 state-state)))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'extend-32-bit-integer-stack (list n val)))) (let ((new-length (+ *32-bit-integer-stack-length* n))) (cond ((> new-length (length (the (array (signed-byte 32) (*)) *32-bit-integer-stack*))) (cond ((> (* 2 new-length) array-dimension-limit) (interface-er "Resource error. Attempt to create too ~ large a stack."))) (let ((new-length new-length)) (declare (fixnum new-length)) (let ((new-array (make-array (* 2 new-length) :element-type '(signed-byte 32)))) (declare (type (array (signed-byte 32) (*)) new-array)) (do ((i (1- *32-bit-integer-stack-length*) (1- i))) ((< i 0)) (declare (fixnum i)) (setf (aref (the (array (signed-byte 32) (*)) new-array) i) (aref (the (array (signed-byte 32) (*)) *32-bit-integer-stack*) i))) (setq *32-bit-integer-stack* new-array))))) (let ((new-length new-length)) (declare (fixnum new-length)) (do ((i *32-bit-integer-stack-length* (1+ i))) ((= i new-length)) (declare (fixnum i)) (setf (aref (the (array (signed-byte 32) (*)) *32-bit-integer-stack*) i) val)) (setq *32-bit-integer-stack-length* new-length))) (return-from extend-32-bit-integer-stack state-state))) (update-32-bit-integer-stack (append (32-bit-integer-stack state-state) (make-list-ac n val nil)) state-state)) (defun shrink-32-bit-integer-stack (n state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. (declare (type (integer 0 *) n) (xargs :guard (state-p1 state-state))) #-acl2-logic-only (cond ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'shrink-32-bit-integer-stack (list n)))) (let ((old *32-bit-integer-stack-length*) (new (max 0 (- *32-bit-integer-stack-length* n)))) (declare (fixnum old new)) (setq *32-bit-integer-stack-length* new) (do ((i new (1+ i))) ((= i old)) (declare (fixnum i)) (setf (aref (the (array (signed-byte 32) (*)) *32-bit-integer-stack*) i) 0))) (return-from shrink-32-bit-integer-stack state-state))) (update-32-bit-integer-stack (first-n-ac (max 0 (- (length (32-bit-integer-stack state-state)) n)) (32-bit-integer-stack state-state) nil) state-state)) (defun aref-32-bit-integer-stack (i state-state) #-acl2-logic-only (declare (fixnum i)) (declare (xargs :guard (and (integerp i) (>= i 0) (state-p1 state-state) (< i (32-bit-integer-stack-length1 state-state))))) ; Wart: We use state-state instead of state because of a bootstrap problem. #-acl2-logic-only (the (signed-byte 32) (cond ((live-state-p state-state) (the (signed-byte 32) (aref (the (array (signed-byte 32) (*)) *32-bit-integer-stack*) (the fixnum i)))) (t (nth i (32-bit-integer-stack state-state))))) #+acl2-logic-only (nth i (32-bit-integer-stack state-state))) (defun aset-32-bit-integer-stack (i val state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. #-acl2-logic-only (declare (fixnum i)) (declare (type (signed-byte 32) val)) (declare (xargs :guard (and (integerp i) (>= i 0) (state-p1 state-state) (< i (32-bit-integer-stack-length1 state-state)) (32-bit-integerp val)))) (cond #-acl2-logic-only ((live-state-p state-state) (cond (*wormholep* (wormhole-er 'aset-32-bit-integer-stack (list i val)))) (setf (aref (the (array (signed-byte 32) (*)) *32-bit-integer-stack*) (the fixnum i)) (the (signed-byte 32) val)) state-state) (t (update-32-bit-integer-stack (update-nth i val (32-bit-integer-stack state-state)) state-state)))) (defmacro f-big-clock-negative-p (st) #-acl2-logic-only (let ((s (gensym))) `(let ((,s ,st)) (cond ((live-state-p ,s) nil) (t (big-clock-negative-p ,s))))) #+acl2-logic-only (list 'big-clock-negative-p st)) (defmacro f-decrement-big-clock (st) #-acl2-logic-only (let ((s (gensym))) `(let ((,s ,st)) (cond ((live-state-p ,s) ; Because there is no way to get the big-clock-entry for ; *the-live-state* we do not have to prevent the field from changing ; when *wormholep* is true. *the-live-state*) (t (decrement-big-clock ,s))))) #+acl2-logic-only (list 'decrement-big-clock st)) (defun big-clock-negative-p (state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. ; big-clock-negative-p plays a crucial role in the termination of ev, ; translate1, and rewrite. The justification for big-clock-negative-p ; never returning t when given *the-live-state* be found in a comment ; on ld, where it is explained that a (constructive) existential ; quantifier is used in semantics of a top-level interaction with ld. ; Any ld interaction that completes will have called ; big-clock-decrement at most a finite number of times. The number of ; these calls will provide an appropriate value for the ; big-clock-entry for that interaction. (declare (xargs :guard (state-p1 state-state))) #-acl2-logic-only (cond ((live-state-p state-state) (return-from big-clock-negative-p nil))) (< (big-clock-entry state-state) 0)) (defun decrement-big-clock (state-state) ; Wart: We use state-state instead of state because of a bootstrap problem. ; decrement-big-clock is the one function which is permitted to ; violate the rule that any function which is passed a state and ; modifies it must return it. A function that is passed state may ; pass one down the result of apply decrement-big-clock to the given ; state. decrement-big-clock is exempted from the requirement because ; there are means internal or external to Acl2 for perceiving the ; current big-clock value. (declare (xargs :guard (state-p1 state-state))) #-acl2-logic-only (cond ((live-state-p state-state) ; Because there is no way to get the big-clock-entry for ; *the-live-state* we do not have to prevent the field from changing ; when *wormholep* is true. (return-from decrement-big-clock *the-live-state*))) (update-big-clock-entry (1- (big-clock-entry state-state)) state-state)) (defun list-all-package-names (state-state) (declare (xargs :guard (state-p1 state-state))) ; Wart: We use state-state instead of state because of a bootstrap problem. #-acl2-logic-only (cond ((live-state-p state-state) (return-from list-all-package-names (mv (mapcar (function package-name) (list-all-packages)) state-state)))) (mv (car (list-all-package-names-lst state-state)) (update-list-all-package-names-lst (cdr (list-all-package-names-lst state-state)) state-state))) (defun power-eval (l b) (declare (xargs :guard (and (rationalp b) (rational-lst l)))) (if (null l) 0 (+ (car l) (* b (power-eval (cdr l) b))))) #-acl2-logic-only (defun idate () (power-eval (let (ans) (do ((i 1 (1+ i)) (tl (multiple-value-list (get-decoded-time)) (cdr tl))) ((> i 6) (reverse ans)) (push (cond ((= i 6) (- (car tl) 1900)) (t (car tl))) ans)) (reverse ans)) 100)) (defun read-idate (state-state) (declare (xargs :guard (state-p1 state-state))) ; Wart: We use state-state instead of state because of a bootstrap problem. #-acl2-logic-only (cond ((live-state-p state-state) ; Because there is no way for the user to know what the idates of the original ; state were, there is no way to tell whether we changed them. So we permit ; read-idate to work even when *wormholep* is non-nil. (return-from read-idate (mv (idate) state-state)))) (mv (cond ((null (idates state-state)) 0) (t (car (idates state-state)))) (update-idates (cdr (idates state-state)) state-state))) (defun read-run-time (state-state) (declare (xargs :guard (state-p1 state-state))) ; Wart: We use state-state instead of state because of a bootstrap problem. #-acl2-logic-only (cond ((live-state-p state-state) ; Because there is no way for the user to know what the run-times of the original ; state were, there is no way to tell whether we changed them. So we permit ; read-run-times to work even when *wormholep* is non-nil. (return-from read-run-time (mv (/ (get-internal-run-time) internal-time-units-per-second) state-state)))) (mv (cond ((null (run-times state-state)) 0) (t (car (run-times state-state)))) (update-run-times (cdr (run-times state-state)) state-state))) ; Time: idate, run-time, and timers. ; Time is a very nonapplicative thing. What is it doing in an ; applicative programming language and verification system? Formally, ; read time and cpu time are simply components of state which are ; lists of numbers about which we say nothing, not even that they are ; ascending. In actual practice, the numbers that we provide ; correspond to the universal time and the cpu time at the moment that ; read-idate and read-run-time are called. ; We provide a mechanism for the user to report real time and to keep ; trace of and report cpu time, but we do not let the user do anything ; with times except print them, so as to keep computations entirely ; deterministic for read-book. We prohibit the user from accessing ; the internal timing subroutines and state variables by putting them ; on untouchables. (If we ever implement a file system, then of ; course the nondeterminism of read-book will be shattered because a ; user could check what sort of io was being generated.) ; The user can print the current date in a format we call the idate by ; calling (print-current-idate channel state). ; To keep track of the cpu time used in a way we find congenial, we ; implement a facility called timers. A ``timer'' is a symbolp with ; an associated value in the timer-alistp called the 'timer-alist, ; stored in the global table of state. Typically the value of a timer ; is a list of rationals, treated as a stack. One may have many such ; timers. As of this writing, the Acl2 system itself has three: ; 'prove-time, 'print-time, and 'other-time, and we use a singleton stack ; 'total-time, as a temporary to sum the times on the other stacks. ; To clean the slate, i.e. to get ready to start a new set of timings, ; one could invoke (set-timer 'prove-time '(0) state), (set-timer ; 'print-time '(0) state), etc., and finally (main-timer state). The ; set-timer function set the values of the timers each to a stack ; containing a single 0. The call of main-timer can be thought of as ; starting the clock running. What it actually does is store the ; current cpu-time-used figure in a secret place to be used later. ; Now, after some computing one could invoke (increment-timer ; 'prove-time state), which would attribute all of the cpu time used ; since cleaning the slate to the top-most element on the 'prove-time ; timer. That is, increment-timer takes the time used since the ; ``clock was started'' and adds it to the number on the top of the ; given timer stack. Increment-timer also restarts the clock. One ; could later execute (increment-timer 'print-time state), which would ; attribute all of the cpu time used since the previous call of ; increment-timer to 'print-time. And so forth. At an appropriate ; time, one could then call (print-timer 'print-time channel state) and ; (print-timer 'prove-time time), which would print the top-most ; values of the timers. Finally, one could either pop the timer ; stacks, exposing accumulated time in that category for some superior ; computation, or pop the stacks but add the popped time into the ; newly exposed accumulated time (charging the superior with the time ; used by the inferior), or simply reset the stacks as by set-timer. ; Time is maintained as a rational. We print time in seconds, accurate ; to two decimal places. We just print the number, without leading or ; trailing spaces or even the word ``seconds''. (defthm len-update-nth (implies (and (integerp n) (<= 0 n) (true-listp x) (< n (len x))) (equal (len (update-nth n val x)) (len x)))) (defthm update-run-times-preserves-state-p1 (implies (and (state-p1 state) (rational-lst times)) (state-p1 (update-run-times times state))) :hints (("Goal" :in-theory (enable state-p1)))) (in-theory (disable update-run-times)) (local (defthm rational-lst-cdr (implies (rational-lst x) (rational-lst (cdr x))))) (defthm read-run-time-preserves-state-p1 (implies (state-p1 state) (state-p1 (nth 1 (read-run-time state)))) :rule-classes ((:forward-chaining :trigger-terms ((nth 1 (read-run-time state))))) :hints (("Goal" :in-theory (enable nth)))) ; Perhaps the following should be local. (defthm rational-lst-implies-rationalp-car (implies (and (rational-lst x) x) (rationalp (car x)))) (defthm nth-0-read-run-time-type-prescription (implies (state-p1 state) (rationalp (nth 0 (read-run-time state)))) :hints (("Goal" :in-theory (enable nth))) :rule-classes ((:type-prescription :typed-term (nth 0 (read-run-time state))))) (in-theory (disable read-run-time)) (defun main-timer (state) (declare (xargs :guard (state-p state))) (mv-let (current-time state) (read-run-time state) (let ((old-value (cond ((and (f-boundp-global 'main-timer state) (rationalp (f-get-global 'main-timer state))) (f-get-global 'main-timer state)) (t 0)))) (let ((state (f-put-global 'main-timer current-time state))) (mv (- current-time old-value) state))))) (defun put-assoc-eq (name val alist) (declare (xargs :guard (if (symbolp name) (alistp alist) (symbol-alistp alist)))) (cond ((null alist) (list (cons name val))) ((eq name (caar alist)) (cons (cons name val) (cdr alist))) (t (cons (car alist) (put-assoc-eq name val (cdr alist)))))) (defthm timer-alist-bound-in-state-p1 (implies (state-p1 s) (boundp-global1 'timer-alist s)) :hints (("Goal" :in-theory (enable state-p1)))) (defthm timer-alist-bound-in-state-p (implies (state-p s) (boundp-global1 'timer-alist s))) (defun set-timer (name val state) (declare (xargs :guard (and (symbolp name) (rational-lst val) (state-p state)))) (f-put-global 'timer-alist (put-assoc-eq name val (f-get-global 'timer-alist state)) state)) (defun get-timer (name state) (declare (xargs :guard (and (symbolp name) (state-p state)))) (cdr (assoc-eq name (f-get-global 'timer-alist state)))) (local (defthm timer-alistp-implies-rational-lst-assoc-eq (implies (and (symbolp name) (timer-alistp alist)) (rational-lst (cdr (assoc-eq name alist)))))) (defun push-timer (name val state) (declare (xargs :guard (and (symbolp name) (rationalp val) (state-p state)))) (set-timer name (cons val (get-timer name state)) state)) ; The following four rules were not necessary until we added complex numbers. ; However, the first one is now crucial for acceptance of pop-timer. (defthm rationalp-+ (implies (and (rationalp x) (rationalp y)) (rationalp (+ x y)))) (defthm rationalp-* (implies (and (rationalp x) (rationalp y)) (rationalp (* x y)))) (defthm rationalp-unary-- (implies (rationalp x) (rationalp (- x)))) (defthm rationalp-unary-/ (implies (and (rationalp x) (not (equal x 0))) (rationalp (/ x)))) (defun pop-timer (name flg state) ; If flg is nil we discard the popped value. If flg is t we ; add the popped value into the exposed value. (declare (xargs :guard (and (symbolp name) (state-p state) (consp (get-timer name state)) (or (null flg) (consp (cdr (get-timer name state))))))) (let ((timer (get-timer name state))) (set-timer name (if flg (cons (+ (car timer) (cadr timer)) (cddr timer)) (cdr timer)) state))) (defun add-timers (name1 name2 state) (declare (xargs :guard (and (symbolp name1) (symbolp name2) (state-p state) (consp (get-timer name1 state)) (consp (get-timer name2 state))))) (let ((timer1 (get-timer name1 state)) (timer2 (get-timer name2 state))) (set-timer name1 (cons (+ (car timer1) (car timer2)) (cdr timer1)) state))) ;; Here are lemmas for opening up nth on explicitly given conses (defthm nth-0-cons (implies (true-listp l) (equal (nth 0 (cons a l)) a)) :hints (("Goal" :in-theory (enable nth)))) (local (defthm plus-minus-1-1 (implies (rationalp x) (equal (+ -1 1 x) x)))) (defthm nth-add1 (implies (and (integerp n) (>= n 0) (true-listp l)) (equal (nth (+ 1 n) (cons a l)) (nth n l))) :hints (("Goal" :expand (nth (+ 1 n) (cons a l))))) (defthm main-timer-type-prescription (implies (state-p1 state) (and (consp (main-timer state)) (true-listp (main-timer state)))) :rule-classes :type-prescription) (defthm ordered-symbol-alistp-add-pair-forward (implies (and (symbolp key) (ordered-symbol-alistp l)) (ordered-symbol-alistp (add-pair key value l))) :rule-classes ((:forward-chaining :trigger-terms ((add-pair key value l))))) #| (defthm eqlable-alistp-add-pair (implies (and (symbolp key) (ordered-symbol-alistp l)) (eqlable-alistp (add-pair key value l)))) |# (defthm assoc-add-pair (implies (and (symbolp sym2) (ordered-symbol-alistp alist)) (equal (assoc sym1 (add-pair sym2 val alist)) (if (equal sym1 sym2) (cons sym1 val) (assoc sym1 alist))))) (defthm add-pair-preserves-all-boundp (implies (and (eqlable-alistp alist1) (ordered-symbol-alistp alist2) (all-boundp alist1 alist2) (symbolp sym)) (all-boundp alist1 (add-pair sym val alist2)))) (defthm state-p1-update-main-timer (implies (state-p1 state) (state-p1 (update-nth 2 (add-pair 'main-timer val (nth 2 state)) state))) :hints (("Goal" :in-theory (set-difference-theories (enable state-p1 global-table) '(true-listp ordered-symbol-alistp assoc getprop integer-lst rational-lst all-true-listp open-channels-p all-boundp worldp timer-alistp known-package-alistp 32-bit-integer-lst file-clock-p readable-files-p written-files-p read-files-p writeable-files-p)))) :rule-classes ((:forward-chaining :trigger-terms ((update-nth 2 (add-pair 'main-timer val (nth 2 state)) state))))) (defun increment-timer (name state) (declare (xargs :guard (and (symbolp name) (state-p state) (consp (get-timer name state))))) (let ((timer (get-timer name state))) (mv-let (epsilon state) (main-timer state) (set-timer name (cons (+ (car timer) epsilon) (cdr timer)) state)))) (skip-proofs (defun print-rational-as-decimal (x channel state) (declare (xargs :guard (and (rationalp x) (state-p state) (open-output-channel-p channel :character state)))) (let ((x00 (round (* 100 (abs x)) 1))) (pprogn (cond ((< x 0) (princ$ "-" channel state)) (t state)) (cond ((> x00 99) (princ$ (floor (/ x00 100) 1) channel state)) (t (princ$ "0" channel state))) (princ$ "." channel state) (let ((r (rem x00 100))) (cond ((< r 10) (pprogn (princ$ "0" channel state) (princ$ r channel state))) (t (princ$ r channel state))))))) ) (skip-proofs (defun print-timer (name channel state) (declare (xargs :guard (and (symbolp name) (state-p state) (open-output-channel-p channel :character state) (consp (get-timer name state))))) (print-rational-as-decimal (car (get-timer name state)) channel state)) ) ; Prin1 ; We need to specify the :induct hint below because we also want to ; disable state-p1. By so doing we make (state-p1 state) turn state ; into a udf var which causes us to remove the desired induction from ; our consideration. #-acl2-logic-only (defconstant *char-code-backslash* (char-code #\\)) #-acl2-logic-only (defconstant *char-code-double-gritch* (char-code #\")) (skip-proofs (defun prin1$ (x channel state) ; prin1$ differs from prin1 in several ways. The second arg is state, not ; a stream. prin1$ returns the modified state, not x. (declare (xargs :guard (and (or (acl2-numberp x) (characterp x) (stringp x) (symbolp x)) (state-p state) (open-output-channel-p channel :character state)))) #-acl2-logic-only (cond ((live-state-p state) (cond ((and *wormholep* (not (eq channel *standard-co*))) (wormhole-er 'prin1$ (list x channel)))) (let ((stream (get-output-stream-from-channel channel))) (cond ((acl2-numberp x) (princ x stream)) ((characterp x) (princ "#\\" stream) (princ (case x (#\Newline "Newline") (#\Space "Space") (#\Page "Page") (#\Tab "Tab") (#\Rubout "Rubout") (otherwise x)) stream)) ((stringp x) (princ #\" stream) (let ((n (length (the string x)))) (declare (fixnum n)) (block check (do ((i 0 (1+ i))) ((= i n)) (declare (fixnum i)) (let ((ch (char-code (aref (the string x) i)))) (declare (fixnum ch)) (cond ((or (= ch *char-code-backslash*) (= ch *char-code-double-gritch*)) (prin1-with-slashes x #\" channel state) (return-from check nil))))) (princ x stream))) (princ #\" stream)) ((symbolp x) (cond ((keywordp x) (princ #\: stream)) ((or (equal (symbol-package-name x) (f-get-global 'current-package state)) (member-eq x (cdr (assoc-equal (f-get-global 'current-package state) (global-val 'known-package-alist (f-get-global 'current-acl2-world state)))))) state) (t (let ((p (symbol-package-name x))) (cond ((may-need-slashes p) (princ "|" stream) (prin1-with-slashes p #\| channel state) (princ "|" stream)) (t (princ p stream))) (princ "::" stream)))) (cond ((may-need-slashes (symbol-name x)) (princ #\| stream) (prin1-with-slashes (symbol-name x) #\| channel state) (princ #\| stream)) (t (princ x stream)))) (t (error "Prin1$ called on an illegal object ~a~%~%." x))) (return-from prin1$ state)))) (cond ((acl2-numberp x) (princ$ x channel state)) ((characterp x) (pprogn (princ$ "#\\" channel state) (princ$ (case x (#\Newline "Newline") (#\Space "Space") (#\Page "Page") (#\Tab "Tab") (#\Rubout "Rubout") (otherwise x)) channel state))) ((stringp x) (let ((l (coerce x 'list))) (pprogn (princ$ #\" channel state) (cond ((or (member #\\ l) (member #\" l)) (prin1-with-slashes x #\" channel state)) (t (princ$ x channel state))) (princ$ #\" channel state)))) (t (pprogn (cond ((keywordp x) (princ$ #\: channel state)) ((or (equal (symbol-package-name x) (f-get-global 'current-package state)) (member-eq x (cdr (assoc-equal (f-get-global 'current-package state) (global-val 'known-package-alist (f-get-global 'current-acl2-world state)))))) state) (t (let ((p (symbol-package-name x))) (pprogn (cond ((may-need-slashes p) (pprogn (princ$ #\| channel state) (prin1-with-slashes p #\| channel state) (princ$ #\| channel state))) (t (princ$ p channel state))) (princ$ "::" channel state))))) (cond ((may-need-slashes (symbol-name x)) (pprogn (princ$ #\| channel state) (prin1-with-slashes (symbol-name x) #\| channel state) (princ$ #\| channel state))) (t (princ$ x channel state))))))) ) ; UNTOUCHABLES ; The ``untouchables'' mechanism of Acl2, we believe, gives Acl2 a ; modest form of write-protection which can be used to preserve ; integrity in the presence of arbitrary Acl2 user acts. (What about ; undoing??? How do we prevent that?) If a symbol s is a member of ; the value of the global variable untouchables, then translate will ; cause an error if one attempts to define a function or macro (or to ; directly execute code) that would either (a) set or make unbound a ; global variable with name s or (b) call a function named s. The ; general idea is to have a ``sacred'' variable, e.g. ; current-acl2-world, which the user cannot directly alter once that ; variable has been placed on untouchables. Instead, to alter that ; variable, the user is required to invoke certain functions that were ; defined before the variable was made untouchable. Of course, the ; implementor must take great care to make sure that any auxilliary ; functions which can alter the variable are also rendered ; untouchable! We do not attempt to enforce any sort of read ; protection; untouchables is entirely oriented towards write ; protection. read protection could not be perfectly enforced in any ; case since by calling translate one could at least find out what was ; on untouchables. (defthm all-boundp-preserves-assoc (implies (and (eqlable-alistp tbl1) (eqlable-alistp tbl2) (all-boundp tbl1 tbl2) (symbolp x) (assoc-eq x tbl1)) (assoc x tbl2)) :rule-classes nil) (local (defthm all-boundp-initial-global-table (implies (and (state-p1 state) (assoc-eq x *initial-global-table*)) (assoc x (nth 2 state))) :hints (("Goal" :use ((:instance all-boundp-preserves-assoc (tbl1 *initial-global-table*) (tbl2 (nth 2 state)))) :in-theory (disable assoc all-boundp eqlable-alistp))))) (defun push-untouchable (x state) (declare (xargs :guard (and (symbolp x) (state-p state)))) (f-put-global 'untouchables (cons x (f-get-global 'untouchables state)) state)) (defun w (state) (declare (xargs :guard (state-p state))) (f-get-global 'current-acl2-world state)) (defun current-package (state) (declare (xargs :guard (state-p state))) ":Doc-Section Miscellaneous the package used for reading and printing~/ Current-package is an LD special (see :DOC ld). The accessor is (current-package state) and the updater is (set-current-package val state), or more conventionally, (in-package val). The value of current-package is actually the string that names the package. (Common Lisp's ``package'' objects do not exist in Acl2.) The current package must known to Acl2, i.e., it must be one of the initial packages or a package defined with DEFPKG by the user.~/ When printing symbols, the package prefix is displayed if it is not the current-package and may be optionally displayed otherwise. Thus, if current-package is \"ACL2\" then the symbol 'ACL2::SYMB may be printed as SYMB or ACL2::SYMB, while 'MY-PKG::SYMB must be printed as MY-PKG::SYMB. But if current-package is \"MY-PKG\" then the former symbol must be printed as ACL2::SYMB while the latter may be printed as SYMB. In Common Lisp, current-package also affects how objects are read from character streams. Roughly speaking, read and print are inverses if the current-package is fixed, so reading from a stream produced by printing an object must produce an equal object. In Acl2, the situation is more complicated because we never read objects from character streams, we only read them from object ``streams'' (channels). Logically speaking, the objects in such a channel are fixed regardless of the setting of current-package. However, our host file systems do not support the idea of Lisp object files and instead only support character files. So when you open an object input channel to a given (character file) we must somehow convert it to a list of Acl2 objects. This is done by a deus ex machina (``a person or thing that appears or is introduced suddenly and unexpectedly and provides a contrived solution to an apparently insoluble difficulty,'' Webster's Ninth New Collegiate Dictionary). Roughly speaking, the deus ex machina determines what sequence of calls to read-object will occur in the future and what the current-package will be during each of those calls, and then produces a channel containing the sequence of objects produced by an analogous sequence of Common Lisp reads with *current-package* bound appropriately for each. A simple rule suffices to make sane file io possible: before you read an object from an object channel to a file created by printing to a character channel, make sure the current-package at read-time is the same as it was at print-time." (f-get-global 'current-package state)) (defun known-package-alist (state) (declare (xargs :guard (state-p state))) (getprop 'known-package-alist 'global-value nil 'current-acl2-world (w state))) (defthm state-p1-update-nth-2-world (implies (and (state-p1 state) (worldp wrld) (known-package-alistp (getprop 'known-package-alist 'global-value nil 'current-acl2-world wrld)) (symbol-alistp (getprop 'acl2-defaults-table 'table-alist nil 'current-acl2-world wrld))) (state-p1 (update-nth 2 (add-pair 'current-acl2-world wrld (nth 2 state)) state))) :hints (("Goal" :in-theory (set-difference-theories (enable state-p1) '(global-val true-listp ordered-symbol-alistp assoc getprop integer-lst rational-lst all-true-listp open-channels-p all-boundp worldp timer-alistp known-package-alistp 32-bit-integer-lst file-clock-p readable-files-p written-files-p read-files-p writeable-files-p))))) ;;; For the toothbrush, we don't want to pull in retract-world1 or ;;; extend-world1. #| (defun set-w (flg wrld state) ; This is the only way in Acl2 (as opposed to raw Common Lisp) to ; install wrld as the current-acl2-world. Flg must be either ; 'extension or 'retraction. Logically speaking, all this function ; does is set the state global value of 'current-acl2-world in state ; to be wrld and possibly set current-package to "ACL2". Practically, ; speaking however, it installs wrld on the symbol-plists in Common ; Lisp. However, wrld must be an extension or retraction, as ; indicated, of the currently installed Acl2 world. ; Statement of Policy regarding Erroneous Events and ; Current Acl2 World Installation: ; Any event which causes an error must leave the current-acl2-world of ; state unchanged. That is, if you extend the world in an event, you ; must revert on error back to the original world. Once upon a time ; we enforced this rule in LD, simply by reverting the world on every ; erroneous command. But then we made that behavior conditional on ; the LD special ld-error-triples. If ld-error-triples is nil, then ; (mv t nil state) is not treated as an error by LD. Hence, an ; erroneous DEFUN, say, evaluated with ld-error-triples nil, does not ; cause LD to revert. Therefore, DEFUN must manage the reversion ; itself. #+acl2-logic-only (declare (xargs :guard (and (or (eq flg 'extension) (eq flg 'retraction)) (worldp wrld) (known-package-alistp (getprop 'known-package-alist 'global-value nil 'current-acl2-world wrld)) (symbol-alistp (getprop 'acl2-defaults-table 'table-alist nil 'current-acl2-world wrld)) (state-p state)))) #+acl2-logic-only (pprogn (f-put-global 'current-acl2-world wrld state) (cond ((assoc-equal (current-package state) (known-package-alist state)) state) (t (f-put-global 'current-package "ACL2" state)))) #-acl2-logic-only (cond ((live-state-p state) (cond ((and *wormholep* (not (eq wrld (w *the-live-state*)))) (push-wormhole-undo-formi 'cloaked-set-w! (w *the-live-state*) nil))) (cond ((eq flg 'extension) (extend-world1 'current-acl2-world wrld) state) (t (retract-world1 'current-acl2-world wrld) state))) (t (f-put-global 'current-acl2-world wrld state) (cond ((assoc-equal (current-package state) (known-package-alist state)) state) (t (f-put-global 'current-package "ACL2" state)))))) |# (defun get-untouchables (state) (declare (xargs :guard (state-p state))) (f-get-global 'untouchables state)) (defconst *initial-untouchables* '(coerce-state-to-object coerce-object-to-state f-put-ld-specials include-book-action-on-uncertified-books certify-book-file connected-book-directory install-event set-w set-w! cloaked-set-w! current-package current-acl2-world undone-worlds-kill-ring ld-skip-proofsp ld-redefinition-action timer-alist ; Why is untouchables not a member of untouchables? There is no point ; in putting untouchables on untouchables because a user can always ; attempt to tranlate a form that mentions an untouchable and thereby ; obtain the information anyway. read-idate read-run-time main-timer get-timer wormhole-name )) (defconst *acl2-exports* '(iff implies state xargs defpkg defun defuns mutual-recursion defconst deflabel deftheory defmacro in-theory table defthm defaxiom encapsulate include-book certify-book local verify-guards verify-termination verify retrieve toggle-pc-macro define-pc-macro define-pc-atomic-macro prove thm assume current-theory disable enable executable-counterpart-theory function-theory intersection-theories set-difference-theories theory union-theories universal-theory mv mv-let assign @ ld ubt) "This is the list of Acl2 symbols that the ordinary user is extremely likely to want to include in the import list of any package created because these symbols are the basic hooks for using Acl2. However, it is never necessary to do such importing: one can always use the acl2:: prefix." ) ; We need to have these bound for trace to work. It uses ; current-package for printing and current-acl2-world for ; current-acl2-world suppression. #-acl2-logic-only (dolist (pair *initial-global-table*) (f-put-global (car pair) (cdr pair) *the-live-state*)) (defun union-eq (lst1 lst2) (declare (xargs :guard (and (symbolp-listp lst1) (true-listp lst2)))) (cond ((null lst1) lst2) ((member-eq (car lst1) lst2) (union-eq (cdr lst1) lst2)) (t (cons (car lst1) (union-eq (cdr lst1) lst2))))) ; There are a variety of state global variables, 'ld-skip-proofsp among them, ; that are "bound" by LD in the sense that their values are protected by ; pushing them upon entrance to LD and popping them upon exit. These globals ; are called the "LD specials". For each LD special there are accessor and ; updater functions. The updaters enforce our invariants on the values of the ; globals. We now define the accessor for the LD special ld-skip-proofsp. We ; delay the introduction of the updater until we have some error handling ; functions. (defun ld-skip-proofsp (state) (declare (xargs :guard (state-p state))) ":Doc-Section Miscellaneous how carefully Acl2 processes your commands~/ Examples: ACL2 Gold>(set-ld-skip-proofsp nil state) ACL2 Gold>(set-ld-skip-proofsp t state) ACL2 Gold>(set-ld-skip-proofsp 'include-book state)~/ A global variable in the Acl2 state, called 'ld-skip-proofsp, determines the thoroughness with which Acl2 processes your commands. This variable may take on one of three values: t, nil or 'include-book. When ld-skip-proofsp is non-nil, the system assumes that which ought to be proved and is thus unsound. The form (set-ld-skip-proofsp flg state) is the general-purpose way of setting ld-skip-proofsp. This global variable is an ``LD special,'' which is to say, you may call LD in such a way as to ``bind'' this variable for the dynamic extent of the LD. When ld-skip-proofsp is non-nil, the default prompt displays the default-color enclosed in parentheses. Thus, the prompt ACL2 (:Gold)> means that the default-color is :gold but ``proofs are being skipped.'' Observe that there are two legal non-nil values, t and 'include-book. When ld-skip-proofsp is t, Acl2 skips all proof obligations but otherwise performs all other required analysis of input events. When ld-skip-proofsp is 'include-book, Acl2 skips not only proof obligations but all analysis except that required to compute the effect of successfully executed events. To explain the distinction, let us consider one particular event, say a DEFUN. Very roughly speaking, a DEFUN event normally involves a check of the syntactic well-formedness of the submitted definition, the generation and proof of the termination conditions, and the computation and storage of various rules such as a :DEFINITION rule and some :TYPE-PRESCRIPTION rules. By ``normally'' above we mean when ld-skip-proofsp is nil. How does a DEFUN behave when ld-skip-proofsp is non-nil? If ld-skip-proofsp is t, then DEFUN performs the syntactic well-formedness checks and computes and stores the various rules, but it does not actually carry out the termination proofs. If ld-skip-proofsp is 'include-book, DEFUN does not do the syntactic well-formedness check nor does it carry out the termination proof. Instead, it merely computes and stores the rules under the assumption that the checks and proofs would all succeed. Observe that a setting of 'include-book is ``stronger'' than a setting of t in the sense that 'include-book causes DEFUN to assume even more about the admissibility of the event than t does. As one might infer from the choice of name, the INCLUDE-BOOK event sets ld-skip-proofsp to 'include-book when processing the events in a book being loaded. Thus, INCLUDE-BOOK does the miminal work necessary to carry out the effects of every event in the book. The syntactic checks and proof obligations were, presumably, successfully carried out when the book was certified. A non-nil value for ld-skip-proofsp also affects the system's output messages. Event summaries (the paragraphs that begin ``Summary'' and display the event forms, rules used, etc.) are not printed when ld-skip-proofsp is non-nil. Warnings and observations are printed when ld-skip-proofsp is t but are not printed when it is 'include-book. Intuitively, ld-skip-proofsp t means skip just the proofs and otherwise do all the work normally required for an event; while ld-skip-proofsp 'include-book is ``stronger'' and means do as little as possible to process events. In accordance with this intuition, LOCAL events are processed when ld-skip-proofsp is t but are skipped when ld-skip-proofsp is 'include-book. The Acl2 system itself uses only two settings, nil and 'include-book, the latter being used only when executing the events inside of a book being included. The ld-skip-proofsp setting of t is provided as a convenience to the user. For example, suppose one has a file of events. By loading it with LD with ld-skip-proofsp set to t, the events can all be checked for syntactic correctness and assumed without proof. This is a convenient way to recover a state lost by a system crash or to experiment with a modification of an events file. The foregoing discussion is actually based on a lie. Ld-skip-proofsp is allowed two other values, 'initialize-acl2 and 'include-book-with-locals. The first causes behavior similar to t but skips LOCAL events and avoids some error checks that would otherwise prevent Acl2 from properly booting. The second is identical to 'include-book but also executes LOCAL events. These additional values are not intended for use by the user, but no barriers to their use have been erected. We close by reminding the user that Acl2 is potentially unsound if ld-skip-proofsp is ever set by the user. We provide access to it simply to allow experimentation and rapid reconstruction of lost or modified logical worlds." (f-get-global 'ld-skip-proofsp state)) ; Now we define the weak notion of term that guards metafunctions. (mutual-recursion (defun pseudo-termp (x) (cond ((atom x) (symbolp x)) ((not (true-listp x)) nil) ((eq (car x) 'quote) t) ((not (pseudo-termp-lst (cdr x))) nil) (t (or (symbolp (car x)) ; For most function applications we do not check that the number of ; arguments matches the number of formals. However, for lambda ; applications we do make that check. The reason is that the ; constraint on an evaluator dealing with lambda applications must use ; pairlis$ to pair the formals with the actuals and pairlis$ insists on ; the checks below. (and (true-listp (car x)) (equal (length (car x)) 3) (eq (car (car x)) 'lambda) (symbolp-listp (cadr (car x))) (pseudo-termp (caddr (car x))) (equal (length (cadr (car x))) (length (cdr x)))))))) (defun pseudo-termp-lst (lst) (cond ((atom lst) (equal lst nil)) (t (and (pseudo-termp (car lst)) (pseudo-termp-lst (cdr lst)))))) ) #-acl2-logic-only (defun bad-lisp-objectp (x deceased-packages) ; This routine does a root and branch exploration of x and guarantees ; that x is composed entirely of complex rationals, rationals, ; characters in the Common Lisp standard character set plus #\Page, ; #\Tab, and #\Rubout, strings of such characters, symbols made from ; such strings (and "interned" in a package known to Acl2) and conses ; of the foregoing. ; Deceased-packages is a list of package name strings, e.g., ; ("MY-PKG") that are to be considered as though they are no ; longer known. The problem is that we sometimes call this function ; when we are in the process of undoing a defpkg. At the time of the ; call, the package name is still on the known-package-alist of the ; state, but we would like to do this check as though it were not. ; We return nil or non-nil. If nil, then x is a legal Acl2 object. ; If we return non-nil, then x is a bad object and the answer is a ; message, msg, such that (fmt "~@0" (list (cons #\0 msg)) ...) will ; explain why. ; All of our Acl2 code other than this routine assumes that we are ; manipulating non-bad objects, except for symbols in the invisible ; package, e.g. state and the invisible array mark. We make these ; restrictions for portability's sake. If a Lisp expression is a ; theorem on a Symbolics machine we want it to be a theorem on a Sun. ; Thus, we can't permit such constants as #\Circle-Plus. We also ; assume (and check in chk-suitability-of-this-common-lisp) that all ; of the characters mentioned above are distinct. (cond ((integerp x) ; CLTL2 says, p. 39, ``X3J13 voted in January 1989 <76> to ; specify that the types of fixnum and bignum do in fact form ; an exhaustive partition of the type integer; more precisely, ; they voted to specify that the type bignum is by definition ; equivalent to (and integer (not fixnum)). I interpret this ; to mean that implementators (sic) could still experiment with ; such extensions as adding explicit representations of infinity, ; but such infinities would necessarily be of type bignum'' ; The axioms of Acl2 would certainly not hold for experimental ; infinite bignums. But we know of no way to test for an infinite ; integer. So we repeatedly take the square root to check that we get ; to a fixnum (which would include 0). (do ((i 0 (1+ i)) (y (abs x) (isqrt y))) (nil) (cond ((typep y 'fixnum) (return nil)) ((> i 200) (return (cons "We suspect that ~p0 is an infinite ~ integer, which we cannot handle in ~ Acl2." (list (cons #\0 x)))))))) ((typep x '(complex rational)) (or (bad-lisp-objectp (realpart x) deceased-packages) (bad-lisp-objectp (imagpart x) deceased-packages))) ((typep x 'ratio) (or (bad-lisp-objectp (numerator x) deceased-packages) (bad-lisp-objectp (denominator x) deceased-packages))) ((characterp x) (cond ((legal-acl2-character-p x) nil) (t (cons "The only legal character objects in Acl2 are ~ the CLTL standard characters, plus #\\Page, ~ #\\Tab, and #\\Rubout. The object CLTL ~ displays as ~s0 is therefore illegal." (list (cons #\0 (format nil "~s" x))))))) ((stringp x) (cond ((not (simple-string-p x)) (cons "The strings of Acl2 must be simple strings, but ~p0 ~ is not simple." (list (cons #\0 x)))) (t (do ((i 0 (1+ i))) ((= i (length x))) (declare (fixnum i)) (or (standard-char-p (char (the string x) i)) (return (cons "The strings and symbols of Acl2 may ~ contain only the CLTL standard characters. ~ The object CLTL displays as ~s0 is not ~ one of those." (list (cons #\0 (format nil "~s" (char x i))))))))))) ((symbolp x) (cond ((eq x nil) nil) ((bad-lisp-objectp (symbol-name x) deceased-packages)) ((null (symbol-package x)) (cons "Uninterned symbols such as the one CLTL displays as ~ ~s0 are not allowed in Acl2." (list (cons #\0 (format nil "~s" x))))) ((not (assoc-equal (package-name (symbol-package x)) (known-package-alist *the-live-state*))) (cons "The symbol CLTL displays as ~s0 is not in ~ any of the packages known to Acl2." (list (cons #\0 (format nil "~s" x))))) ((member-equal (package-name (symbol-package x)) deceased-packages) (cons "The symbol CLTL displays as ~s0 would not be in ~ any of the packages that would be known to Acl2 after ~ we removed the package ~s1." (list (cons #\0 (format nil "~s" x)) (cons #\1 (package-name (symbol-package x)))))) ((not (eq x (intern (symbol-name x) (symbol-package x)))) (cons "The symbol ~p0 fails to satisfy the property that ~ it be eq to the result of interning its symbol-name ~ in its symbol package. Such a symbol is illegal in ~ Acl2." (list (cons #\0 (format nil "~s" x))))) (t nil))) ((consp x) (or (bad-lisp-objectp (car x) deceased-packages) (bad-lisp-objectp (cdr x) deceased-packages))) (t (cons "Acl2 permits only objects constructed from rationals, ~ complex rationals, the standard characters of CLTL (plus ~ #\\Page, #\\Tab, and #\\Rubout), simple strings of ~ standard characters, symbols constructed from such ~ strings and interned in the Acl2 packages, and cons ~ trees of such objects. The object CLTL displays as ~s0 ~ is thus illegal in Acl2." (list (cons #\0 (format nil "~s" x))))))) #-acl2-logic-only (defun chk-bad-lisp-object (x deceased-packages) (let ((msg (bad-lisp-objectp x deceased-packages))) (cond (msg (interface-er "~@0" msg)) (t nil)))) (defmacro assign (x y) ":Doc-Section Other assign to a global variable in STATE~/ Example: (assign a (aset1 'ascii-map-array (@ a) 66 'Upper-case-B))~/ General Form: (assign symbol term) where symbol is any symbol (with certain enforced exclusions to avoid overwriting Acl2 system ``globals'') and term is any Acl2 term that could be evaluated at the top-level. Assign evaluates the term, stores the result as the value of the given symbol in the global-table of STATE, and returns the result. Assign is a macro that effectively expands to the more complicated but understandable: (PPROGN (F-PUT-GLOBAL 'symbol term STATE) (MV NIL (F-GET-GLOBAL 'symbol term STATE) STATE)). The macro @ gives convenient access to the value of such globals. The :UBT operation has no effect on the global-table of STATE. Thus, you may use these globals to hang onto useful data structures even though you may undo back past where you computed and saved them.~/" (declare (type symbol x)) `(pprogn (f-put-global ',x ,y state) (mv nil (f-get-global ',x state) state))) (defmacro @ (x) ":Doc-Section Other get the value of a global variable in STATE~/ Example: (assign a (aset1 'ascii-map-array (@ a) 66 'Upper-case-B))~/ General Form: (@ symbol) where symbol is any symbol to which you have ASSIGNed a global value. This macro expands into (F-GET-GLOBAL 'symbol STATE), which retrieves the stored value of the symbol. The macro ASSIGN makes it convenient to set the value of a symbol. The :UBT operation has no effect on the global-table of STATE. Thus, you may use these globals to hang onto useful data structures even though you may undo back past where you computed and saved them.~/" (declare (type symbol x)) `(f-get-global ',x state)) #-acl2-logic-only (defparameter *wormhole-outputs* nil) ;;; We don't want to pull in LD-FN from ld.lisp on the toothbrush, so ;;; we will comment out wormhole1 and wormhole. #| (defun wormhole1 (name input form ld-specials) ; Here is the world's fanciest no-op. #+acl2-logic-only (declare (ignore name input form ld-specials)) #+acl2-logic-only nil #-acl2-logic-only (let ((*wormholep* t) (state *the-live-state*) (*wormhole-cleanup-form* ; WARNING: THIS MUST BE A NEW CONS. (list 'progn `(setq *wormhole-outputs* (put-assoc-equal ',name (f-get-global 'wormhole-output *the-live-state*) *wormhole-outputs*))))) (cond ((null name) (return-from wormhole1 nil))) (push (cons "Post-hoc unwind-protect for wormhole" (list 'lambda nil *wormhole-cleanup-form*)) (car *acl2-unwind-protect-stack*)) ; The f-put-globals about to be performed will be done undoably. (f-put-global 'wormhole-name name state) (f-put-global 'wormhole-input input state) (f-put-global 'wormhole-output (cdr (assoc-equal name *wormhole-outputs*)) state) (ld-fn (append `((standard-oi . (,form . ,*standard-oi*)) (standard-co . ,*standard-co*) (proofs-co . ,*standard-co*)) ld-specials) state t) (eval *wormhole-cleanup-form*) (pop (car *acl2-unwind-protect-stack*)) nil)) (defmacro wormhole (pseudo-flg name input form &key (current-package 'same current-packagep) (ld-skip-proofsp 'same ld-skip-proofspp) (ld-redefinition-action 'save ld-redefinition-actionp) (ld-prompt ''wormhole-prompt) (ld-keyword-aliases 'same ld-keyword-aliasesp) (ld-pre-eval-filter 'same ld-pre-eval-filterp) (ld-pre-eval-print 'same ld-pre-eval-printp) (ld-post-eval-print 'same ld-post-eval-printp) (ld-evisc-tuple 'same ld-evisc-tuplep) (ld-error-triples 'same ld-error-triplesp) (ld-error-action 'same ld-error-actionp) (ld-query-control-alist 'same ld-query-control-alistp) (ld-verbose 'same ld-verbosep)) ":Doc-Section Miscellaneous LD without STATE -- a short-cut to a parallel universe~/ Example Form: (wormhole t 'interactive-break nil '(value 'hi!)) ; Enters a recursive read-eval-print loop ; on a copy of the ``current state'' and ; returns nil!~/ General Form: (wormhole pseudo-flg name input form :ld-skip-proofsp ... ; t, nil or 'include-book :ld-redefinition-action ; nil or '(:a . :b) :ld-prompt ... ; nil, t, or some prompt printer fn :ld-keyword-aliases ... ; an alist pairing keywords to parse info :ld-pre-eval-filter ... ; :all, :query, or some new name :ld-pre-eval-print ... ; nil or t :ld-post-eval-print ... ; nil, t, or :command-conventions :ld-evisc-tuple ... ; nil or '(alist nil nil level length) :ld-error-triples ... ; nil or t :ld-error-action ... ; :continue, :return, or :error :ld-query-control-alist ; alist supplying default responses :ld-verbose ...) ; nil or t The keyword arguments above are exactly those of LD (see :DOC ld) except that three of LD's keyword arguments are missing: the three that specify the channels standard-oi, standard-co and proofs-co. Essentially wormhole is just a call of LD on the current state with the given keyword arguments. Wormhole always returns nil. The AMAZING thing about wormhole is that it calls LD and interacts with the user even though STATE is not available as an argument! Wormhole does this by manufacturing a ``wormhole state,'' a copy of the ``current state'' (whatever that is) modified so as to contain some of the wormhole arguments. LD is called on that wormhole state with the three LD channels directed to Acl2's ``comment window.'' At the moment, the comment window is overlaid on the terminal and you cannot tell when output is going to *standard-co* and when it is going to the comment window. But we imagine that eventually a different window will pop up on your screen. In any case, the interaction provided by this call of LD does not modify the state ``from which'' wormhole was called, it modifies the copied state. When LD exits (i.e., in response to :Q being typed in the comment window) the wormhole state evaporates and wormhole returns nil. Logically and actually (from the perspective of the ongoing computation) nothing has happened except that a no-op function was called and returned nil. The name wormhole is meant to suggest the idea that the function provides easy access to state in situations where it is apparently impossible to get state. Thus, for example, if you define the factorial function, say, except that you sprinkled into its body appropriate calls of wormhole, then the execution of (factorial 6) would cause interactive breaks in the comment window. During those breaks you would apparently be able to inspect the ``current state'' even though factorial does not take STATE as an argument. The whole notion of there being a ``current state'' during the evaluation of (factorial 6) is logically ill-defined. And yet, we know from practical experience with the sequential computing machines upon which Acl2 is implemented that there is a ``current state'' (to which the factorial function is entirely insensitive) and that is the state to which wormhole ``tunnels.'' A call of wormhole from within factorial can pass factorial- specific information which is embedded in the wormhole state and made available for inspection by the user in an interactive setting. But no information ever flows out of a wormhole state: wormholes always return nil. There are four arguments to wormhole that need further explanation: pseudo-flg, name, input, and form. Roughly speaking, the value of pseudo-flg should be t or nil and indicates whether we are actually to enter a wormhole or just return nil immediately. The actual handling of pseudo-flg is more sophisticated and is explained in detail at the end of this documentation. Name and input are used as follows. Recall that wormhole copies the ``current state'' and then modifies it slightly to obtain the state upon which LD is called. We now describe the modifications. First, the state global variable 'wormhole-name is set to name, which may be any non-nil Acl2 object but is usually a symbol. Then, 'wormhole-input is set to input, which may be any Acl2 object. Finally, and inexplicably, 'wormhole-output is set to the value of 'wormhole-output the last time a wormhole named name was exited (or nil if this is the first time a wormhole named name was entered). This last aspect of wormholes, namely the preservation of 'wormhole-output, allows all the wormholes of a given name to communicate with eachother. We can now explain how form is used. The modified state described above is the state on which LD is called. However, standard-oi -- the input channel from which LD reads commands -- is set so that the first command that LD reads and evaluates is form. If form returns an error triple with value :Q, i.e., form returns via (value :q), then no further commands are read, LD exits, and the wormhole exits and returns nil. But if form returns any other value (or is not an error triple), then subsequent commands are read from the comment window. As usual, the LD-specials affect whether a herald is printed upon entry, whether form is printed before evaluation, whether a prompt is printed, how errors are handled, etc. The LD-specials can be specified with the corresponding arguments to wormhole. It is standard practice to call wormhole so that the entry to LD and the evaluation of form is totally silent. Then, tests in form can inspect the state and decide whether user interaction is desired. If so, form can appropriately set LD-PROMPT, LD-ERROR-ACTION, etc., print a herald, and then return (value :invisible). Recall from :DOC ld that (value :invisible) causes LD not to print a value for the just executed form. The result of this arrangement is that whether interaction occurs can be based on tests that are performed on the wormhole state after (@ wormhole-input) and the last (@ wormhole-output) are available for inspection. This is important because outside the wormhole you can access wormhole-input (you are passing it into the wormhole) but you may not be able to access the current state (because you might be in factorial) and you definitely cannot access the wormhole-output of the last wormhole because it is not part of the Acl2 state. Thus, if the condition under which you wish to interact depends upon the state or that part of it preserved from the last wormhole interaction, that condition can only be tested from within the wormhole, via form. It is via this mechanism that break-rewrite (see :DOC break-rewrite) is implemented. To be more precise, the list of monitored runes is maintained as part of the preserved wormhole-output of the break-rewrite wormhole. Because it is not part of the normal state, it may be changed by the user during proofs. That is what allows you to install new monitors while debugging proofs. But that means that the list of monitored runes cannot be inspected from outside the wormhole. Therefore, to decide whether a break is to occur when a given rule is applied, the rewriter must enter the break-rewrite wormhole, supplying a form that causes interaction if the given rule's break condition is satisfied. The user perceives this as though the wormhole was conditionally entered -- a perception that is happily at odds which the informed user's knowledge that the list of monitored runes is not part of the state. In fact, the wormhole was unconditionally entered and the condition was checked from within the wormhole, that being the only state in which the condition is known. Another illustrative example is available in the implemention of the monitor command. How can we add a new rune to the list of monitored runes while in the normal Acl2 state (i.e., while not in a wormhole)? The answer is: by getting into a wormhole. In particular, when you type (monitor rune expr) at the top-level of Acl2, monitor enters the break-rewrite wormhole with a cleverly designed first form. That form adds rune and expr to the list of monitored runes -- said list only being available in break-rewrite wormhole states. Then the first form returns (value :q) which causes us to exit the wormhole. By using LD-specials that completely suppress all output during the process, it does not appear to the user that a wormhole was entered. The moral here is rather subtle: the first form supplied to wormhole may be the entire computation you want to perform in the wormhole; it need not just be a predicate that decides if interaction is to occur. Using wormholes of different names you can maintain a variety of ``hidden'' data structures that are always accessible (whether passed in or not). This appears to violate completely the applicative semantics of Acl2, but it does not: because these data structures are only accessible via wormholes, it is impossible for them to affect any Acl2 computation (except in the comment window). As one might imagine, there is some overhead associated with entering a wormhole because of the need to copy the current state. This brings us back to pseudo-flg. Ostensibly, wormhole is a function and hence all of its argument expressions are evaluated outside the function (and hence, outside the wormhole it creates) and then their values are passed into the function where an appropriate wormhole is created. In fact, wormhole is a macro that permits the pseudo-flg expression to peer dimly into the wormhole that will be created before it is created. In particular, pseudo-flg allows the user to access the wormhole-output that will be used to create the wormhole state. This is done by allowing the user to mention the (apparently unbound) variable wormhole-output in the first argument to wormhole. Logically, wormhole is a macro that wraps (let ((wormhole-ouptut nil)) ...) around the expression supplied as its first argument. So logically, wormhole-output is always nil when the expression is evaluated. However, actually, wormhole-output is bound to the value of (@ wormhole-output) on the last exit from a wormhole of the given name (or nil if this is the first entrance). Thus, the pseudo-flg expression, while having to handle the possibility that wormhole-output is nil, will sometimes see non-nil values. The next question is, of course, ``But how can you get away with saying that logically wormhole-output is always nil but actually it is not? That doesn't appear to be sound.'' But it is sound because whether pseudo-flg evaluates to nil or non-nil doesn't matter, since in either case wormhole returns nil. To make that point slightly more formal, imagine that wormhole did not take pseudo-flg as an argument. Then it could be implemented by writing (if pseudo-flg (wormhole name input form ...) nil). Now since wormhole always returns nil, this expression is equivalent to (if pseudo-flg nil nil) and we see that the value of pseudo-flg is irrelevant. So we could in fact allow the user to access arbitrary information to decide which branch of this if to take. We allow access to wormhole-output because it is often all that is needed. We don't allow access to state (unless state is available at the level of the wormhole call) for technical reasons having to do with the difficulty of overcoming translate's prohibition of the sudden appearance of the variable STATE. We conclude with an example of the use of pseudo-flg. This example is a simplification of our implementation of break-rewrite. To enter break-rewrite at the beginning of the attempted application of a rule, rule, we use (wormhole (and (f-get-global 'brr-mode STATE) (member-equal (access rewrite-rule rule :rune) (cdr (assoc-eq 'monitored-runes WORMHOLE-OUTPUT)))) 'break-rewrite ...) The function in which this call of wormhole occurs has STATE as a formal. The pseudo-flg expression can therefore refer to STATE to determine whether 'brr-mode is set. But the pseudo-flg expression above mentions the variable WORMHOLE-OUTPUT; this variable is not bound in the context of the call of wormhole; if wormhole were a simple function symbol, this expression would be illegal because it mentions a free variable. However, it is useful to think of wormhole as a simple function that evaluates all of its arguments but to also imagine that somehow WORMHOLE-OUTPUT is magically bound around the first argument so that WORMHOLE-OUTPUT is the output of the last break-rewrite wormhole. If we so imagine, then the pseudo-flg expression above evaluates either to nil or non-nil and we will enter the wormhole named break-rewrite in the latter case. Now what does the pseudo-flg expression above actually test? We know the format of our own wormhole-output because we are responsible for maintaining it. In particular, we know that the list of monitored runes can be obtained via (cdr (assoc-eq 'monitored-runes wormhole-output)). Using that knowledge we can design a pseudo-flg expression which tests whether (a) we are in brr-mode and (b) the rune of the current rule is a member of the monitored runes. Question (a) is answered by looking into the current state. Question (b) is answered by looking into that part of the about-to-be-created wormhole state that will differ from the current state. To reiterate the reason we can make wormhole-output available here even though it is not in the current state: logically speaking the value of wormhole-output is irrelevant because it is only used to choose between two identical alternatives. This example also makes it clear that pseudo-flg provides no additional functionality. The test made in the pseudo-flg expression could be moved into the first form evaluated by the wormhole -- changing the free variable wormhole-output to (@ wormhole-output) and arranging for the first form to return (value :q) when the pseudo-flg expression returns nil. The only reason we provide the pseudo-flg feature is because it allows the test to be carried out without the overhead of entering the wormhole." `(let ((wormhole-name ,name)) (cond ((let ((wormhole-output #+acl2-logic-only nil #-acl2-logic-only (cdr (assoc-equal wormhole-name *wormhole-outputs*)))) (prog2$ wormhole-output (check-vars-not-free (wormhole-name) ,pseudo-flg))) (wormhole1 wormhole-name (check-vars-not-free (wormhole-name) ,input) (check-vars-not-free (wormhole-name) ,form) (check-vars-not-free (wormhole-name) (list ,@(append (if current-packagep (list `(cons 'current-package ,current-package)) nil) (if ld-skip-proofspp (lis