4.4BSD/usr/src/contrib/emacs-18.57/lisp/cl.elc
(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 \"\" ! [ @ 9?? !\"
BA@ BAA% *
@
D B
BAf +
!
@
@BB A
A
* BF." [nforms pairs symbols forms bindings newsyms assignments i ptr var form newsym ptr1 ptr2 nil /= % 2 0 error "Odd number of arguments to `psetq'" "`psetq' expected a symbol, found '%s'." prin1-to-string gensym nreverse let setq] 11))
(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 B)A
)
! !\"+" [ptr oldforms bindings newsyms newsym G$$_7 nil endp gentemp values nreverse] 7))
(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 " @
@ !
!?5
BBA
A@
@
!-" [p0 evens p1 odds even odd result nil endp nreverse] 6))
(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 " @! !?0
B
B!@!
!
!\"-" [ptr list this next evens odds cadr nil endp cddr values nreverse] 9))
(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 " \"\" Y?' \"
B \\
!))*" [minlen argslists result T$$_0 i apply min mapcar length nil 0 (lambda (sublist) (byte-code " \"" [sublist i elt] 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 @ !O
JC!) 8 8 \"g n !\"\"
@
!? \" ?
B
A
@
-+" [argslist nil acceptable T$$_1 *mvalues-count* it *mvalues-values* forms keywords auxlist ptr this auxval alist evenp error "Odd number of keyword-args" every keywordp "Second arg should be a list of keywords" gensym unzip-list copy-sequence 1 0 "Expected keywords, found `%s'" prin1-to-string pairlis endp assoc] 17))
(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 "
<
\" Â !
\" )
\" )
\" )*" [duplicates propname list nil x gensym every symbolp error "A list of symbols is needed" mapcar (lambda (x) (byte-code " #" [x propname put 0] 4)) (lambda (x) (byte-code " NT#" [x propname put] 5)) (lambda (x) (byte-code " NV
B" [x propname duplicates 1] 2))] 8))
(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 t 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 t nil char-equal symbol-name 0 58] 4))
(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)$ !\"" [sym newsym t keywordp intern ":" symbol-name error "Expected a symbol, not `%s'" prin1-to-string] 7))
(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 "?
? ?@ P\\
\"?<
\" *" [prefix *gentemp-prefix* oblist obarray newsymbol nil newname *gentemp-index* 1 intern-soft intern] 5))
(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
\\ !?* !
*" [prefix *gensym-prefix* newsymbol nil newname *gensym-index* "" 1 intern-soft make-symbol] 5))
(put (quote case) (quote lisp-indent-hook) 1)
(put (quote ecase) (quote lisp-indent-hook) 1)
(put (quote when) (quote lisp-indent-hook) 1)
(put (quote unless) (quote lisp-indent-hook) 1)
(defmacro when (condition &rest body) "(when CONDITION . BODY) => evaluate BODY if CONDITION is true." (byte-code "D $" [condition body list* if not nil] 5))
(defmacro unless (condition &rest body) "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false." (byte-code " $" [condition body list* if nil] 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*" [newsym clauses cases expr gentemp case-clausify let list* cond nreverse] 8))
(defmacro ecase (expr &rest cases) "(ecase EXPR . CASES) => like `case', but error if no case fits.
`t'-clauses are not allowed." (byte-code "
\" != ! DDFD B DC !\"E*" [newsym clauses cases t expr gentemp case-clausify caar error "No clause-head should be `t' or `otherwise' for `ecase'" "ecase on %s = %s failed to take any branch." quote prin1-to-string let list* cond nreverse] 10))
(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
?& !\"{
=/
=H
!?< !B B{
!_
DEB B{
<u
DEB B{
!\"*A
A@
," [currentpos cases nextpos curclause result head body newsym t nil endp error "Case clauses cannot have null heads: `%s'" prin1-to-string otherwise "Clause with `t' or `otherwise' head must be last" atom eql quote member "Don't know how to parse case clause `%s'."] 11))
(put (quote do) (quote lisp-indent-hook) 2)
(put (quote do*) (quote lisp-indent-hook) 2)
(put (quote dolist) (quote lisp-indent-hook) 1)
(put (quote dotimes) (quote lisp-indent-hook) 1)
(put (quote do-symbols) (quote lisp-indent-hook) 1)
(put (quote do-all-symbols) (quote lisp-indent-hook) 1)
(defmacro do (stepforms endforms &rest body) "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables.
STEPFORMS must be a list of symbols or lists. In the second case, the
lists must start with a symbol and contain up to two more forms. In
the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms
are the initial value (def. NIL) and the form to step (def. itself).
The values used by initialization and stepping are computed in parallel.
The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION
evaluates to true in any iteration, ENDBODY is evaluated and the last
form in it is returned.
The BODY (which may be empty) is evaluated at every iteration, with
the symbols of the STEPFORMS bound to the initial or stepped values." (byte-code "! !!! @ A
D \"BB
!BBB," [stepforms endforms initlist steplist endcond endbody body check-do-stepforms check-do-endforms extract-do-inits extract-do-steps let while not append] 11))
(defmacro do* (stepforms endforms &rest body) "`do*' is to `do' as `let*' is to `let'.
STEPFORMS must be a list of symbols or lists. In the second case, the
lists must start with a symbol and contain up to two more forms. In
the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms
are the initial value (def. NIL) and the form to step (def. itself).
Initializations and steppings are done in the sequence they are written.
The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION
evaluates to true in any iteration, ENDBODY is evaluated and the last
form in it is returned.
The BODY (which may be empty) is evaluated at every iteration, with
the symbols of the STEPFORMS bound to the initial or stepped values." (byte-code "! !!! @ A
D \"BB
!BBB," [stepforms endforms initlist steplist endcond endbody body check-do-stepforms check-do-endforms extract-do-inits extract-do*-steps let* while not append] 11))
(defun check-do-stepforms (forms) "\
True if FORMS is a valid stepforms for the do[*] macro (q.v.)" (byte-code "! !\" \"" [forms t nlistp error "Init/Step form for do[*] should be a list, not `%s'" prin1-to-string mapcar (lambda (entry) (byte-code "9 < @9 GW ! !\"" [entry t 4 error "Init/Step must be symbol or (symbol [init [step]]), not `%s'" prin1-to-string] 4))] 6))
(defun check-do-endforms (forms) "\
True if FORMS is a valid endforms for the do[*] macro (q.v.)" (byte-code "< !\"" [forms t error "Termination form for do macro should be a list, not `%s'" prin1-to-string] 4))
(defun extract-do-inits (forms) "\
Returns a list of the initializations (for do) in FORMS
-a stepforms, see the do macro-. Forms is assumed syntactically valid." (byte-code "\"" [forms mapcar (lambda (entry) (byte-code "9 D < @!D" [entry nil cadr] 3))] 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 "!BC" [forms psetq select-stepping-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 "!BC" [forms setq select-stepping-forms] 3))
(defun select-stepping-forms (forms) "\
Separate only the forms that cause stepping." (byte-code "
/ @ < GU& ! @D\" A !+" [result ptr forms entry nil 3 append caddr nreverse] 5))
(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- !\"@!! C BBD
E DC EE+" [stepform var listform resultform body nil nlistp 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'" cadr caddr progn mapcar function lambda let] 15))
(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- !\"@!!
DC EEC E D
$E," [stepform var countform resultform newsym body nlistp 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'" cadr caddr gentemp let* list* do* 0 + 1 >=] 19))
(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- !\"@!! C BBD
E DC EE+" [stepform var oblist resultform body nil nlistp 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'" cadr caddr progn mapatoms function lambda let] 15))
(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 "@!E #" [stepform body list* do-symbols obarray cadr] 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 nlistp error "Body of `loop' should be a list of lists or nil" mapcar (lambda (component) (byte-code "! !" [component nlistp error "Components of `loop' should be lists"] 3)) while t] 6))
(defun first (x) "\
Synonym for `car'" (byte-code "@" [x] 1))
(defun second (x) "\
Return the second element of the list LIST." (byte-code "8" [x 1] 2))
(defun third (x) "\
Return the third element of the list LIST." (byte-code "8" [x 2] 2))
(defun fourth (x) "\
Return the fourth element of the list LIST." (byte-code "8" [x 3] 2))
(defun fifth (x) "\
Return the fifth element of the list LIST." (byte-code "8" [x 4] 2))
(defun sixth (x) "\
Return the sixth element of the list LIST." (byte-code "8" [x 5] 2))
(defun seventh (x) "\
Return the seventh element of the list LIST." (byte-code "8" [x 6] 2))
(defun eighth (x) "\
Return the eighth element of the list LIST." (byte-code "8" [x 7] 2))
(defun ninth (x) "\
Return the ninth element of the list LIST." (byte-code "8" [x 8] 2))
(defun tenth (x) "\
Return the tenth element of the list LIST." (byte-code "8" [x 9] 2))
(defun rest (x) "\
Synonym for `cdr'" (byte-code "A" [x] 1))
(defun endp (x) "\
t if X is nil, nil if X is a cons; error otherwise." (byte-code "<
? !\"" [x error "endp received a non-cons, non-null argument `%s'" prin1-to-string] 4))
(defun last (x) "\
Returns the last link in the list LIST." (byte-code "! !A
!?( A
A * *" [x current-cons next-cons G$$_9 G$$_8 nil nlistp error "Arg to `last' must be a list" endp] 6))
(defun list-length (x) "\
Returns the length of a non-circular list, or `nil' for a circular one." (byte-code "
?_ ! ƉG A!, \\ƉG =5 VB ʼnƉG \\ ! A * ," [n fast x slow ready nil t G$$_11 G$$_10 0 endp 1 2 cddr] 6))
(defun member (item list) "\
Look for ITEM in LIST; return first link in LIST whose car is `eql' to ITEM." (byte-code "
!?(
@= ƉA +" [ptr list done nil result item t endp] 4))
(defun butlast (list &optional n) "\
Return a new list like LIST but sans the last N elements.
N defaults to 1. If the list doesn't have N elements, nil is returned." (byte-code "? !\"!" [n list 1 reverse nthcdr] 5))
(defun list* (arg &rest others) "\
Return a new list containing the first arguments consed onto the last arg.
Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)." (byte-code "? B
!
! ! @\" +" [others arg allargs front back butlast last rplacd] 6))
(defun adjoin (item list) "\
Return a list which contains ITEM but is otherwise like LIST.
If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST).
When comparing ITEM against elements, `eql' is used." (byte-code " \" B" [item list t member] 3))
(defun ldiff (list sublist) "\
Return a new list like LIST but sans SUBLIST.
SUBLIST must be one of the links in LIST; otherwise the value is LIST itself." (byte-code "
!
=?% @B A ) !*" [result curcons list sublist G$$_12 nil endp reverse] 4))
(defun caar (X) "\
Return the car of the car of X." (byte-code "@@" [X] 1))
(defun cadr (X) "\
Return the car of the cdr of X." (byte-code "A@" [X] 1))
(defun cdar (X) "\
Return the cdr of the car of X." (byte-code "@A" [X] 1))
(defun cddr (X) "\
Return the cdr of the cdr of X." (byte-code "AA" [X] 1))
(defun caaar (X) "\
Return the car of the car of the car of X." (byte-code "@@@" [X] 1))
(defun caadr (X) "\
Return the car of the car of the cdr of X." (byte-code "A@@" [X] 1))
(defun cadar (X) "\
Return the car of the cdr of the car of X." (byte-code "@A@" [X] 1))
(defun cdaar (X) "\
Return the cdr of the car of the car of X." (byte-code "@@A" [X] 1))
(defun caddr (X) "\
Return the car of the cdr of the cdr of X." (byte-code "AA@" [X] 1))
(defun cdadr (X) "\
Return the cdr of the car of the cdr of X." (byte-code "A@A" [X] 1))
(defun cddar (X) "\
Return the cdr of the cdr of the car of X." (byte-code "@AA" [X] 1))
(defun cdddr (X) "\
Return the cdr of the cdr of the cdr of X." (byte-code "AAA" [X] 1))
(defun caaaar (X) "\
Return the car of the car of the car of the car of X." (byte-code "@@@@" [X] 1))
(defun caaadr (X) "\
Return the car of the car of the car of the cdr of X." (byte-code "A@@@" [X] 1))
(defun caadar (X) "\
Return the car of the car of the cdr of the car of X." (byte-code "@A@@" [X] 1))
(defun cadaar (X) "\
Return the car of the cdr of the car of the car of X." (byte-code "@@A@" [X] 1))
(defun cdaaar (X) "\
Return the cdr of the car of the car of the car of X." (byte-code "@@@A" [X] 1))
(defun caaddr (X) "\
Return the car of the car of the cdr of the cdr of X." (byte-code "AA@@" [X] 1))
(defun cadadr (X) "\
Return the car of the cdr of the car of the cdr of X." (byte-code "A@A@" [X] 1))
(defun cdaadr (X) "\
Return the cdr of the car of the car of the cdr of X." (byte-code "A@@A" [X] 1))
(defun caddar (X) "\
Return the car of the cdr of the cdr of the car of X." (byte-code "@AA@" [X] 1))
(defun cdadar (X) "\
Return the cdr of the car of the cdr of the car of X." (byte-code "@A@A" [X] 1))
(defun cddaar (X) "\
Return the cdr of the cdr of the car of the car of X." (byte-code "@@AA" [X] 1))
(defun cadddr (X) "\
Return the car of the cdr of the cdr of the cdr of X." (byte-code "AAA@" [X] 1))
(defun cddadr (X) "\
Return the cdr of the cdr of the car of the cdr of X." (byte-code "A@AA" [X] 1))
(defun cdaddr (X) "\
Return the cdr of the car of the cdr of the cdr of X." (byte-code "AA@A" [X] 1))
(defun cdddar (X) "\
Return the cdr of the cdr of the cdr of the car of X." (byte-code "@AAA" [X] 1))
(defun cddddr (X) "\
Return the cdr of the cdr of the cdr of the cdr of X." (byte-code "AAAA" [X] 1))
(defun setnth (n list newval) "\
Set (nth N LIST) to NEWVAL. Returns NEWVAL." (byte-code " \"
\"" [n list newval rplaca nthcdr] 4))
(defun setnthcdr (n list newval) "\
SETNTHCDR N LIST NEWVAL => NEWVAL
As a side effect, sets the Nth cdr of LIST to NEWVAL." (byte-code "W
\", U#
@\"
A\"
, Z \"
\"" [n list newval t 0 error "N must be 0 or greater, not %d" rplaca rplacd nthcdr 1] 7))
(defun acons (key item alist) "\
Return a new alist with KEY paired with ITEM; otherwise like ALIST.
Does not copy ALIST." (byte-code " B
B" [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 ! @ @ !?C
# A A @ @ -" [keys data nil kptr dptr key item result alist error "Keys and data should be the same length" endp acons] 7))
(defkeyword :test "Used to designate positive (selection) tests.")
(defkeyword :test-not "Used to designate negative (rejection) tests.")
(defkeyword :key "Used to designate component extractions.")
(defkeyword :predicate "Used to define matching of sequence components.")
(defkeyword :start "Inclusive low index in sequence")
(defkeyword :end "Exclusive high index in sequence")
(defkeyword :start1 "Inclusive low index in first of two sequences.")
(defkeyword :start2 "Inclusive low index in second of two sequences.")
(defkeyword :end1 "Exclusive high index in first of two sequences.")
(defkeyword :end2 "Exclusive high index in second of two sequences.")
(defkeyword :count "Number of elements to affect.")
(defkeyword :from-end "T when counting backwards.")
(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 \"?6 Ă> ʉA@
-)" [args seq moreseqs ready nil result applyval remaining current pred t reassemble-argslists list* endp apply] 7))
(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 "
\"! @ !?L
\"5 Ă< ƉĉA@
-)" [args seq moreseqs ready nil result t applyval remaining current pred reassemble-argslists list* endp apply] 7))
(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 "
\"! @ !?M
\"?6 Ă= ƉĉA@
-)" [args seq moreseqs ready nil result t applyval remaining current pred reassemble-argslists list* endp apply] 7))
(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 "
\"! @ !?L \"5 Ă< ʉʉA@
-)" [args seq moreseqs ready nil result applyval remaining current pred t reassemble-argslists list* endp apply] 7))
(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
W
Y
#7 <$
#7 !1
I7 !\")" [l seq n t newval 0 error "N(%d) should be between 0 and %d" setnth arrayp "SEQ should be a sequence, not `%s'" prin1-to-string] 7))
(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 "
\"A )" [retrieved key klist default assoc] 3))
(defun add-to-klist (key item klist) "\
ADD-TO-KLIST KEY ITEM KLIST => new KLIST
Add association (KEY . ITEM) to KLIST." (byte-code "
#" [klist key item acons] 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 "
\"
\"
# \"
\"#: 4
\"#?:
!\"+" [test :test klist test-not :test-not keyfn :key item elt t extract-from-klist identity funcall error "Neither :test nor :test-not in `%s'" prin1-to-string] 11))
(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 "
\" \"
\"#*" [predicate :predicate klist keyfn :key item elt extract-from-klist identity funcall] 8))
(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 "
\" \"
\"#?*" [predicate :predicate klist keyfn :key item elt extract-from-klist identity funcall] 8))
(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 "
\"
\"
# %
\"
\"#@ :
\"
\"#?@
!\"+" [test :test klist test-not :test-not keyfn :key e1 e2 t extract-from-klist identity funcall error "Neither :test nor :test-not in `%s'" prin1-to-string] 13))
(put (quote multiple-value-bind) (quote lisp-indent-hook) 2)
(put (quote multiple-value-setq) (quote lisp-indent-hook) 2)
(put (quote multiple-value-list) (quote lisp-indent-hook) nil)
(put (quote multiple-value-call) (quote lisp-indent-hook) 1)
(put (quote multiple-value-prog1) (quote lisp-indent-hook) 1)
(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@" [*mvalues-values* val-forms *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 *mvalues-values* *mvalues-count* nlistp error "Argument to values-list must be a list, not `%s'" prin1-to-string] 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 "EDC EDEDDEDFFFE" [nil form progn setq *mvalues-count* let it (gensym) set 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 "
!DDC DE DDEEEEE*" [result arg function args gentemp apply eval let* nil dolist quote setq append multiple-value-list] 16))
(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 #*" [vals clauses vars form body gentemp mv-bind-clausify list* let* multiple-value-list] 7))
(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 "
\" DDCK \"BE*" [vals clauses vars form gentemp mv-bind-clausify let* multiple-value-list setq apply append] 9))
(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)" [heldvalues form body gentemp let* multiple-value-list append values-list] 7))
(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 Y?: 8
ED
B \\
))*" [vars nvars clauses T$$_4 n vals nlistp notevery symbolp error "Expected a list of symbols, not `%s'" prin1-to-string nil 0 nth 1] 9))
(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 "\"\"" [number /= % 2 0] 4))
(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 Z
" [number t 0] 2))
(defun signum (number) "\
Return -1, 0 or 1 according to the sign of NUMBER." (byte-code "W
 V à " [number t 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 @! V4 K 8 8\" \"B\" 8 8\"!?F ÂI ! 8! 8!
]
^
? \"\" !
Èl .)" [howmany integers t nil absa absb dd ds q r done result 0 1 abs 2 apply gcd nthcdr zerop * error "A zero argument is invalid for `gcd'" / %] 16))
(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 8 \" !
!K V1 K
\"B\"K
\"
!B ȂK
!
\"\"-" [howmany more a integer b prod yetmore t 0 nil nthcdr 1 zerop abs apply lcm * / gcd] 14))
(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 "! !k ! ʂk X ̂k \" ?Y
\"
\"
\"YE ̂F #\"
=
)
\"Vi
Zj
+" [number t approx done nil iter minusp error "Argument to `isqrt' must not be negative" zerop 0 3 1 / 2 + % *] 15))
(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 \"L - != щJC!) 8 8 8
!\\ \" !l
\" !w ł
\\Z
\"Z
\"," [divisor number t T$$_5 *mvalues-count* nil it *mvalues-values* s r q numberp values 0 gensym safe-idiv copy-sequence 1 2 zerop plusp *] 15))
(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 \"L - != щJC!) 8 8 8
!\\ \" !l
\" !w ł
\\
\"Z
\"," [divisor number t T$$_8 *mvalues-count* nil it *mvalues-values* s r q numberp values 0 gensym safe-idiv copy-sequence 1 2 zerop minusp *] 15))
(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 \"L - != щJC!) 8 8 8
!\\ \" !l
\" !w ł
Z
\"Z
\"," [divisor number t T$$_11 *mvalues-count* nil it *mvalues-values* s r q numberp values 0 gensym safe-idiv copy-sequence 1 2 zerop plusp *] 15))
(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 \"L - != ҉JC!) 8 8 8
! ! Z Vp
\\
U|
!
\\
\"
\"Z
\")," [divisor number t T$$_14 *mvalues-count* nil it *mvalues-values* s r q other-r numberp values 0 gensym safe-idiv copy-sequence 1 2 abs oddp *] 14))
(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!)8 8 +" [T$$_17 *mvalues-count* nil it number divisor *mvalues-values* r q gensym floor copy-sequence 1 0] 6))
(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!)8 8 +" [T$$_20 *mvalues-count* nil it number divisor *mvalues-values* r q gensym truncate copy-sequence 1 0] 6))
(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 "! ! ! !? # \"! ! \" ! !\"
\" \"Z
#-" [a b nil absa absb q s r numberp error "Arguments to `safe-idiv' must be numbers" zerop "Cannot divide %d by zero" abs / * signum values] 17))
(defkeyword :setf-update-fn "Property, its value is the function setf must invoke to update a
generalized variable whose access form is a function call of the
symbol that has this property.")
(defkeyword :setf-update-doc "Property of symbols that have a `defsetf' update function on them,
installed by the `defsetf' from its optional third argument.")
(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 *V\\ @ ! !?R
EB ! @ !0 !,B* @ ! 9u
E) < @ 9
N # : @= 9 ! K ! : @=) A
C\"B
A
C\"!L
!
JC!) 8 8 BE+) !\",)" [nforms pairs nil args place value result t head updatefn :setf-update-fn defn T$$_23 *mvalues-count* it *mvalues-values* newsyms bindings /= % 2 0 error "Odd number of arguments to `setf'" progn cadr endp setf cddr nreverse setq lambda fboundp subrp append gensym pair-with-newsyms copy-sequence 1 let "No `setf' update-function for `%s'" prin1-to-string] 21))
(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 nil :setf-update-fn updatefn :setf-update-doc docstring error "First argument of `defsetf' must be a symbol, not `%s'" prin1-to-string put] 7))
(defsetf apply (lambda (&rest args) (let* ((fnform (car args)) (applyargs (append (apply (quote list*) (butlast (cdr args))) (last args))) (newupdater nil)) (cond ((and (symbolp fnform) (setq newupdater (get fnform :setf-update-fn))) (apply newupdater applyargs)) (t (error "Can't `setf' to `%s'" (prin1-to-string fnform)))))) "`apply' is a special case for `setf'")
(defsetf aref aset "`setf' inversion for `aref'")
(defsetf nth setnth "`setf' inversion for `nth'")
(defsetf nthcdr setnthcdr "`setf' inversion for `nthcdr'")
(defsetf elt setelt "`setf' inversion for `elt'")
(defsetf first (lambda (list val) (setnth 0 list val)) "`setf' inversion for `first'")
(defsetf second (lambda (list val) (setnth 1 list val)) "`setf' inversion for `second'")
(defsetf third (lambda (list val) (setnth 2 list val)) "`setf' inversion for `third'")
(defsetf fourth (lambda (list val) (setnth 3 list val)) "`setf' inversion for `fourth'")
(defsetf fifth (lambda (list val) (setnth 4 list val)) "`setf' inversion for `fifth'")
(defsetf sixth (lambda (list val) (setnth 5 list val)) "`setf' inversion for `sixth'")
(defsetf seventh (lambda (list val) (setnth 6 list val)) "`setf' inversion for `seventh'")
(defsetf eighth (lambda (list val) (setnth 7 list val)) "`setf' inversion for `eighth'")
(defsetf ninth (lambda (list val) (setnth 8 list val)) "`setf' inversion for `ninth'")
(defsetf tenth (lambda (list val) (setnth 9 list val)) "`setf' inversion for `tenth'")
(defsetf rest (lambda (list val) (setcdr list val)) "`setf' inversion for `rest'")
(defsetf car setcar "Replace the car of a cons")
(defsetf cdr setcdr "Replace the cdr of a cons")
(defsetf caar (lambda (list val) (setcar (nth 0 list) val)) "`setf' inversion for `caar'")
(defsetf cadr (lambda (list val) (setcar (cdr list) val)) "`setf' inversion for `cadr'")
(defsetf cdar (lambda (list val) (setcdr (car list) val)) "`setf' inversion for `cdar'")
(defsetf cddr (lambda (list val) (setcdr (cdr list) val)) "`setf' inversion for `cddr'")
(defsetf caaar (lambda (list val) (setcar (caar list) val)) "`setf' inversion for `caaar'")
(defsetf caadr (lambda (list val) (setcar (cadr list) val)) "`setf' inversion for `caadr'")
(defsetf cadar (lambda (list val) (setcar (cdar list) val)) "`setf' inversion for `cadar'")
(defsetf cdaar (lambda (list val) (setcdr (caar list) val)) "`setf' inversion for `cdaar'")
(defsetf caddr (lambda (list val) (setcar (cddr list) val)) "`setf' inversion for `caddr'")
(defsetf cdadr (lambda (list val) (setcdr (cadr list) val)) "`setf' inversion for `cdadr'")
(defsetf cddar (lambda (list val) (setcdr (cdar list) val)) "`setf' inversion for `cddar'")
(defsetf cdddr (lambda (list val) (setcdr (cddr list) val)) "`setf' inversion for `cdddr'")
(defsetf caaaar (lambda (list val) (setcar (caaar list) val)) "`setf' inversion for `caaaar'")
(defsetf caaadr (lambda (list val) (setcar (caadr list) val)) "`setf' inversion for `caaadr'")
(defsetf caadar (lambda (list val) (setcar (cadar list) val)) "`setf' inversion for `caadar'")
(defsetf cadaar (lambda (list val) (setcar (cdaar list) val)) "`setf' inversion for `cadaar'")
(defsetf cdaaar (lambda (list val) (setcdr (caar list) val)) "`setf' inversion for `cdaaar'")
(defsetf caaddr (lambda (list val) (setcar (caddr list) val)) "`setf' inversion for `caaddr'")
(defsetf cadadr (lambda (list val) (setcar (cdadr list) val)) "`setf' inversion for `cadadr'")
(defsetf cdaadr (lambda (list val) (setcdr (caadr list) val)) "`setf' inversion for `cdaadr'")
(defsetf caddar (lambda (list val) (setcar (cddar list) val)) "`setf' inversion for `caddar'")
(defsetf cdadar (lambda (list val) (setcdr (cadar list) val)) "`setf' inversion for `cdadar'")
(defsetf cddaar (lambda (list val) (setcdr (cdaar list) val)) "`setf' inversion for `cddaar'")
(defsetf cadddr (lambda (list val) (setcar (cdddr list) val)) "`setf' inversion for `cadddr'")
(defsetf cddadr (lambda (list val) (setcdr (cdadr list) val)) "`setf' inversion for `cddadr'")
(defsetf cdaddr (lambda (list val) (setcdr (caddr list) val)) "`setf' inversion for `cdaddr'")
(defsetf cdddar (lambda (list val) (setcdr (cddar list) val)) "`setf' inversion for `cdddar'")
(defsetf cddddr (lambda (list val) (setcdr (cddr list) val)) "`setf' inversion for `cddddr'")
(defsetf get put "`setf' inversion for `get' is `put'")
(defsetf symbol-function fset "`setf' inversion for `symbol-function' is `fset'")
(defsetf symbol-plist setplist "`setf' inversion for `symbol-plist' is `setplist'")
(defsetf symbol-value set "`setf' inversion for `symbol-value' is `set'")
(defmacro incf (ref &optional delta) "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)" (byte-code "? EE" [delta ref 1 setf +] 5))
(defmacro decf (ref &optional delta) "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)" (byte-code "? EE" [delta ref 1 setf -] 5))
(defmacro push (item ref) "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)" (byte-code " EE" [ref item setf cons] 5))
(defmacro pushnew (item ref) "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)" (byte-code " EE" [ref item setf adjoin] 5))
(defmacro pop (ref) "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))" (byte-code " DCD DEEE)" [listname ref gensym let prog1 car setf cdr] 9))
(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 &
!3 щ JC
!)
8
8 !L W
!d щ JC
!) 8 8
\"BF++" [pairs nil T$$_26 *mvalues-count* it *mvalues-values* forms places T$$_29 newsyms bindings evenp error "Odd number of arguments to `psetf'" gensym unzip-list copy-sequence 1 0 pair-with-newsyms let setf zip-lists] 16))
(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
2 !B ʉJC!) 8 8
A C\"\"B@F+*" [forms nil places newvalue T$$_32 *mvalues-count* it *mvalues-values* newsyms bindings 1 error "`shiftf' needs more than one argument" butlast last gensym pair-with-newsyms copy-sequence 0 let setf zip-lists append] 15))
(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 "? P
!L ! !0 ̉
JC!) 8 8 A@C\"\"BF+" [places nil t T$$_35 *mvalues-count* it *mvalues-values* newsyms bindings gensym pair-with-newsyms copy-sequence 1 0 let setf zip-lists append] 12))
(defkeyword :include "Syntax of `defstruct'")
(defkeyword :named "Syntax of `defstruct'")
(defkeyword :conc-name "Syntax of `defstruct'")
(defkeyword :copier "Syntax of `defstruct'")
(defkeyword :predicate "Syntax of `defstruct'")
(defkeyword :print-function "Syntax of `defstruct'")
(defkeyword :type "Syntax of `defstruct'")
(defkeyword :initial-offset "Syntax of `defstruct'")
(defkeyword :structure-doc "Documentation string for a structure.")
(defkeyword :structure-slotsn "Number of slots in structure")
(defkeyword :structure-slots "List of the slot's names")
(defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)")
(defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)")
(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 8
8
#L `
!m JC
!) 8
8 8 8 8 8 8 ! V? \\\"
\"V !\"! ? !\")\" D F D F D DF D DF D !DF%DD DEEDEDCDEDEDC@ A DB C E DED E DTEFEDEE F %L
! JC
!) 8 8 8)G H I B\"BCJ K &B..." [T$$_36 *mvalues-count* nil it args *mvalues-values* initlist slots slotsn docstring options name T$$_37 moreinits moreslots moreslotsn predicate copier constructor conc-name dups properties functions keywords accessors alterators returned :structure-doc :structure-slotsn :structure-slots :structure-initforms :structure-indices T$$_38 gensym parse$defstruct$args copy-sequence 1 5 4 3 2 0 parse$defstruct$options 6 numberp append error "%s needs at least one slot" prin1-to-string duplicate-symbols-p "`%s' are duplicates" simplify$inits list put quote extract$indices fset function lambda &rest make$structure$instance struct copy-vector thing and vectorp eq elt = length build$accessors$for vector mapcar (lambda (x) (list (quote quote) x)) progn nconc] 32))
(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 " @9 @ɉ@ @<, !9= !!@ !A @;?R ɂY @ Aɉ !L v
! JC
!)
8
8
8
&,." [name options docstring slotargs slotsn slots initlist args t nil T$$_39 *mvalues-count* it *mvalues-values* "" 0 caar cdar error "First arg to `defstruct' must be symbol or (symbol ...)" gensym process$slots copy-sequence 1 2 values] 15))
(defun process$slots (slots) "\
PROCESS$SLOTS SLOTS => 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 @ !?f
9*
B
! #Z
<2
@9T
@
!
B! #*Z
!\" A @ *
! !#+" [slotsn slots slotslist initlist ptr this nil name form t endp acons keyword-of cadr error "Slot should be symbol or (symbol ...), not `%s'" prin1-to-string values nreverse] 14))
(defun parse$defstruct$options (name options slots) "\
PARSE$DEFSTRUCT$OPTIONS NAME OPTIONS SLOTS => 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 " !PP!P! P!
\" )
&." [namestring name conc-name const copier pred moreslotsn moreslots moreinits option-head option-second option-rest these-slotsn these-slots these-inits options option nil symbol-name "-" intern "make-" "copy-" "-p" 0 mapcar (lambda (option) (byte-code "! = !\")<# @!!\" =[ ;F U ?O U !\"=| 9i
?p v !\"= 9
? !\" = 9
? !\"
= 9 ˂ !\"
N N N ! V ˂ !\"ˉ
!L !/JC!) 8 8 8 V?P˂e\" )\" \\\" \" ,\"!\")!\"" [option T$$_40 t option-head option-second option-rest T$$_41 conc-name copier const pred nil these-slotsn :structure-slotsn these-slots :structure-slots these-inits :structure-initforms T$$_42 *mvalues-count* it *mvalues-values* xtra-inits xtra-slots xtra-slotsn xslot moreslotsn moreslots moreinits keywordp :named error "Can't recognize option `%s'" prin1-to-string second nthcdr 2 :conc-name "" "`%s' is invalid as `conc-name'" :copier :constructor :predicate :include "Arg to `:include' should be a symbol, not `%s'" numberp 0 "`%s' is not a valid structure" gensym process$slots copy-sequence 1 mapcar (lambda (xslot) (byte-code " >
! !#" [xslot these-slots nil option-second error "`%s' is not a slot of `%s'" prin1-to-string] 6)) append member (:print-function :type :initial-offset)] 34)) values] 13))
(defun simplify$inits (slots initlist) "\
SIMPLIFY$INITS SLOTS INITLIST => new INITLIST
Removes from INITLIST - an ALIST - any shadowed bindings." (byte-code "
\")!*" [result key slots slot nil mapcar (lambda (slot) (byte-code " ! \"A
#" [key slot result initlist keyword-of acons assoc] 6)) 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 "
\"!)*" [result index initlist entry nil 0 mapcar (lambda (entry) (byte-code " @
#
\\" [result entry index acons 1] 4)) 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? 8!P! DCDTEDD DDFDEEDE B DDTFDD DDFDEEE
B8!D BT
)
!
! !#-" [i accessors alterators keywords canonic slotsn conc-name slots predicate name G$$_13 nil 0 "" intern symbol-name fset quote function lambda object cond aref t error "`%s' not a %s." prin1-to-string defsetf newval aset "`%s' not a `%s'" defkeyword keyword-of values nreverse] 17))
(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
NN !- V4 : !\"
G!G N
!\"
!L l !}
JC!) 8 8 K\" !\"\" ) @ !? DBA@ !+
!# ! !?!\"A!BA! !+ K B\"+-" [name nil initforms :structure-initforms slotsn :structure-slotsn indices :structure-indices initalist initializers args T$$_43 *mvalues-count* it *mvalues-values* specvals speckwds kwd ptr val result key error "`%s' is not a possible name for a structure" prin1-to-string numberp 0 "`%s' is not a defined structure" evenp "Slot initializers `%s' not of even length" gensym unzip-list copy-sequence 1 every keywordp "All of the names in `%s' should be keywords" mapcar (lambda (kwd) (byte-code " \"A! ! !#" [kwd indices nil name numberp assoc error "`%s' is not a valid slot name for %s" prin1-to-string] 8)) pairlis endp quote nreverse caar eval assoc apply vector] 32))