;;; compiled by jimb@wookumz.gnu.ai.mit.edu on Tue Jul 21 01:27:11 1992 ;;; from file /home/gd/gnu/emacs-18.58/lisp/cl.el ;;; emacs version 18.58.1. ;;; bytecomp version 2.01 beta; 13-aug-91. ;;; optimization is on; compiled with emacs18 compatibility. (provide (quote cl)) (defmacro psetq (&rest pairs) "\ (psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE. All the VALUEs are evaluated, and then all the VARIABLEs are set. Aside from order of evaluation, this is the same as `setq'." (byte-code "G\"U !V@9<!\"BA@BAA**@ D B BAe+ ! @@ BBAA* BF." [pairs nil i assignments newsyms bindings forms symbols nforms % 2 0 error "Odd number of arguments to `psetq'" var ptr "`psetq' expected a symbol, found '%s'." prin1-to-string newsym form gensym nreverse ptr2 ptr1 let setq] 8)) (defun pair-with-newsyms (oldforms) "\ PAIR-WITH-NEWSYMS OLDFORMS The top-level components of the list oldforms are paired with fresh symbols, the pairings list and the newsyms list are returned." (byte-code " !'  @D B\nB) A) !\n!\"+" [oldforms nil newsyms bindings ptr endp gentemp newsym G$$_500 values nreverse] 5)) (defun zip-lists (evens odds) "\ Merge two lists EVENS and ODDS, taking elts from each list alternatingly. EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose even numbered elements (0,2,...) come from EVENS and whose odd numbered elements (1,3,...) come from ODDS. The construction stops when the shorter list is exhausted." (byte-code "\n @ @ !0 !0 BB A A @ @ !-" [evens p0 odds p1 even odd nil result endp nreverse] 3)) (defun unzip-list (list) "\ Extract even and odd elements of LIST into two separate lists. The argument LIST is separated in two strands, the even and the odd numbered elements. Numbering starts with 0, so the first element belongs in EVENS. No check is made that there is an even number of elements to start with." (byte-code "@ ! !/\nB B !@ !!!\"-" [list ptr this cadr next nil evens odds endp cddr values nreverse] 5)) (defun reassemble-argslists (argslists) "\ (reassemble-argslists ARGSLISTS). ARGSLISTS is a list of sequences. Return a list of lists, the first sublist being all the entries coming from ELT 0 of the original sublists, the next those coming from ELT 1 and so on, until the shortest list is exhausted." (byte-code " \"\" \nY+ \"B\n\\\n!," [apply min mapcar length argslists minlen nil result T$$_0 0 i (lambda (sublist) (byte-code " \n\"" [elt sublist i] 3)) 1 nreverse] 6)) (defun build-klist (argslist acceptable) "\ Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE. ARGSLIST is a list, presumably the &rest argument of a call, whose even numbered elements must be keywords. ACCEPTABLE is a list of keywords, the only ones that are truly acceptable. The result is an alist containing the arguments named by the keywords in ACCEPTABLE, or nil if something failed." (byte-code "< G!! < \" !  !L 9!F  JC!)A@@\"c!\"\" @!\"BA@x." [argslist evenp error "Odd number of keyword-args" acceptable every keywordp "Second arg should be a list of keywords" nil *mvalues-count* gensym it unzip-list copy-sequence *mvalues-values* 1 T$$_1 forms keywords "Expected keywords, found `%s'" prin1-to-string pairlis auxlist ptr this auxval alist endp assoc] 5)) (defun duplicate-symbols-p (list) "\ Find all symbols appearing more than once in LIST. Return a list of all such duplicates; `nil' if there are no duplicates." (byte-code "  < \"! \" \" \" *" [nil gensym propname duplicates list every symbolp error "A list of symbols is needed" mapcar (lambda (x) (byte-code " \n#" [put x propname 0] 4)) (lambda (x) (byte-code " \n \nNT#" [put x propname] 5)) (lambda (x) (byte-code " NV  B" [x propname 1 duplicates] 2))] 3)) (defmacro defkeyword (x &optional docstring) "\ Make symbol X a keyword (symbol whose value is itself). Optional second argument is a documentation string for it." (byte-code "9 DE!\"" [x defconst quote error "`%s' is not a symbol" prin1-to-string] 4)) (defun keywordp (sym) "\ Return `t' if SYM is a keyword." (byte-code "9!H\"LŇ" [sym char-equal symbol-name 0 58 nil] 3)) (defun keyword-of (sym) "\ Return a keyword that is naturally associated with symbol SYM. If SYM is keyword, the value is SYM. Otherwise it is a keyword whose name is `:' followed by SYM's name." (byte-code " ! 9 !P!L) !\"" [keywordp sym intern ":" symbol-name newsym error "Expected a symbol, not `%s'" prin1-to-string] 5)) (defvar *gentemp-index* 0 "\ Integer used by gentemp to produce new names.") (defvar *gentemp-prefix* "T$$_" "\ Names generated by gentemp begin with this string by default.") (defun gentemp (&optional prefix oblist) "\ Generate a fresh interned symbol. There are 2 optional arguments, PREFIX and OBLIST. PREFIX is the string that begins the new name, OBLIST is the obarray used to search for old names. The defaults are just right, YOU SHOULD NEVER NEED THESE ARGUMENTS IN YOUR OWN CODE." (byte-code " \n ĉ2P\\ \n\" \n\"*" [prefix *gentemp-prefix* oblist obarray nil newname newsymbol *gentemp-index* 1 intern-soft intern] 4)) (defvar *gensym-index* 0 "\ Integer used by gensym to produce new names.") (defvar *gensym-prefix* "G$$_" "\ Names generated by gensym begin with this string by default.") (defun gensym (&optional prefix) "\ Generate a fresh uninterned symbol. There is an optional argument, PREFIX. PREFIX is the string that begins the new name. Most people take just the default, except when debugging needs suggest otherwise." (byte-code "  'P\\ !\n ! *" [prefix *gensym-prefix* nil "" newname newsymbol *gensym-index* 1 intern-soft make-symbol] 3)) (byte-code "####" [put case lisp-indent-hook 1 ecase when unless] 4) (defmacro when (condition &rest body) "\ (when CONDITION . BODY) => evaluate BODY if CONDITION is true." (byte-code " D $" [list* if not condition nil body] 5)) (defmacro unless (condition &rest body) "\ (unless CONDITION . BODY) => evaluate BODY if CONDITION is false." (byte-code "\n $" [list* if condition nil body] 5)) (defmacro case (expr &rest cases) "\ (case EXPR . CASES) => evals EXPR, chooses from CASES on that value. EXPR -> any form CASES -> list of clauses, non empty CLAUSE -> HEAD . BODY HEAD -> t = catch all, must be last clause -> otherwise = same as t -> nil = illegal -> atom = activated if (eql EXPR HEAD) -> list of atoms = activated if (member EXPR HEAD) BODY -> list of forms, implicit PROGN is built around it. EXPR is evaluated only once." (byte-code "  \" DC !\"E*" [gentemp newsym case-clausify cases clauses let expr list* cond nreverse] 6)) (defmacro ecase (expr &rest cases) "\ (ecase EXPR . CASES) => like `case', but error if no case fits. `t'-clauses are not allowed." (byte-code "  \" !=! D DFD B  DC !\"E*" [gentemp newsym case-clausify cases clauses caar t error "No clause-head should be `t' or `otherwise' for `ecase'" "ecase on %s = %s failed to take any branch." quote expr prin1-to-string let list* cond nreverse] 6)) (defun case-clausify (cases newsym) "\ CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond' Converts the CASES of a [e]case macro into cond clauses to be evaluated inside a let that binds NEWSYM. Returns the clauses in reverse order." (byte-code "A@ ! @ A& !\"~=4=H\n!>!B B~:_DEB B~ an s-expr FORMS is the stepforms part of a DO macro (q.v.). This function constructs an s-expression that does the stepping at the end of an iteration." (byte-code "\n!BC" [psetq select-stepping-forms forms] 3)) (defun extract-do*-steps (forms) "\ EXTRACT-DO*-STEPS FORMS => an s-expr FORMS is the stepforms part of a DO* macro (q.v.). This function constructs an s-expression that does the stepping at the end of an iteration." (byte-code "\n!BC" [setq select-stepping-forms forms] 3)) (defun select-stepping-forms (forms) "\ Separate only the forms that cause stepping." (byte-code "  * @<#\nGU#\n!\n@D \" A\n !+" [nil forms entry ptr result 3 append caddr nreverse] 4)) (defmacro dolist (stepform &rest body) "\ (dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST. The RESULTFORM defaults to nil. The VAR is bound to successive elements of the value of LIST and remains bound (to the nil value) when the RESULTFORM is evaluated." (byte-code "<!\".@9 @!\".GV.!\"@! ! CBBD EDC EE+" [stepform error "Stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'" prin1-to-string "First component of stepform should be a symbol, not `%s'" 3 "Too many components in stepform `%s'" var cadr listform caddr resultform progn mapcar function lambda body let nil] 6)) (defmacro dotimes (stepform &rest body) "\ (dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR. The COUNTFORM should return a positive integer. The VAR is bound to successive integers from 0 to COUNTFORM-1 and the BODY is repeated for each of them. At the end, the RESULTFORM is evaluated and its value returned. During this last evaluation, the VAR is still bound, and its value is the number of times the iteration occurred. An omitted RESULTFORM defaults to nil." (byte-code "<!\".@9 @!\".GV.!\"@! !    DCEEC E D$E," [stepform error "Stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'" prin1-to-string "First component of stepform should be a symbol, not `%s'" 3 "Too many components in stepform `%s'" var cadr countform caddr resultform gentemp newsym let* list* do* 0 + 1 >= body] 9)) (defmacro do-symbols (stepform &rest body) "\ (do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY) The VAR is bound to each of the symbols in OBARRAY (def. obarray) and the BODY is repeatedly performed for each of those bindings. At the end, RESULTFORM (def. nil) is evaluated and its value returned. During this last evaluation, the VAR is still bound and its value is nil. See also the function `mapatoms'." (byte-code "<!\".@9 @!\".GV.!\"@! ! CBBD EDC EE+" [stepform error "Stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'" prin1-to-string "First component of stepform should be a symbol, not `%s'" 3 "Too many components in stepform `%s'" var cadr oblist caddr resultform progn mapatoms function lambda body let nil] 6)) (defmacro do-all-symbols (stepform &rest body) "\ (do-all-symbols (VAR [RESULTFORM]) . BODY) Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)." (byte-code "\n@\n!E #" [list* do-symbols stepform obarray cadr body] 6)) (defmacro loop (&rest body) "\ (loop . BODY) repeats BODY indefinitely and does not return. Normally BODY uses `throw' or `signal' to cause an exit. The forms in BODY should be lists, as non-lists are reserved for new features." (byte-code "< !\"BB" [body error "Body of `loop' should be a list of lists or nil" mapcar (lambda (component) (byte-code " NEWVAL As a side effect, sets the Nth cdr of LIST to NEWVAL." (byte-code "W \"U\" @\" A\"Z \"\"" [n 0 error "N must be 0 or greater, not %d" rplaca list newval rplacd nthcdr 1] 4)) (defun acons (key item alist) "\ Return a new alist with KEY paired with ITEM; otherwise like ALIST. Does not copy ALIST." (byte-code " B\nB" [key item alist] 2)) (defun pairlis (keys data &optional alist) "\ Return a new alist with each elt of KEYS paired with an elt of DATA; optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must have the same length." (byte-code "G GU !  @ @ != # A A @ @ -" [keys data error "Keys and data should be the same length" kptr dptr key item alist result endp acons] 4)) (byte-code " \n " [:test :test-not :key :predicate :start :end :start1 :start2 :end1 :end2 :count :from-end] 1) (defun some (pred seq &rest moreseqs) "\ Test PREDICATE on each element of SEQUENCE; is it ever non-nil? Extra args are additional sequences; PREDICATE gets one arg from each sequence and we advance down all the sequences together in lock-step. A sequence means either a list or a vector." (byte-code "\n \"!  @\nB !B \n\"6 A @\n." [reassemble-argslists list* seq moreseqs args nil ready result applyval remaining current endp apply pred t] 5)) (defun every (pred seq &rest moreseqs) "\ Test PREDICATE on each element of SEQUENCE; is it always non-nil? Extra args are additional sequences; PREDICATE gets one arg from each sequence and we advance down all the sequences together in lock-step. A sequence means either a list or a vector." (byte-code "\n \"! \n@ A\n!A \" 5\nA\n@ ." [reassemble-argslists list* seq moreseqs args nil ready t result applyval remaining current endp apply pred] 5)) (defun notany (pred seq &rest moreseqs) "\ Test PREDICATE on each element of SEQUENCE; is it always nil? Extra args are additional sequences; PREDICATE gets one arg from each sequence and we advance down all the sequences together in lock-step. A sequence means either a list or a vector." (byte-code "\n \"! \n@ A\n!A \" 5\nA\n@ ." [reassemble-argslists list* seq moreseqs args nil ready t result applyval remaining current endp apply pred] 5)) (defun notevery (pred seq &rest moreseqs) "\ Test PREDICATE on each element of SEQUENCE; is it sometimes nil? Extra args are additional sequences; PREDICATE gets one arg from each sequence and we advance down all the sequences together in lock-step. A sequence means either a list or a vector." (byte-code "\n \"!  @\nA !A \n\"5 A @\n." [reassemble-argslists list* seq moreseqs args nil ready result applyval remaining current endp apply pred t] 5)) (defun setelt (seq n newval) "\ In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL. A sequence means either a list or a vector." (byte-code "G\nW\n Y\n #9<%\n#9!3\nI9!\")" [seq l n 0 error "N(%d) should be between 0 and %d" setnth newval arrayp "SEQ should be a sequence, not `%s'" prin1-to-string] 4)) (defun extract-from-klist (key klist &optional default) "\ EXTRACT-FROM-KLIST KEY KLIST [DEFAULT] => value of KEY or DEFAULT Extract value associated with KEY in KLIST (return DEFAULT if nil)." (byte-code " \n\"A )" [assoc key klist retrieved default] 4)) (defun add-to-klist (key item klist) "\ ADD-TO-KLIST KEY ITEM KLIST => new KLIST Add association (KEY . ITEM) to KLIST." (byte-code " \n #" [acons key item klist] 4)) (defun elt-satisfies-test-p (item elt klist) "\ ELT-SATISFIES-TEST-P ITEM ELT KLIST => t or nil KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. True if the given ITEM and ELT satisfy the test." (byte-code " \n\" \n\" \n#$ \n!\"=7 \n!\"?=\n!\"+" [extract-from-klist :test klist :test-not :key identity keyfn test-not test item elt error "Neither :test nor :test-not in `%s'" prin1-to-string] 7)) (defun elt-satisfies-if-p (item klist) "\ ELT-SATISFIES-IF-P ITEM KLIST => t or nil True if an -if style function was called and ITEM satisfies the predicate under :predicate in KLIST." (byte-code " \n\" \" !\"*" [extract-from-klist :predicate klist :key identity keyfn predicate item elt] 5)) (defun elt-satisfies-if-not-p (item klist) "\ ELT-SATISFIES-IF-NOT-P ITEM KLIST => t or nil KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. True if an -if-not style function was called and ITEM does not satisfy the predicate under :predicate in KLIST." (byte-code " \n\" \" !\"*?" [extract-from-klist :predicate klist :key identity keyfn predicate item elt] 5)) (defun elts-match-under-klist-p (e1 e2 klist) "\ ELTS-MATCH-UNDER-KLIST-P E1 E2 KLIST => t or nil KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL. True if elements E1 and E2 match under the tests encoded in KLIST." (byte-code " \n\" \n\" \n#' !\n!\"C= !\n!\"?C\n!\"+" [extract-from-klist :test klist :test-not :key identity keyfn test-not test e1 e2 error "Neither :test nor :test-not in `%s'" prin1-to-string] 7)) (byte-code "#####" [put multiple-value-bind lisp-indent-hook 2 multiple-value-setq multiple-value-list nil multiple-value-call 1 multiple-value-prog1] 4) (defvar *mvalues-values* nil "\ Most recently returned multiple-values") (defvar *mvalues-count* nil "\ Count of multiple-values returned, or nil if the mechanism was not used") (defun values (&rest val-forms) "\ Produce multiple values (zero or more). Each arg is one value. See also `multiple-value-bind', which is one way to examine the multiple values produced by a form. If the containing form or caller does not check specially to see multiple values, it will see only the first value." (byte-code "G @" [val-forms *mvalues-values* *mvalues-count*] 2)) (defun values-list (&optional val-forms) "\ Produce multiple values (zero or mode). Each element of LIST is one value. This is equivalent to (apply 'values LIST)." (byte-code "< !\"G @" [val-forms error "Argument to values-list must be a list, not `%s'" prin1-to-string *mvalues-values* *mvalues-count*] 5)) (defmacro multiple-value-list (form) "\ Execute FORM and return a list of all the (multiple) values FORM produces. See `values' and `multiple-value-bind'." (byte-code "EDCEDEDDEDFFFE" [progn setq *mvalues-count* nil let it (gensym) set form if copy-sequence *mvalues-values* 1 list symbol-value] 15)) (defmacro multiple-value-call (function &rest args) "\ Call FUNCTION on all the values produced by the remaining arguments. (multiple-value-call '+ (values 1 2) (values 3 4)) is 10." (byte-code "   !D DC\n\nD E \nDDEEEEE*" [gentemp result arg apply function eval let* nil dolist quote args setq append multiple-value-list] 13)) (defmacro multiple-value-bind (vars form &rest body) "\ Bind VARS to the (multiple) values produced by FORM, then do BODY. VARS is a list of variables; each is bound to one of FORM's values. If FORM doesn't make enough values, the extra variables are bound to nil. (Ordinary forms produce only one value; to produce more, use `values'.) Extra values are ignored. BODY (zero or more forms) is executed with the variables bound, then the bindings are unwound." (byte-code "  \" DD B #*" [gentemp vals mv-bind-clausify vars clauses list* let* multiple-value-list form body] 5)) (defmacro multiple-value-setq (vars form) "\ Set VARS to the (multiple) values produced by FORM. VARS is a list of variables; each is set to one of FORM's values. If FORM doesn't make enough values, the extra variables are set to nil. (Ordinary forms produce only one value; to produce more, use `values'.) Extra values are ignored." (byte-code "  \" DDC \"BE*" [gentemp vals mv-bind-clausify vars clauses let* multiple-value-list form setq apply append] 6)) (defmacro multiple-value-prog1 (form &rest body) "\ Evaluate FORM, then BODY, then produce the same values FORM produced. Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2. This is like `prog1' except that `prog1' would produce only one value, which would be the first of FORM's values." (byte-code "  DDC DC\")BB" [gentemp heldvalues let* multiple-value-list form append body values-list] 6)) (defun mv-bind-clausify (vars vals) "\ MV-BIND-CLAUSIFY VARS VALS => Auxiliary list Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to the length of VARS (a list of symbols). VALS is just a fresh symbol." (byte-code "< \"!\"G   YB 8  EDB \\ \"," [vars notevery symbolp error "Expected a list of symbols, not `%s'" prin1-to-string nvars nil clauses T$$_4 0 n nth vals 1] 5)) (defun plusp (number) "\ True if NUMBER is strictly greater than zero." (byte-code "V" [number 0] 2)) (defun minusp (number) "\ True if NUMBER is strictly less than zero." (byte-code "W" [number 0] 2)) (defun oddp (number) "\ True if INTEGER is not divisible by 2." (byte-code " \"U?" [% number 2 0] 3)) (defun evenp (number) "\ True if INTEGER is divisible by 2." (byte-code " \"U" [% number 2 0] 3)) (defun abs (number) "\ Return the absolute value of NUMBER." (byte-code "W [" [number 0] 2)) (defun signum (number) "\ Return -1, 0 or 1 according to the sign of NUMBER." (byte-code "W‡VÇ" [number 0 -1 1] 2)) (defun gcd (&rest integers) "\ Return the greatest common divisor of all the arguments. The arguments must be integers. With no arguments, value is zero." (byte-code "GU ‚ U@! V1lj@A@\"AAB\"@A@\"UA!@! A@!   ]   ^ \" \"Uh h.)" [integers howmany 0 1 abs 2 apply gcd * error "A zero argument is invalid for `gcd'" absa absb dd ds q r nil done result / % t] 6)) (defun lcm (integer &rest more) "\ Return the least common multiple of all the arguments. The arguments must be integers and there must be at least one of them." (byte-code "G @AU!JV0̉ \" B\"J \"U@ȂJ ! \"\"-" [more integer nil yetmore prod b a howmany 0 abs 1 apply lcm * / gcd] 6)) (defun isqrt (number) "\ Return the integer square root of NUMBER. NUMBER must not be negative. Result is largest integer less than or equal to the real square root of the argument." (byte-code " !\n! Uć XƇ \"    Z  \"  \" \"YEƂF\\\\\"   =   & \" Vk Zm +" [minusp number error "Argument to `isqrt' must not be negative" 0 3 1 / 2 approx nil done iter % *] 7)) (defun floor (number &optional divisor) "\ Divide DIVIDEND by DIVISOR, rounding toward minus infinity. DIVISOR defaults to 1. The remainder is produced as a second value." (byte-code "\n!\n\" \n\"L) !6JC  !)  8 A@ @UXĉ\"!h\"U\\[\n\"Z\"," [divisor numberp number values 0 nil *mvalues-count* gensym it safe-idiv copy-sequence *mvalues-values* 1 T$$_5 2 s r q plusp *] 5)) (defun ceiling (number &optional divisor) "\ Divide DIVIDEND by DIVISOR, rounding toward plus infinity. DIVISOR defaults to 1. The remainder is produced as a second value." (byte-code "\n!\n\" \n\"L) !6JC  !)  8 A@ @UXĉ\"!h\"U~\\\n\"Z\"," [divisor numberp number values 0 nil *mvalues-count* gensym it safe-idiv copy-sequence *mvalues-values* 1 T$$_8 2 s r q minusp *] 5)) (defun truncate (number &optional divisor) "\ Divide DIVIDEND by DIVISOR, rounding toward zero. DIVISOR defaults to 1. The remainder is produced as a second value." (byte-code "\n!\n\" \n\"L) !6JC  !)  8 A@ @UXĉ\"!h\"U}[\n\"Z\"," [divisor numberp number values 0 nil *mvalues-count* gensym it safe-idiv copy-sequence *mvalues-values* 1 T$$_11 2 s r q plusp *] 5)) (defun round (number &optional divisor) "\ Divide DIVIDEND by DIVISOR, rounding to nearest integer. DIVISOR defaults to 1. The remainder is produced as a second value." (byte-code "\n!\n\" \n\"L) !6JC  !)  8 A@ @!!ZVi\\~U~!~\\\"\n\"Z\"-" [divisor numberp number values 0 nil *mvalues-count* gensym it safe-idiv copy-sequence *mvalues-values* 1 T$$_14 2 s r q abs other-r oddp *] 5)) (defun mod (number divisor) "\ Return remainder of X by Y (rounding quotient toward minus infinity). That is, the remainder goes with the quotient produced by `floor'." (byte-code "  \"L !# JC!)\nA@ \n@  +" [nil *mvalues-count* gensym it floor number divisor copy-sequence *mvalues-values* 1 T$$_17 r q] 5)) (defun rem (number divisor) "\ Return remainder of X by Y (rounding quotient toward zero). That is, the remainder goes with the quotient produced by `truncate'." (byte-code "  \"L !# JC!)\nA@ \n@  +" [nil *mvalues-count* gensym it truncate number divisor copy-sequence *mvalues-values* 1 T$$_20 r q] 5)) (defun safe-idiv (a b) "\ SAFE-IDIV A B => Q R S Q=|A|/|B|, R is the rest, S is the sign of A/B." (byte-code " ! \n!!\nU \" !\n!  \" !\n!\" ̉ \"\n\"Z #-" [numberp a b error "Arguments to `safe-idiv' must be numbers" 0 "Cannot divide %d by zero" abs absa absb / q * signum s r values] 5)) (byte-code "" [:setf-update-fn :setf-update-doc] 1) (defmacro setf (&rest pairs) "\ Generalized `setq' that can set things other than variable values. A use of `setf' looks like (setf {PLACE VALUE}...). The behavior of (setf PLACE VALUE) is to access the generalized variable at PLACE and store VALUE there. It returns VALUE. If there is more than one PLACE and VALUE, each PLACE is set from its VALUE before the next PLACE is evaluated." (byte-code "G \"U!2 Uǂ2 Va @\n !   !X\n E B  ! @\n ! 3 !,B2@\n! \n9\n E1\n<*\n@*9*N*:@=9!K!:@=)\nA C\"B1 \nA C\"!L !JC  !)\"A@#\"@$$#BE+1\n!\",)" [pairs nforms % 2 0 error "Odd number of arguments to `setf'" nil progn args place cadr value result endp setf cddr nreverse head updatefn setq :setf-update-fn lambda fboundp defn subrp append *mvalues-count* gensym it pair-with-newsyms copy-sequence *mvalues-values* 1 T$$_23 newsyms bindings let "No `setf' update-function for `%s'" prin1-to-string] 6)) (defmacro defsetf (accessfn updatefn &optional docstring) "\ Define how `setf' works on a certain kind of generalized variable. A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]). ACCESSFN is a symbol. UPDATEFN is a function or macro which takes one more argument than ACCESSFN does. DEFSETF defines the translation of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL). The function UPDATEFN must return its last arg, after performing the updating called for." (byte-code "9 !\" ##" [accessfn error "First argument of `defsetf' must be a symbol, not `%s'" prin1-to-string put :setf-update-fn updatefn :setf-update-doc docstring] 4)) (defmacro incf (ref &optional delta) "\ (incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)" (byte-code " EE" [delta 1 setf ref +] 5)) (defmacro decf (ref &optional delta) "\ (decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)" (byte-code " EE" [delta 1 setf ref -] 5)) (defmacro push (item ref) "\ (push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)" (byte-code " EE" [setf ref cons item] 5)) (defmacro pushnew (item ref) "\ (pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)" (byte-code " EE" [setf ref adjoin item] 5)) (defmacro pop (ref) "\ (pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))" (byte-code "  DC D DEEE)" [gensym listname let ref prog1 car setf cdr] 8)) (defmacro psetf (&rest pairs) "\ (psetf {PLACE VALUE}...): Set several generalized variables in parallel. All the VALUEs are computed, and then all the PLACEs are stored as in `setf'. See also `psetq', `shiftf' and `rotatef'." (byte-code " G! !  !L \"\n!.JC\n\n!) A@  @  !L S\n!_JC\n\n!)A@@\"BF." [evenp pairs error "Odd number of arguments to `psetf'" nil *mvalues-count* gensym it unzip-list copy-sequence *mvalues-values* 1 T$$_26 forms places pair-with-newsyms T$$_29 newsyms bindings let setf zip-lists] 7)) (defmacro shiftf (&rest forms) "\ (shiftf PLACE1 PLACE2... NEWVALUE): set PLACE1 to PLACE2, PLACE2 to PLACE3... Each PLACE is set to the old value of the following PLACE, and the last PLACE is set to the value NEWVALUE." (byte-code "GV !!!@  !L 0!=  JC!)A@@AC\"\"B@F-" [forms 1 error "`shiftf' needs more than one argument" butlast last newvalue places nil *mvalues-count* gensym it pair-with-newsyms copy-sequence *mvalues-values* T$$_32 newsyms bindings let setf zip-lists append] 9)) (defmacro rotatef (&rest places) "\ (rotatef PLACE...) sets each PLACE to the old value of the following PLACE. The last PLACE is set to the old value of the first PLACE. Thus, the values rotate through the PLACEs." (byte-code " !L\n!' JC!) A@\n @  \nA\n@C\"\"BF+" [places nil *mvalues-count* gensym it pair-with-newsyms copy-sequence *mvalues-values* 1 T$$_35 newsyms bindings let setf zip-lists append] 9)) (byte-code " \n  " [:include :named :conc-name :copier :predicate :print-function :type :initial-offset :structure-doc :structure-slotsn :structure-slots :structure-indices :structure-initforms] 1) (defmacro defstruct (&rest args) "\ (defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type. NAME must be a symbol, the name of the new structure. It could also be a list (NAME . OPTIONS), but not all options are supported currently. As of Dec. 1986, this is supporting :conc-name, :copier and :predicate completely, :include arguably completely and :constructor only to change the name of the default constructor. No BOA constructors allowed. The DOC-STRING is established as the 'structure-doc' property of NAME. The SLOTS are one or more of the following: SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME list of SYMBOL and VALUE -- meaning that VALUE is the initial value of the slot. `defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the structure, and functions with the same name as the slots to access them. `setf' of the accessors sets their values." (byte-code "  !L !! JC!)  8  8  8 8 A@ @  #L b!m JC!)88888A@@!V\\ \"  \" V!\" !%%!\")  \" ()*+,-D1FD2FD3 DFD4 DFD5 !DF%-DDDEEDEDCDEDEDC@DABEDECDDTEFEDEE, E %L ! JC!)FF8+FA@)F@*)GHI B\"BC(JK-,+*)(&.B" [nil *mvalues-count* gensym it parse$defstruct$args args copy-sequence *mvalues-values* 1 T$$_38 5 initlist 4 slots 3 slotsn 2 docstring options name parse$defstruct$options T$$_41 6 moreinits moreslots moreslotsn predicate copier constructor conc-name numberp 0 append error "%s needs at least one slot" prin1-to-string duplicate-symbols-p dups "`%s' are duplicates" simplify$inits returned alterators accessors keywords functions properties list put quote :structure-doc :structure-slotsn :structure-slots :structure-initforms :structure-indices extract$indices fset function lambda &rest make$structure$instance struct copy-vector thing and vectorp eq elt = length build$accessors$for T$$_44 vector mapcar (lambda (x) (byte-code " D" [quote x] 2)) progn nconc] 14)) (defun parse$defstruct$args (args) "\ PARSE$DEFSTRUCT$ARGS ARGS => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots, SLOTS=list of their names, INITLIST=alist (keyword . initform)." (byte-code " \n@9$\n@ F\n@ SLOTSN SLOTSLIST INITLIST Converts a list of symbols or lists of symbol and form into the last 3 values returned by PARSE$DEFSTRUCT$ARGS." (byte-code "G@ !f9* B!\n#\\ CONC-NAME CONST COPIER PRED Returns at least those 4 values (a string and 3 symbols, to name the necessary functions), might return also things discovered by actually inspecting the options, namely MORESLOTSN MORESLOTS MOREINITS, as can be created by :include, and perhaps a list of BOACONSTRUCTORS." (byte-code " !P\nP!\nP! \nP!  \"    &." [symbol-name name namestring "-" conc-name intern "make-" const "copy-" copier "-p" pred 0 moreslotsn nil moreslots moreinits option-head option-second option-rest these-slotsn these-slots these-inits mapcar (lambda (option) (byte-code " ! = !\") <~ @!~ ! AA\n =Z ;D T M͂T !\"| =} 9q\nq w !\"| = 9\n !\"| = 9\n !\"| =n 9 !\" N N N!V !\"\" $\n!L\"'!*\"$JC''!)))8+)A@,)@-VR,\"+\"1\\12\"23\"3,| \"| !\") !\"" [keywordp option T$$_50 :named error "Can't recognize option `%s'" prin1-to-string option-head second option-second option-rest T$$_51 :conc-name "" "`%s' is invalid as `conc-name'" conc-name :copier copier :constructor const :predicate pred :include "Arg to `:include' should be a symbol, not `%s'" :structure-slotsn these-slotsn :structure-slots these-slots :structure-initforms these-inits numberp 0 "`%s' is not a valid structure" nil *mvalues-count* gensym it process$slots copy-sequence *mvalues-values* 1 T$$_52 2 xtra-inits xtra-slots xtra-slotsn mapcar (lambda (xslot) (byte-code " >?! !#" [xslot these-slots error "`%s' is not a slot of `%s'" prin1-to-string option-second] 5)) append moreslotsn moreslots moreinits member (:print-function :type :initial-offset)] 5)) options values] 9)) (defun simplify$inits (slots initlist) "\ SIMPLIFY$INITS SLOTS INITLIST => new INITLIST Removes from INITLIST - an ALIST - any shadowed bindings." (byte-code " \"\n!*" [nil key result mapcar (lambda (slot) (byte-code " !\n\n \"A#" [keyword-of slot key acons assoc initlist result] 5)) slots nreverse] 3)) (defun extract$indices (initlist) "\ EXTRACT$INDICES INITLIST => indices list Kludge. From a list of pairs (keyword . form) build a list of pairs of the form (keyword . position in list from 0). Useful to precompute some of the work of MAKE$STRUCTURE$INSTANCE." (byte-code "\" !+" [nil 0 index result mapcar (lambda (entry) (byte-code " @\n #\n\\" [acons entry index result 1] 4)) initlist entry nreverse] 3)) (defun build$accessors$for (name conc-name predicate slots slotsn) "\ BUILD$ACCESSORS$FOR NAME PREDICATE SLOTS SLOTSN => FSETS DEFSETFS KWDS Generate the code for accesors and defsetfs of a structure called NAME, whose slots are SLOTS. Also, establishes the keywords for the slots names." (byte-code "Y\n 8!P! DCDTEDDDDFDEEDEB DDTFDDDDFDEEE B 8!D BT ) ! ! !#-" [0 nil "" canonic keywords alterators accessors i slotsn intern conc-name symbol-name slots fset quote function lambda object cond predicate aref t error "`%s' not a %s." prin1-to-string name defsetf newval aset "`%s' not a `%s'" defkeyword keyword-of G$$_1770 values nreverse] 15)) (defun make$structure$instance (name args) "\ MAKE$STRUCTURE$INSTANCE NAME ARGS => new struct NAME A struct of type NAME is created, some slots might be initialized according to ARGS (the &rest argument of MAKE-name)." (byte-code "9 !\" N NNlj \n   !0 V7!\"G!G!\" !La!nJC!)A@@\"!\"\"#@$%#!$D%B%#A#@$%!+ !# \n##!*%#!* \"A!%B%#A##!*%!+B\"." [name error "`%s' is not a possible name for a structure" prin1-to-string :structure-initforms :structure-slotsn :structure-indices nil initializers initalist indices slotsn initforms numberp 0 "`%s' is not a defined structure" evenp args "Slot initializers `%s' not of even length" *mvalues-count* gensym it unzip-list copy-sequence *mvalues-values* 1 T$$_55 specvals speckwds every keywordp "All of the names in `%s' should be keywords" mapcar (lambda (kwd) (byte-code "\n \"A!?\n!!#" [numberp assoc kwd indices error "`%s' is not a valid slot name for %s" prin1-to-string name] 5)) pairlis ptr val result endp quote nreverse caar key eval assoc apply vector] 6))