Return to cl.el CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp

Annotation of 43BSDReno/contrib/emacs-18.55/lisp/cl.el, revision 1.1

1.1     ! root        1: ;; Common-Lisp extensions for GNU Emacs Lisp.
        !             2: ;; Copyright (C) 1987, 1988 Free Software Foundation, Inc.
        !             3: 
        !             4: ;; This file is part of GNU Emacs.
        !             5: 
        !             6: ;; GNU Emacs is distributed in the hope that it will be useful,
        !             7: ;; but WITHOUT ANY WARRANTY.  No author or distributor
        !             8: ;; accepts responsibility to anyone for the consequences of using it
        !             9: ;; or for whether it serves any particular purpose or works at all,
        !            10: ;; unless he says so in writing.  Refer to the GNU Emacs General Public
        !            11: ;; License for full details.
        !            12: 
        !            13: ;; Everyone is granted permission to copy, modify and redistribute
        !            14: ;; GNU Emacs, but only under the conditions described in the
        !            15: ;; GNU Emacs General Public License.   A copy of this license is
        !            16: ;; supposed to have been given to you along with GNU Emacs so you
        !            17: ;; can know your rights and responsibilities.  It should be in a
        !            18: ;; file named COPYING.  Among other things, the copyright notice
        !            19: ;; and this notice must be preserved on all copies.
        !            20: 
        !            21: ;;;;
        !            22: ;;;; These are extensions to Emacs Lisp that provide some form of
        !            23: ;;;; Common Lisp compatibility, beyond what is already built-in
        !            24: ;;;; in Emacs Lisp.
        !            25: ;;;;
        !            26: ;;;; When developing them, I had the code spread among several files.
        !            27: ;;;; This file 'cl.el' is a concatenation of those original files,
        !            28: ;;;; minus some declarations that became redundant.  The marks between
        !            29: ;;;; the original files can be found easily, as they are lines that
        !            30: ;;;; begin with four semicolons (as this does).  The names of the
        !            31: ;;;; original parts follow the four semicolons in uppercase, those
        !            32: ;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS,
        !            33: ;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT.  If you
        !            34: ;;;; add functions to this file, you might want to put them in a place
        !            35: ;;;; that is compatible with the division above (or invent your own
        !            36: ;;;; categories).
        !            37: ;;;;
        !            38: ;;;; To compile this file, make sure you load it first.  This is
        !            39: ;;;; because many things are implemented as macros and now that all
        !            40: ;;;; the files are concatenated together one cannot ensure that
        !            41: ;;;; declaration always precedes use.
        !            42: ;;;;
        !            43: ;;;; Bug reports, suggestions and comments,
        !            44: ;;;; to [email protected]
        !            45: 
        !            46: (provide 'cl)
        !            47: 
        !            48: 
        !            49: ;;;; GLOBAL
        !            50: ;;;;    This file provides utilities and declarations that are global
        !            51: ;;;;    to Common Lisp and so might be used by more than one of the
        !            52: ;;;;    other libraries.  Especially, I intend to keep here some
        !            53: ;;;;    utilities that help parsing/destructuring some difficult calls. 
        !            54: ;;;;
        !            55: ;;;;
        !            56: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !            57: ;;;;       ([email protected])
        !            58: 
        !            59: (defmacro psetq (&rest pairs)
        !            60:   "(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE.
        !            61: All the VALUEs are evaluated, and then all the VARIABLEs are set.
        !            62: Aside from order of evaluation, this is the same as `setq'."
        !            63:   (let ((nforms (length pairs))                ;count of args
        !            64:        ;; next are used to destructure the call
        !            65:        symbols                         ;even numbered args
        !            66:        forms                           ;odd numbered args
        !            67:        ;; these are used to generate code
        !            68:        bindings                        ;for the let
        !            69:        newsyms                         ;list of gensyms
        !            70:        assignments                     ;for the setq
        !            71:        ;; auxiliary indices
        !            72:        i)
        !            73:     ;; check there is a reasonable number of forms
        !            74:     (if (/= (% nforms 2) 0)
        !            75:        (error "Odd number of arguments to `psetq'"))
        !            76: 
        !            77:     ;; destructure the args
        !            78:     (let ((ptr pairs)                  ;traverses the args
        !            79:          var                           ;visits each symbol position
        !            80:          )
        !            81:       (while ptr
        !            82:        (setq var (car ptr))            ;next variable
        !            83:        (if (not (symbolp var))
        !            84:            (error "`psetq' expected a symbol, found '%s'."
        !            85:                   (prin1-to-string var)))
        !            86:        (setq symbols (cons var symbols))
        !            87:        (setq forms   (cons (car (cdr ptr)) forms))
        !            88:        (setq ptr (cdr (cdr ptr)))))
        !            89: 
        !            90:     ;; assign new symbols to the bindings
        !            91:     (let ((ptr forms)                  ;traverses the forms
        !            92:          form                          ;each form goes here
        !            93:          newsym                        ;gensym for current value of form
        !            94:          )
        !            95:       (while ptr
        !            96:        (setq form (car ptr))
        !            97:        (setq newsym (gensym))
        !            98:        (setq bindings (cons (list newsym form) bindings))
        !            99:        (setq newsyms (cons newsym newsyms))
        !           100:        (setq ptr (cdr ptr))))
        !           101:     (setq newsyms (nreverse newsyms))  ;to sync with symbols
        !           102:     
        !           103:     ;; pair symbols with newsyms for assignment
        !           104:     (let ((ptr1 symbols)               ;traverses original names
        !           105:          (ptr2 newsyms)                ;traverses new symbols
        !           106:          )
        !           107:       (while ptr1
        !           108:        (setq assignments
        !           109:              (cons (car ptr1) (cons (car ptr2) assignments)))
        !           110:        (setq ptr1 (cdr ptr1))
        !           111:        (setq ptr2 (cdr ptr2))))
        !           112:     
        !           113:     ;; generate code
        !           114:     (list 'let
        !           115:          bindings
        !           116:          (cons 'setq assignments)
        !           117:          nil)))
        !           118: 
        !           119: ;;; utilities
        !           120: ;;;
        !           121: ;;; pair-with-newsyms takes a list and returns a list of lists of the
        !           122: ;;; form (newsym form), such that a let* can then bind the evaluation
        !           123: ;;; of the forms to the newsyms.  The idea is to guarantee correct
        !           124: ;;; order of evaluation of the subforms of a setf.  It also returns a
        !           125: ;;; list of the newsyms generated, in the corresponding order.
        !           126: 
        !           127: (defun pair-with-newsyms (oldforms)
        !           128:   "PAIR-WITH-NEWSYMS OLDFORMS
        !           129: The top-level components of the list oldforms are paired with fresh
        !           130: symbols, the pairings list and the newsyms list are returned."
        !           131:   (do ((ptr oldforms (cdr ptr))
        !           132:        (bindings '())
        !           133:        (newsyms  '()))
        !           134:       ((endp ptr) (values (nreverse bindings) (nreverse newsyms)))
        !           135:     (let ((newsym (gentemp)))
        !           136:       (setq bindings (cons (list newsym (car ptr)) bindings))
        !           137:       (setq newsyms  (cons newsym newsyms)))))
        !           138: 
        !           139: (defun zip-lists (evens odds)
        !           140:   "Merge two lists EVENS and ODDS, taking elts from each list alternatingly.
        !           141: EVENS and ODDS are two lists.  ZIP-LISTS constructs a new list, whose
        !           142: even numbered elements (0,2,...) come from EVENS and whose odd
        !           143: numbered elements (1,3,...) come from ODDS. 
        !           144: The construction stops when the shorter list is exhausted."
        !           145:   (do* ((p0   evens    (cdr p0))
        !           146:         (p1   odds     (cdr p1))
        !           147:         (even (car p0) (car p0))
        !           148:         (odd  (car p1) (car p1))
        !           149:         (result '()))
        !           150:       ((or (endp p0) (endp p1))
        !           151:        (nreverse result))
        !           152:     (setq result
        !           153:           (cons odd (cons even result)))))
        !           154: 
        !           155: (defun unzip-list (list)
        !           156:   "Extract even and odd elements of LIST into two separate lists.
        !           157: The argument LIST is separated in two strands, the even and the odd
        !           158: numbered elements.  Numbering starts with 0, so the first element
        !           159: belongs in EVENS. No check is made that there is an even number of
        !           160: elements to start with."
        !           161:   (do* ((ptr   list       (cddr ptr))
        !           162:         (this  (car ptr)  (car ptr))
        !           163:         (next  (cadr ptr) (cadr ptr))
        !           164:         (evens '())
        !           165:         (odds  '()))
        !           166:       ((endp ptr)
        !           167:        (values (nreverse evens) (nreverse odds)))
        !           168:     (setq evens (cons this evens))
        !           169:     (setq odds  (cons next odds))))
        !           170: 
        !           171: (defun reassemble-argslists (argslists)
        !           172:   "(reassemble-argslists ARGSLISTS).
        !           173: ARGSLISTS is a list of sequences.  Return a list of lists, the first
        !           174: sublist being all the entries coming from ELT 0 of the original
        !           175: sublists, the next those coming from ELT 1 and so on, until the
        !           176: shortest list is exhausted."
        !           177:   (let* ((minlen   (apply 'min (mapcar 'length argslists)))
        !           178:          (result   '()))
        !           179:     (dotimes (i minlen (nreverse result))
        !           180:       ;; capture all the elements at index i
        !           181:       (setq result
        !           182:             (cons (mapcar
        !           183:                    (function (lambda (sublist) (elt sublist i)))
        !           184:                    argslists)
        !           185:                   result)))))
        !           186: 
        !           187: ;;; to help parsing keyword arguments
        !           188: 
        !           189: (defun build-klist (argslist acceptable)
        !           190:   "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE.
        !           191: ARGSLIST is a list, presumably the &rest argument of a call, whose
        !           192: even numbered elements must be keywords.
        !           193: ACCEPTABLE is a list of keywords, the only ones that are truly acceptable.
        !           194: The result is an alist containing the arguments named by the keywords
        !           195: in ACCEPTABLE, or nil if something failed."
        !           196: 
        !           197:   ;; check legality of the arguments, then destructure them
        !           198:   (unless (and (listp argslist)
        !           199:                (evenp (length argslist)))
        !           200:     (error "Odd number of keyword-args"))
        !           201:   (unless (and (listp acceptable)
        !           202:                (every 'keywordp acceptable))
        !           203:     (error "Second arg should be a list of keywords"))
        !           204:   (multiple-value-bind
        !           205:       (keywords forms)
        !           206:       (unzip-list argslist)
        !           207:     (unless (every 'keywordp keywords)
        !           208:       (error "Expected keywords, found `%s'"
        !           209:              (prin1-to-string keywords)))
        !           210:     (do*                                ;pick up the pieces
        !           211:         ((auxlist                       ;auxiliary a-list, may
        !           212:           (pairlis keywords forms))     ;contain repetitions and junk
        !           213:          (ptr    acceptable  (cdr ptr)) ;pointer in acceptable
        !           214:          (this  (car ptr)  (car ptr))   ;current acceptable keyword
        !           215:          (auxval nil)                   ;used to move values around
        !           216:          (alist  '()))                  ;used to build the result
        !           217:         ((endp ptr) alist)
        !           218:       ;; if THIS appears in auxlist, use its value
        !           219:       (when (setq auxval (assoc this auxlist))
        !           220:         (setq alist (cons auxval alist))))))
        !           221: 
        !           222: 
        !           223: ;;; Checking that a list of symbols contains no duplicates is a common
        !           224: ;;; task when checking the legality of some macros.  The check for 'eq
        !           225: ;;; pairs can be too expensive, as it is quadratic on the length of
        !           226: ;;; the list.  I use a 4-pass, linear, counting approach.  It surely
        !           227: ;;; loses on small lists (less than 5 elements?), but should win for
        !           228: ;;; larger lists.  The fourth pass could be eliminated.
        !           229: ;;; 10 dec 1986.  Emacs Lisp has no REMPROP, so I just eliminated the
        !           230: ;;; 4th pass.
        !           231: (defun duplicate-symbols-p (list)
        !           232:   "Find all symbols appearing more than once in LIST.
        !           233: Return a list of all such duplicates; `nil' if there are no duplicates."
        !           234:   (let  ((duplicates '())               ;result built here
        !           235:          (propname   (gensym))          ;we use a fresh property
        !           236:          )
        !           237:     ;; check validity
        !           238:     (unless (and (listp list)
        !           239:                  (every 'symbolp list))
        !           240:       (error "A list of symbols is needed"))
        !           241:     ;; pass 1: mark
        !           242:     (dolist (x list)
        !           243:       (put x propname 0))
        !           244:     ;; pass 2: count
        !           245:     (dolist (x list)
        !           246:       (put x propname (1+ (get x propname))))
        !           247:     ;; pass 3: collect
        !           248:     (dolist (x list)
        !           249:       (if (> (get x propname) 1)
        !           250:           (setq duplicates (cons x duplicates))))
        !           251:     ;; pass 4: unmark.  eliminated.
        !           252:     ;; (dolist (x list) (remprop x propname))
        !           253:     ;; return result
        !           254:     duplicates))
        !           255: 
        !           256: ;;;; end of cl-global.el
        !           257: 
        !           258: ;;;; SYMBOLS
        !           259: ;;;;    This file provides the gentemp function, which generates fresh
        !           260: ;;;;    symbols, plus some other minor Common Lisp symbol tools.
        !           261: ;;;;
        !           262: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !           263: ;;;;       ([email protected])
        !           264: 
        !           265: ;;; Keywords.  There are no packages in Emacs Lisp, so this is only a
        !           266: ;;; kludge around to let things be "as if" a keyword package was around.
        !           267: 
        !           268: (defmacro defkeyword (x &optional docstring)
        !           269:   "Make symbol X a keyword (symbol whose value is itself).
        !           270: Optional second argument is a documentation string for it."
        !           271:   (cond
        !           272:    ((symbolp x)
        !           273:     (list 'defconst x (list 'quote x)))
        !           274:    (t
        !           275:     (error "`%s' is not a symbol" (prin1-to-string x)))))
        !           276: 
        !           277: (defun keywordp (sym)
        !           278:   "Return `t' if SYM is a keyword."
        !           279:   (cond
        !           280:    ((and (symbolp sym)
        !           281:          (char-equal (aref (symbol-name sym) 0) ?\:))
        !           282:     ;; looks like one, make sure value is right
        !           283:     (set sym sym))
        !           284:    (t
        !           285:     nil)))
        !           286: 
        !           287: (defun keyword-of (sym)
        !           288:   "Return a keyword that is naturally associated with symbol SYM.
        !           289: If SYM is keyword, the value is SYM.
        !           290: Otherwise it is a keyword whose name is `:' followed by SYM's name."
        !           291:   (cond
        !           292:    ((keywordp sym)
        !           293:     sym)
        !           294:    ((symbolp sym)
        !           295:     (let ((newsym (intern (concat ":" (symbol-name sym)))))
        !           296:       (set newsym newsym)))
        !           297:    (t
        !           298:     (error "Expected a symbol, not `%s'" (prin1-to-string sym)))))
        !           299: 
        !           300: ;;; Temporary symbols.  
        !           301: ;;; 
        !           302: 
        !           303: (defvar *gentemp-index* 0
        !           304:   "Integer used by gentemp to produce new names.")
        !           305: 
        !           306: (defvar *gentemp-prefix* "T$$_"
        !           307:   "Names generated by gentemp begin with this string by default.")
        !           308: 
        !           309: (defun gentemp (&optional prefix oblist)
        !           310:   "Generate a fresh interned symbol.
        !           311: There are 2 optional arguments, PREFIX and OBLIST.  PREFIX is the
        !           312: string that begins the new name, OBLIST is the obarray used to search for
        !           313: old names.  The defaults are just right, YOU SHOULD NEVER NEED THESE
        !           314: ARGUMENTS IN YOUR OWN CODE."
        !           315:   (if (null prefix)
        !           316:       (setq prefix *gentemp-prefix*))
        !           317:   (if (null oblist)
        !           318:       (setq oblist obarray))            ;default for the intern functions
        !           319:   (let ((newsymbol nil)
        !           320:         (newname))
        !           321:     (while (not newsymbol)
        !           322:       (setq newname (concat prefix *gentemp-index*))
        !           323:       (setq *gentemp-index* (+ *gentemp-index* 1))
        !           324:       (if (not (intern-soft newname oblist))
        !           325:           (setq newsymbol (intern newname oblist))))
        !           326:     newsymbol))
        !           327: 
        !           328: (defvar *gensym-index* 0
        !           329:   "Integer used by gensym to produce new names.")
        !           330: 
        !           331: (defvar *gensym-prefix* "G$$_"
        !           332:   "Names generated by gensym begin with this string by default.")
        !           333: 
        !           334: (defun gensym (&optional prefix)
        !           335:   "Generate a fresh uninterned symbol.
        !           336: There is an  optional argument, PREFIX.  PREFIX is the
        !           337: string that begins the new name. Most people take just the default,
        !           338: except when debugging needs suggest otherwise."
        !           339:   (if (null prefix)
        !           340:       (setq prefix *gensym-prefix*))
        !           341:   (let ((newsymbol nil)
        !           342:         (newname   ""))
        !           343:     (while (not newsymbol)
        !           344:       (setq newname (concat prefix *gensym-index*))
        !           345:       (setq *gensym-index* (+ *gensym-index* 1))
        !           346:       (if (not (intern-soft newname))
        !           347:           (setq newsymbol (make-symbol newname))))
        !           348:     newsymbol))
        !           349: 
        !           350: ;;;; end of cl-symbols.el
        !           351: 
        !           352: ;;;; CONDITIONALS
        !           353: ;;;;    This file provides some of the conditional constructs of
        !           354: ;;;;    Common Lisp.  Total compatibility is again impossible, as the
        !           355: ;;;;    'if' form is different in both languages, so only a good
        !           356: ;;;;    approximation is desired.
        !           357: ;;;;
        !           358: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !           359: ;;;;       ([email protected])
        !           360: 
        !           361: ;;; indentation info
        !           362: (put 'case      'lisp-indent-hook 1)
        !           363: (put 'ecase     'lisp-indent-hook 1)
        !           364: (put 'when      'lisp-indent-hook 1)
        !           365: (put 'unless    'lisp-indent-hook 1)
        !           366: 
        !           367: ;;; WHEN and UNLESS
        !           368: ;;; These two forms are simplified ifs, with a single branch.
        !           369: 
        !           370: (defmacro when (condition &rest body)
        !           371:   "(when CONDITION . BODY) => evaluate BODY if CONDITION is true."
        !           372:   (list* 'if (list 'not condition) '() body))
        !           373: 
        !           374: (defmacro unless (condition &rest body)
        !           375:   "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false."
        !           376:   (list* 'if condition '() body))
        !           377: 
        !           378: ;;; CASE and ECASE
        !           379: ;;; CASE selects among several clauses, based on the value (evaluated)
        !           380: ;;; of a expression and a list of (unevaluated) key values.  ECASE is
        !           381: ;;; the same, but signals an error if no clause is activated.
        !           382: 
        !           383: (defmacro case (expr &rest cases)
        !           384:   "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value.
        !           385: EXPR   -> any form
        !           386: CASES  -> list of clauses, non empty
        !           387: CLAUSE -> HEAD . BODY
        !           388: HEAD   -> t             = catch all, must be last clause
        !           389:        -> otherwise     = same as t
        !           390:        -> nil           = illegal
        !           391:        -> atom          = activated if (eql  EXPR HEAD)
        !           392:        -> list of atoms = activated if (member EXPR HEAD)
        !           393: BODY   -> list of forms, implicit PROGN is built around it.
        !           394: EXPR is evaluated only once."
        !           395:   (let* ((newsym (gentemp))
        !           396:          (clauses (case-clausify cases newsym)))
        !           397:     ;; convert case into a cond inside a let
        !           398:     (list 'let
        !           399:          (list (list newsym expr))
        !           400:          (list* 'cond (nreverse clauses)))))
        !           401: 
        !           402: (defmacro ecase (expr &rest cases)
        !           403:   "(ecase EXPR . CASES) => like `case', but error if no case fits.
        !           404: `t'-clauses are not allowed."
        !           405:   (let* ((newsym (gentemp))
        !           406:          (clauses (case-clausify cases newsym)))
        !           407:     ;; check that no 't clause is present.
        !           408:     ;; case-clausify would put one such at the beginning of clauses
        !           409:     (if (eq (caar clauses) t)
        !           410:         (error "No clause-head should be `t' or `otherwise' for `ecase'"))
        !           411:     ;; insert error-catching clause
        !           412:     (setq clauses
        !           413:           (cons
        !           414:            (list 't (list 'error
        !           415:                           "ecase on %s = %s failed to take any branch."
        !           416:                           (list 'quote expr)
        !           417:                           (list 'prin1-to-string newsym)))
        !           418:            clauses))
        !           419:     ;; generate code as usual
        !           420:     (list 'let
        !           421:           (list (list newsym expr))
        !           422:           (list* 'cond (nreverse clauses)))))
        !           423: 
        !           424: 
        !           425: (defun case-clausify (cases newsym)
        !           426:   "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond'
        !           427: Converts the CASES of a [e]case macro into cond clauses to be
        !           428: evaluated inside a let that binds NEWSYM.  Returns the clauses in
        !           429: reverse order."
        !           430:   (do* ((currentpos cases        (cdr currentpos))
        !           431:         (nextpos    (cdr cases)  (cdr nextpos))
        !           432:         (curclause  (car cases)  (car currentpos))
        !           433:         (result     '()))
        !           434:       ((endp currentpos) result)
        !           435:     (let ((head (car curclause))
        !           436:           (body (cdr curclause)))
        !           437:       ;; construct a cond-clause according to the head
        !           438:       (cond
        !           439:        ((null head)
        !           440:         (error "Case clauses cannot have null heads: `%s'"
        !           441:                (prin1-to-string curclause)))
        !           442:        ((or (eq head 't)
        !           443:             (eq head 'otherwise))
        !           444:         ;; check it is the last clause
        !           445:         (if (not (endp nextpos))
        !           446:             (error "Clause with `t' or `otherwise' head must be last"))
        !           447:         ;; accept this clause as a 't' for cond
        !           448:         (setq result (cons (cons 't body) result)))
        !           449:        ((atom head)
        !           450:         (setq result
        !           451:               (cons (cons (list 'eql newsym (list 'quote head)) body)
        !           452:                     result)))
        !           453:        ((listp head)
        !           454:         (setq result
        !           455:               (cons (cons (list 'member newsym (list 'quote head)) body)
        !           456:                     result)))
        !           457:        (t
        !           458:         ;; catch-all for this parser
        !           459:         (error "Don't know how to parse case clause `%s'."
        !           460:                (prin1-to-string head)))))))
        !           461: 
        !           462: ;;;; end of cl-conditionals.el
        !           463: 
        !           464: ;;;; ITERATIONS
        !           465: ;;;;    This file provides simple iterative macros (a la Common Lisp)
        !           466: ;;;;    constructed on the basis of let, let* and while, which are the
        !           467: ;;;;    primitive binding/iteration constructs of Emacs Lisp
        !           468: ;;;;
        !           469: ;;;;    The Common Lisp iterations use to have a block named nil
        !           470: ;;;;    wrapped around them, and allow declarations at the beginning
        !           471: ;;;;    of their bodies and you can return a value using (return ...).
        !           472: ;;;;    Nothing of the sort exists in Emacs Lisp, so I haven't tried
        !           473: ;;;;    to imitate these behaviors.
        !           474: ;;;;
        !           475: ;;;;    Other than the above, the semantics of Common Lisp are
        !           476: ;;;;    correctly reproduced to the extent this was reasonable.
        !           477: ;;;;
        !           478: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !           479: ;;;;       ([email protected])
        !           480: 
        !           481: ;;; some lisp-indentation information
        !           482: (put 'do                'lisp-indent-hook 2)
        !           483: (put 'do*               'lisp-indent-hook 2)
        !           484: (put 'dolist            'lisp-indent-hook 1)
        !           485: (put 'dotimes           'lisp-indent-hook 1)
        !           486: (put 'do-symbols        'lisp-indent-hook 1)
        !           487: (put 'do-all-symbols    'lisp-indent-hook 1)
        !           488: 
        !           489: 
        !           490: (defmacro do (stepforms endforms &rest body)
        !           491:   "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables.
        !           492: STEPFORMS must be a list of symbols or lists.  In the second case, the
        !           493: lists must start with a symbol and contain up to two more forms. In
        !           494: the STEPFORMS, a symbol is the same as a (symbol).  The other 2 forms
        !           495: are the initial value (def. NIL) and the form to step (def. itself).
        !           496: The values used by initialization and stepping are computed in parallel.
        !           497: The ENDFORMS are a list (CONDITION . ENDBODY).  If the CONDITION
        !           498: evaluates to true in any iteration, ENDBODY is evaluated and the last
        !           499: form in it is returned.
        !           500: The BODY (which may be empty) is evaluated at every iteration, with
        !           501: the symbols of the STEPFORMS bound to the initial or stepped values."
        !           502:   ;; check the syntax of the macro
        !           503:   (and (check-do-stepforms stepforms)
        !           504:        (check-do-endforms endforms))
        !           505:   ;; construct emacs-lisp equivalent
        !           506:   (let ((initlist (extract-do-inits stepforms))
        !           507:         (steplist (extract-do-steps stepforms))
        !           508:         (endcond  (car endforms))
        !           509:         (endbody  (cdr endforms)))
        !           510:     (cons 'let (cons initlist
        !           511:                      (cons (cons 'while (cons (list 'not endcond) 
        !           512:                                               (append body steplist)))
        !           513:                            (append endbody))))))
        !           514: 
        !           515: 
        !           516: (defmacro do* (stepforms endforms &rest body)
        !           517:   "`do*' is to `do' as `let*' is to `let'.
        !           518: STEPFORMS must be a list of symbols or lists.  In the second case, the
        !           519: lists must start with a symbol and contain up to two more forms. In
        !           520: the STEPFORMS, a symbol is the same as a (symbol).  The other 2 forms
        !           521: are the initial value (def. NIL) and the form to step (def. itself).
        !           522: Initializations and steppings are done in the sequence they are written.
        !           523: The ENDFORMS are a list (CONDITION . ENDBODY).  If the CONDITION
        !           524: evaluates to true in any iteration, ENDBODY is evaluated and the last
        !           525: form in it is returned.
        !           526: The BODY (which may be empty) is evaluated at every iteration, with
        !           527: the symbols of the STEPFORMS bound to the initial or stepped values."
        !           528:   ;; check the syntax of the macro
        !           529:   (and (check-do-stepforms stepforms)
        !           530:        (check-do-endforms endforms))
        !           531:   ;; construct emacs-lisp equivalent
        !           532:   (let ((initlist (extract-do-inits stepforms))
        !           533:         (steplist (extract-do*-steps stepforms))
        !           534:         (endcond  (car endforms))
        !           535:         (endbody  (cdr endforms)))
        !           536:     (cons 'let* (cons initlist
        !           537:                      (cons (cons 'while (cons (list 'not endcond) 
        !           538:                                               (append body steplist)))
        !           539:                            (append endbody))))))
        !           540: 
        !           541: 
        !           542: ;;; DO and DO* share the syntax checking functions that follow.
        !           543: 
        !           544: (defun check-do-stepforms (forms)
        !           545:   "True if FORMS is a valid stepforms for the do[*] macro (q.v.)"
        !           546:   (cond
        !           547:    ((nlistp forms)
        !           548:     (error "Init/Step form for do[*] should be a list, not `%s'"
        !           549:            (prin1-to-string forms)))
        !           550:    (t                                   ;valid list
        !           551:     ;; each entry must be a symbol, or a list whose car is a symbol
        !           552:     ;; and whose length is no more than three
        !           553:     (mapcar
        !           554:      (function
        !           555:       (lambda (entry)
        !           556:         (cond
        !           557:          ((or (symbolp entry)
        !           558:               (and (listp entry)
        !           559:                    (symbolp (car entry))
        !           560:                    (< (length entry) 4)))
        !           561:           t)
        !           562:          (t
        !           563:           (error
        !           564:            "Init/Step must be symbol or (symbol [init [step]]), not `%s'"
        !           565:            (prin1-to-string entry))))))
        !           566:      forms))))
        !           567: 
        !           568: (defun check-do-endforms (forms)
        !           569:   "True if FORMS is a valid endforms for the do[*] macro (q.v.)"
        !           570:   (cond
        !           571:    ((listp forms)
        !           572:     t)
        !           573:    (t
        !           574:     (error "Termination form for do macro should be a list, not `%s'"
        !           575:            (prin1-to-string forms)))))
        !           576: 
        !           577: (defun extract-do-inits (forms)
        !           578:   "Returns a list of the initializations (for do) in FORMS
        !           579: -a stepforms, see the do macro-. Forms is assumed syntactically valid."
        !           580:   (mapcar
        !           581:    (function
        !           582:     (lambda (entry)
        !           583:       (cond
        !           584:        ((symbolp entry)
        !           585:         (list entry nil))
        !           586:        ((listp entry)
        !           587:         (list (car entry) (cadr entry))))))
        !           588:    forms))
        !           589: 
        !           590: ;;; There used to be a reason to deal with DO differently than with
        !           591: ;;; DO*.  The writing of PSETQ has made it largely unnecessary.
        !           592: 
        !           593: (defun extract-do-steps (forms)
        !           594:   "EXTRACT-DO-STEPS FORMS => an s-expr
        !           595: FORMS is the stepforms part of a DO macro (q.v.).  This function
        !           596: constructs an s-expression that does the stepping at the end of an
        !           597: iteration."
        !           598:   (list (cons 'psetq (select-stepping-forms forms))))
        !           599: 
        !           600: (defun extract-do*-steps (forms)
        !           601:   "EXTRACT-DO*-STEPS FORMS => an s-expr
        !           602: FORMS is the stepforms part of a DO* macro (q.v.).  This function
        !           603: constructs an s-expression that does the stepping at the end of an
        !           604: iteration."
        !           605:   (list (cons 'setq (select-stepping-forms forms))))
        !           606: 
        !           607: (defun select-stepping-forms (forms)
        !           608:   "Separate only the forms that cause stepping."
        !           609:   (let ((result '())                   ;ends up being (... var form ...)
        !           610:        (ptr forms)                     ;to traverse the forms
        !           611:        entry                           ;to explore each form in turn
        !           612:        )
        !           613:     (while ptr                         ;(not (endp entry)) might be safer
        !           614:       (setq entry (car ptr))
        !           615:       (cond
        !           616:        ((and (listp entry)
        !           617:             (= (length entry) 3))
        !           618:        (setq result (append            ;append in reverse order!
        !           619:                      (list (caddr entry) (car entry))
        !           620:                      result))))
        !           621:       (setq ptr (cdr ptr)))            ;step in the list of forms
        !           622:     ;;put things back in the
        !           623:     ;;correct order before return
        !           624:     (nreverse result)))
        !           625: 
        !           626: ;;; Other iterative constructs
        !           627: 
        !           628: (defmacro dolist  (stepform &rest body)
        !           629:   "(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST.
        !           630: The RESULTFORM defaults to nil.  The VAR is bound to successive
        !           631: elements of the value of LIST and remains bound (to the nil value) when the
        !           632: RESULTFORM is evaluated."
        !           633:   ;; check sanity
        !           634:   (cond
        !           635:    ((nlistp stepform)
        !           636:     (error "Stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'"
        !           637:            (prin1-to-string stepform)))
        !           638:    ((not (symbolp (car stepform)))
        !           639:     (error "First component of stepform should be a symbol, not `%s'"
        !           640:            (prin1-to-string (car stepform))))
        !           641:    ((> (length stepform) 3)
        !           642:     (error "Too many components in stepform `%s'"
        !           643:            (prin1-to-string stepform))))
        !           644:   ;; generate code
        !           645:   (let* ((var (car stepform))
        !           646:          (listform (cadr stepform))
        !           647:          (resultform (caddr stepform)))
        !           648:     (list 'progn
        !           649:           (list 'mapcar
        !           650:                 (list 'function
        !           651:                       (cons 'lambda (cons (list var) body)))
        !           652:                 listform)
        !           653:           (list 'let
        !           654:                 (list (list var nil))
        !           655:                 resultform))))
        !           656: 
        !           657: (defmacro dotimes (stepform &rest body)
        !           658:   "(dotimes (VAR COUNTFORM [RESULTFORM]) .  BODY): Repeat BODY, counting in VAR.
        !           659: The COUNTFORM should return a positive integer.  The VAR is bound to
        !           660: successive integers from 0 to COUNTFORM-1 and the BODY is repeated for
        !           661: each of them.  At the end, the RESULTFORM is evaluated and its value
        !           662: returned. During this last evaluation, the VAR is still bound, and its
        !           663: value is the number of times the iteration occurred. An omitted RESULTFORM
        !           664: defaults to nil."
        !           665:   ;; check sanity 
        !           666:   (cond
        !           667:    ((nlistp stepform)
        !           668:     (error "Stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'"
        !           669:            (prin1-to-string stepform)))
        !           670:    ((not (symbolp (car stepform)))
        !           671:     (error "First component of stepform should be a symbol, not `%s'"
        !           672:            (prin1-to-string (car stepform))))
        !           673:    ((> (length stepform) 3)
        !           674:     (error "Too many components in stepform `%s'"
        !           675:            (prin1-to-string stepform))))
        !           676:   ;; generate code
        !           677:   (let* ((var (car stepform))
        !           678:          (countform (cadr stepform))
        !           679:          (resultform (caddr stepform))
        !           680:          (newsym (gentemp)))
        !           681:     (list
        !           682:      'let* (list (list newsym countform))
        !           683:      (list*
        !           684:       'do*
        !           685:       (list (list var 0 (list '+ var 1)))
        !           686:       (list (list '>= var newsym) resultform)
        !           687:       body))))
        !           688: 
        !           689: (defmacro do-symbols (stepform &rest body)
        !           690:   "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY)
        !           691: The VAR is bound to each of the symbols in OBARRAY (def. obarray) and
        !           692: the BODY is repeatedly performed for each of those bindings. At the
        !           693: end, RESULTFORM (def. nil) is evaluated and its value returned.
        !           694: During this last evaluation, the VAR is still bound and its value is nil.
        !           695: See also the function `mapatoms'."
        !           696:   ;; check sanity
        !           697:   (cond
        !           698:    ((nlistp stepform)
        !           699:     (error "Stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'"
        !           700:            (prin1-to-string stepform)))
        !           701:    ((not (symbolp (car stepform)))
        !           702:     (error "First component of stepform should be a symbol, not `%s'"
        !           703:            (prin1-to-string (car stepform))))
        !           704:    ((> (length stepform) 3)
        !           705:     (error "Too many components in stepform `%s'"
        !           706:            (prin1-to-string stepform))))
        !           707:   ;; generate code
        !           708:   (let* ((var (car stepform))
        !           709:          (oblist (cadr stepform))
        !           710:          (resultform (caddr stepform)))
        !           711:     (list 'progn
        !           712:           (list 'mapatoms
        !           713:                 (list 'function
        !           714:                       (cons 'lambda (cons (list var) body)))
        !           715:                 oblist)
        !           716:           (list 'let
        !           717:                 (list (list var nil))
        !           718:                 resultform))))
        !           719: 
        !           720: 
        !           721: (defmacro do-all-symbols (stepform &rest body)
        !           722:   "(do-all-symbols (VAR [RESULTFORM]) . BODY)
        !           723: Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)."
        !           724:   (list*
        !           725:    'do-symbols
        !           726:    (list (car stepform) 'obarray (cadr stepform))
        !           727:    body))
        !           728: 
        !           729: (defmacro loop (&rest body)
        !           730:   "(loop . BODY) repeats BODY indefinitely and does not return.
        !           731: Normally BODY uses `throw' or `signal' to cause an exit.
        !           732: The forms in BODY should be lists, as non-lists are reserved for new features."
        !           733:   ;; check that the body doesn't have atomic forms
        !           734:   (if (nlistp body)
        !           735:       (error "Body of `loop' should be a list of lists or nil")
        !           736:     ;; ok, it is a list, check for atomic components
        !           737:     (mapcar
        !           738:      (function (lambda (component)
        !           739:                  (if (nlistp component)
        !           740:                      (error "Components of `loop' should be lists"))))
        !           741:      body)
        !           742:     ;; build the infinite loop
        !           743:     (cons 'while (cons 't body))))
        !           744: 
        !           745: ;;;; end of cl-iterations.el
        !           746: 
        !           747: ;;;; LISTS
        !           748: ;;;;    This file provides some of the lists machinery of Common-Lisp
        !           749: ;;;;    in a way compatible with Emacs Lisp.  Especially, see the the
        !           750: ;;;;    typical c[ad]*r functions.
        !           751: ;;;;
        !           752: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !           753: ;;;;       ([email protected])
        !           754: 
        !           755: 
        !           756: 
        !           757: ;;; Synonyms for list functions
        !           758: (defun first (x)
        !           759:   "Synonym for `car'"
        !           760:   (car x))
        !           761: 
        !           762: (defun second (x)
        !           763:   "Return the second element of the list LIST."
        !           764:   (nth 1 x))
        !           765: 
        !           766: (defun third (x)
        !           767:   "Return the third element of the list LIST."
        !           768:   (nth 2 x))
        !           769: 
        !           770: (defun fourth (x)
        !           771:   "Return the fourth element of the list LIST."
        !           772:   (nth 3 x))
        !           773: 
        !           774: (defun fifth (x)
        !           775:   "Return the fifth element of the list LIST."
        !           776:   (nth 4 x))
        !           777: 
        !           778: (defun sixth (x)
        !           779:   "Return the sixth element of the list LIST."
        !           780:   (nth 5 x))
        !           781: 
        !           782: (defun seventh (x)
        !           783:   "Return the seventh element of the list LIST."
        !           784:   (nth 6 x))
        !           785: 
        !           786: (defun eighth (x)
        !           787:   "Return the eighth element of the list LIST."
        !           788:   (nth 7 x))
        !           789: 
        !           790: (defun ninth (x)
        !           791:   "Return the ninth element of the list LIST."
        !           792:   (nth 8 x))
        !           793: 
        !           794: (defun tenth (x)
        !           795:   "Return the tenth element of the list LIST."
        !           796:   (nth 9 x))
        !           797: 
        !           798: (defun rest (x)
        !           799:   "Synonym for `cdr'"
        !           800:   (cdr x))
        !           801: 
        !           802: (defun endp (x)
        !           803:   "t if X is nil, nil if X is a cons; error otherwise."
        !           804:   (if (listp x)
        !           805:       (null x)
        !           806:     (error "endp received a non-cons, non-null argument `%s'"
        !           807:           (prin1-to-string x))))
        !           808: 
        !           809: (defun last (x)
        !           810:   "Returns the last link in the list LIST."
        !           811:   (if (nlistp x)
        !           812:       (error "Arg to `last' must be a list"))
        !           813:   (do ((current-cons    x       (cdr current-cons))
        !           814:        (next-cons    (cdr x)    (cdr next-cons)))
        !           815:       ((endp next-cons) current-cons)))
        !           816: 
        !           817: (defun list-length (x)                  ;taken from CLtL sect. 15.2
        !           818:   "Returns the length of a non-circular list, or `nil' for a circular one."
        !           819:   (do ((n 0)                            ;counter
        !           820:        (fast x (cddr fast))             ;fast pointer, leaps by 2
        !           821:        (slow x (cdr slow))              ;slow pointer, leaps by 1
        !           822:        (ready nil))                     ;indicates termination
        !           823:       (ready n)
        !           824:     (cond
        !           825:      ((endp fast)
        !           826:       (setq ready t))                   ;return n
        !           827:      ((endp (cdr fast))
        !           828:       (setq n (+ n 1))
        !           829:       (setq ready t))                   ;return n+1
        !           830:      ((and (eq fast slow) (> n 0))
        !           831:       (setq n nil)
        !           832:       (setq ready t))                   ;return nil
        !           833:      (t
        !           834:       (setq n (+ n 2))))))              ;just advance counter
        !           835: 
        !           836: (defun member (item list)
        !           837:   "Look for ITEM in LIST; return first link in LIST whose car is `eql' to ITEM."
        !           838:   (let ((ptr list)
        !           839:         (done nil)
        !           840:         (result '()))
        !           841:     (while (not (or done (endp ptr)))
        !           842:       (cond ((eql item (car ptr))
        !           843:              (setq done t)
        !           844:              (setq result ptr)))
        !           845:       (setq ptr (cdr ptr)))
        !           846:     result))
        !           847: 
        !           848: (defun butlast (list &optional n)
        !           849:   "Return a new list like LIST but sans the last N elements.
        !           850: N defaults to 1.  If the list doesn't have N elements, nil is returned."
        !           851:   (if (null n) (setq n 1))
        !           852:   (reverse (nthcdr n (reverse list))))
        !           853: 
        !           854: (defun list* (arg &rest others)
        !           855:   "Return a new list containing the first arguments consed onto the last arg.
        !           856: Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)."
        !           857:   (if (null others)
        !           858:       arg
        !           859:     (let* ((allargs (cons arg others))
        !           860:            (front   (butlast allargs))
        !           861:            (back    (last allargs)))
        !           862:       (rplacd (last front) (car back))
        !           863:       front)))
        !           864: 
        !           865: (defun adjoin (item list)
        !           866:   "Return a list which contains ITEM but is otherwise like LIST.
        !           867: If ITEM occurs in LIST, the value is LIST.  Otherwise it is (cons ITEM LIST).
        !           868: When comparing ITEM against elements, `eql' is used."
        !           869:   (cond
        !           870:    ((member item list)
        !           871:     list)
        !           872:    (t
        !           873:     (cons item list))))
        !           874: 
        !           875: (defun ldiff (list sublist)
        !           876:   "Return a new list like LIST but sans SUBLIST.
        !           877: SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
        !           878:   (do ((result '())
        !           879:        (curcons list (cdr curcons)))
        !           880:       ((or (endp curcons) (eq curcons sublist))
        !           881:        (reverse result))
        !           882:     (setq result (cons (car curcons) result))))
        !           883: 
        !           884: ;;; The popular c[ad]*r functions.
        !           885: 
        !           886: (defun caar (X)
        !           887:   "Return the car of the car of X."
        !           888:   (car (car X)))
        !           889: 
        !           890: (defun cadr (X)
        !           891:   "Return the car of the cdr of X."
        !           892:   (car (cdr X)))
        !           893: 
        !           894: (defun cdar (X)
        !           895:   "Return the cdr of the car of X."
        !           896:   (cdr (car X)))
        !           897: 
        !           898: (defun cddr (X)
        !           899:   "Return the cdr of the cdr of X."
        !           900:   (cdr (cdr X)))
        !           901: 
        !           902: (defun caaar (X)
        !           903:   "Return the car of the car of the car of X."
        !           904:   (car (car (car X))))
        !           905: 
        !           906: (defun caadr (X)
        !           907:   "Return the car of the car of the cdr of X."
        !           908:   (car (car (cdr X))))
        !           909: 
        !           910: (defun cadar (X)
        !           911:   "Return the car of the cdr of the car of X."
        !           912:   (car (cdr (car X))))
        !           913: 
        !           914: (defun cdaar (X)
        !           915:   "Return the cdr of the car of the car of X."
        !           916:   (cdr (car (car X))))
        !           917: 
        !           918: (defun caddr (X)
        !           919:   "Return the car of the cdr of the cdr of X."
        !           920:   (car (cdr (cdr X))))
        !           921: 
        !           922: (defun cdadr (X)
        !           923:   "Return the cdr of the car of the cdr of X."
        !           924:   (cdr (car (cdr X))))
        !           925: 
        !           926: (defun cddar (X)
        !           927:   "Return the cdr of the cdr of the car of X."
        !           928:   (cdr (cdr (car X))))
        !           929: 
        !           930: (defun cdddr (X)
        !           931:   "Return the cdr of the cdr of the cdr of X."
        !           932:   (cdr (cdr (cdr X))))
        !           933: 
        !           934: (defun caaaar (X)
        !           935:   "Return the car of the car of the car of the car of X."
        !           936:   (car (car (car (car X)))))
        !           937: 
        !           938: (defun caaadr (X)
        !           939:   "Return the car of the car of the car of the cdr of X."
        !           940:   (car (car (car (cdr X)))))
        !           941: 
        !           942: (defun caadar (X)
        !           943:   "Return the car of the car of the cdr of the car of X."
        !           944:   (car (car (cdr (car X)))))
        !           945: 
        !           946: (defun cadaar (X)
        !           947:   "Return the car of the cdr of the car of the car of X."
        !           948:   (car (cdr (car (car X)))))
        !           949: 
        !           950: (defun cdaaar (X)
        !           951:   "Return the cdr of the car of the car of the car of X."
        !           952:   (cdr (car (car (car X)))))
        !           953: 
        !           954: (defun caaddr (X)
        !           955:   "Return the car of the car of the cdr of the cdr of X."
        !           956:   (car (car (cdr (cdr X)))))
        !           957: 
        !           958: (defun cadadr (X)
        !           959:   "Return the car of the cdr of the car of the cdr of X."
        !           960:   (car (cdr (car (cdr X)))))
        !           961: 
        !           962: (defun cdaadr (X)
        !           963:   "Return the cdr of the car of the car of the cdr of X."
        !           964:   (cdr (car (car (cdr X)))))
        !           965: 
        !           966: (defun caddar (X)
        !           967:   "Return the car of the cdr of the cdr of the car of X."
        !           968:   (car (cdr (cdr (car X)))))
        !           969: 
        !           970: (defun cdadar (X)
        !           971:   "Return the cdr of the car of the cdr of the car of X."
        !           972:   (cdr (car (cdr (car X)))))
        !           973: 
        !           974: (defun cddaar (X)
        !           975:   "Return the cdr of the cdr of the car of the car of X."
        !           976:   (cdr (cdr (car (car X)))))
        !           977: 
        !           978: (defun cadddr (X)
        !           979:   "Return the car of the cdr of the cdr of the cdr of X."
        !           980:   (car (cdr (cdr (cdr X)))))
        !           981: 
        !           982: (defun cddadr (X)
        !           983:   "Return the cdr of the cdr of the car of the cdr of X."
        !           984:   (cdr (cdr (car (cdr X)))))
        !           985: 
        !           986: (defun cdaddr (X)
        !           987:   "Return the cdr of the car of the cdr of the cdr of X."
        !           988:   (cdr (car (cdr (cdr X)))))
        !           989: 
        !           990: (defun cdddar (X)
        !           991:   "Return the cdr of the cdr of the cdr of the car of X."
        !           992:   (cdr (cdr (cdr (car X)))))
        !           993: 
        !           994: (defun cddddr (X)
        !           995:   "Return the cdr of the cdr of the cdr of the cdr of X."
        !           996:   (cdr (cdr (cdr (cdr X)))))
        !           997: 
        !           998: ;;; some inverses of the accessors are needed for setf purposes
        !           999: 
        !          1000: (defun setnth (n list newval)
        !          1001:   "Set (nth N LIST) to NEWVAL.  Returns NEWVAL."
        !          1002:   (rplaca (nthcdr n list) newval))
        !          1003: 
        !          1004: (defun setnthcdr (n list newval)
        !          1005:   "SETNTHCDR N LIST NEWVAL => NEWVAL
        !          1006: As a side effect, sets the Nth cdr of LIST to NEWVAL."
        !          1007:   (cond
        !          1008:    ((< n 0)
        !          1009:     (error "N must be 0 or greater, not %d" n))
        !          1010:    ((= n 0)
        !          1011:     (rplaca list (car newval))
        !          1012:     (rplacd list (cdr newval))
        !          1013:     newval)
        !          1014:    (t
        !          1015:     (rplacd (nthcdr (- n 1) list) newval))))
        !          1016: 
        !          1017: ;;; A-lists machinery
        !          1018: 
        !          1019: (defun acons (key item alist)
        !          1020:   "Return a new alist with KEY paired with ITEM; otherwise like ALIST.
        !          1021: Does not copy ALIST."
        !          1022:   (cons (cons key item) alist))
        !          1023: 
        !          1024: (defun pairlis (keys data &optional alist)
        !          1025:   "Return a new alist with each elt of KEYS paired with an elt of DATA;
        !          1026: optional 3rd arg ALIST is nconc'd at the end.  KEYS and DATA must
        !          1027: have the same length."
        !          1028:   (unless (= (length keys) (length data))
        !          1029:     (error "Keys and data should be the same length"))
        !          1030:   (do* ;;collect keys and data in front of alist
        !          1031:       ((kptr keys (cdr kptr))           ;traverses the keys
        !          1032:        (dptr data (cdr dptr))           ;traverses the data
        !          1033:        (key (car kptr) (car kptr))      ;current key
        !          1034:        (item (car dptr) (car dptr))     ;current data item
        !          1035:        (result alist))
        !          1036:       ((endp kptr) result)
        !          1037:     (setq result (acons key item result))))
        !          1038: 
        !          1039: ;;;; end of cl-lists.el
        !          1040: 
        !          1041: ;;;; SEQUENCES
        !          1042: ;;;; Emacs Lisp provides many of the 'sequences' functionality of
        !          1043: ;;;; Common Lisp.  This file provides a few things that were left out.
        !          1044: ;;;; 
        !          1045: 
        !          1046: 
        !          1047: (defkeyword :test      "Used to designate positive (selection) tests.")
        !          1048: (defkeyword :test-not  "Used to designate negative (rejection) tests.")
        !          1049: (defkeyword :key       "Used to designate component extractions.")
        !          1050: (defkeyword :predicate "Used to define matching of sequence components.")
        !          1051: (defkeyword :start     "Inclusive low index in sequence")
        !          1052: (defkeyword :end       "Exclusive high index in sequence")
        !          1053: (defkeyword :start1    "Inclusive low index in first of two sequences.")
        !          1054: (defkeyword :start2    "Inclusive low index in second of two sequences.")
        !          1055: (defkeyword :end1      "Exclusive high index in first of two sequences.")
        !          1056: (defkeyword :end2      "Exclusive high index in second of two sequences.")
        !          1057: (defkeyword :count     "Number of elements to affect.")
        !          1058: (defkeyword :from-end  "T when counting backwards.")
        !          1059: 
        !          1060: (defun some     (pred seq &rest moreseqs)
        !          1061:   "Test PREDICATE on each element of SEQUENCE; is it ever non-nil?
        !          1062: Extra args are additional sequences; PREDICATE gets one arg from each
        !          1063: sequence and we advance down all the sequences together in lock-step.
        !          1064: A sequence means either a list or a vector."
        !          1065:   (let ((args  (reassemble-argslists (list* seq moreseqs))))
        !          1066:     (do* ((ready nil)                   ;flag: return when t
        !          1067:           (result nil)                  ;resulting value
        !          1068:           (applyval nil)                ;result of applying pred once
        !          1069:           (remaining args
        !          1070:                      (cdr remaining))   ;remaining argument sets
        !          1071:           (current (car remaining)      ;current argument set
        !          1072:                    (car remaining)))
        !          1073:         ((or ready (endp remaining)) result)
        !          1074:       (setq applyval (apply pred current))
        !          1075:       (when applyval
        !          1076:         (setq ready t)
        !          1077:         (setq result applyval)))))
        !          1078: 
        !          1079: (defun every    (pred seq &rest moreseqs)
        !          1080:   "Test PREDICATE on each element of SEQUENCE; is it always non-nil?
        !          1081: Extra args are additional sequences; PREDICATE gets one arg from each
        !          1082: sequence and we advance down all the sequences together in lock-step.
        !          1083: A sequence means either a list or a vector."
        !          1084:   (let ((args  (reassemble-argslists (list* seq moreseqs))))
        !          1085:     (do* ((ready nil)                   ;flag: return when t
        !          1086:           (result t)                    ;resulting value
        !          1087:           (applyval nil)                ;result of applying pred once
        !          1088:           (remaining args
        !          1089:                      (cdr remaining))   ;remaining argument sets
        !          1090:           (current (car remaining)      ;current argument set
        !          1091:                    (car remaining)))
        !          1092:         ((or ready (endp remaining)) result)
        !          1093:       (setq applyval (apply pred current))
        !          1094:       (unless applyval
        !          1095:         (setq ready t)
        !          1096:         (setq result nil)))))
        !          1097: 
        !          1098: (defun notany   (pred seq &rest moreseqs)
        !          1099:   "Test PREDICATE on each element of SEQUENCE; is it always nil?
        !          1100: Extra args are additional sequences; PREDICATE gets one arg from each
        !          1101: sequence and we advance down all the sequences together in lock-step.
        !          1102: A sequence means either a list or a vector."
        !          1103:   (let ((args  (reassemble-argslists (list* seq moreseqs))))
        !          1104:     (do* ((ready nil)                   ;flag: return when t
        !          1105:           (result t)                    ;resulting value
        !          1106:           (applyval nil)                ;result of applying pred once
        !          1107:           (remaining args
        !          1108:                      (cdr remaining))   ;remaining argument sets
        !          1109:           (current (car remaining)      ;current argument set
        !          1110:                    (car remaining)))
        !          1111:         ((or ready (endp remaining)) result)
        !          1112:       (setq applyval (apply pred current))
        !          1113:       (when applyval
        !          1114:         (setq ready t)
        !          1115:         (setq result nil)))))
        !          1116: 
        !          1117: (defun notevery (pred seq &rest moreseqs)
        !          1118:   "Test PREDICATE on each element of SEQUENCE; is it sometimes nil?
        !          1119: Extra args are additional sequences; PREDICATE gets one arg from each
        !          1120: sequence and we advance down all the sequences together in lock-step.
        !          1121: A sequence means either a list or a vector."
        !          1122:   (let ((args  (reassemble-argslists (list* seq moreseqs))))
        !          1123:     (do* ((ready nil)                   ;flag: return when t
        !          1124:           (result nil)                  ;resulting value
        !          1125:           (applyval nil)                ;result of applying pred once
        !          1126:           (remaining args
        !          1127:                      (cdr remaining))   ;remaining argument sets
        !          1128:           (current (car remaining)      ;current argument set
        !          1129:                    (car remaining)))
        !          1130:         ((or ready (endp remaining)) result)
        !          1131:       (setq applyval (apply pred current))
        !          1132:       (unless applyval
        !          1133:         (setq ready t)
        !          1134:         (setq result t)))))
        !          1135: 
        !          1136: 
        !          1137: 
        !          1138: ;;; an inverse of elt is needed for setf purposes
        !          1139: 
        !          1140: (defun setelt (seq n newval)
        !          1141:   "In SEQUENCE, set the Nth element to NEWVAL.  Returns NEWVAL.
        !          1142: A sequence means either a list or a vector."
        !          1143:   (let ((l (length seq)))
        !          1144:     (cond
        !          1145:      ((or (< n 0)
        !          1146:           (>= n l))
        !          1147:       (error "N(%d) should be between 0 and %d" n l))
        !          1148:      (t
        !          1149:       ;; only two cases need be considered
        !          1150:       (cond
        !          1151:        ((listp seq)
        !          1152:         (setnth n seq newval))
        !          1153:        ((arrayp seq)
        !          1154:         (aset seq n newval))
        !          1155:        (t
        !          1156:         (error "SEQ should be a sequence, not `%s'"
        !          1157:                (prin1-to-string seq))))))))
        !          1158: 
        !          1159: ;;; Testing with keyword arguments.
        !          1160: ;;;
        !          1161: ;;; Many of the sequence functions use keywords to denote some stylized
        !          1162: ;;; form of selecting entries in a sequence.  The involved arguments
        !          1163: ;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key
        !          1164: ;;; marker), then they are passed to build-klist, who
        !          1165: ;;; constructs an association list.  That association list is used to
        !          1166: ;;; test for satisfaction and matching.
        !          1167: 
        !          1168: (defun extract-from-klist (key klist &optional default)
        !          1169:   "EXTRACT-FROM-KLIST KEY KLIST [DEFAULT] => value of KEY or DEFAULT
        !          1170: Extract value associated with KEY in KLIST (return DEFAULT if nil)."
        !          1171:   (let ((retrieved (cdr (assoc key klist))))
        !          1172:     (or retrieved default)))
        !          1173: 
        !          1174: (defun add-to-klist (key item klist)
        !          1175:   "ADD-TO-KLIST KEY ITEM KLIST => new KLIST
        !          1176: Add association (KEY . ITEM) to KLIST."
        !          1177:   (setq klist (acons key item klist)))
        !          1178: 
        !          1179: (defun elt-satisfies-test-p (item elt klist)
        !          1180:   "ELT-SATISFIES-TEST-P ITEM ELT KLIST => t or nil
        !          1181: KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
        !          1182: True if the given ITEM and ELT satisfy the test."
        !          1183:   (let ((test     (extract-from-klist :test klist))
        !          1184:         (test-not (extract-from-klist :test-not klist))
        !          1185:         (keyfn    (extract-from-klist :key klist 'identity)))
        !          1186:     (cond
        !          1187:      (test
        !          1188:       (funcall test item (funcall keyfn elt)))
        !          1189:      (test-not
        !          1190:       (not (funcall test-not item (funcall keyfn elt))))
        !          1191:      (t                                 ;should never happen
        !          1192:       (error "Neither :test nor :test-not in `%s'"
        !          1193:              (prin1-to-string klist))))))
        !          1194: 
        !          1195: (defun elt-satisfies-if-p   (item klist)
        !          1196:   "ELT-SATISFIES-IF-P ITEM KLIST => t or nil
        !          1197: True if an -if style function was called and ITEM satisfies the
        !          1198: predicate under :predicate in KLIST."
        !          1199:   (let ((predicate (extract-from-klist :predicate klist))
        !          1200:         (keyfn     (extract-from-klist :key 'identity)))
        !          1201:     (funcall predicate item (funcall keyfn elt))))
        !          1202: 
        !          1203: (defun elt-satisfies-if-not-p (item klist)
        !          1204:   "ELT-SATISFIES-IF-NOT-P ITEM KLIST => t or nil
        !          1205: KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
        !          1206: True if an -if-not style function was called and ITEM does not satisfy
        !          1207: the predicate under :predicate in KLIST."
        !          1208:   (let ((predicate (extract-from-klist :predicate klist))
        !          1209:         (keyfn     (extract-from-klist :key 'identity)))
        !          1210:     (not (funcall predicate item (funcall keyfn elt)))))
        !          1211: 
        !          1212: (defun elts-match-under-klist-p (e1 e2 klist)
        !          1213:   "ELTS-MATCH-UNDER-KLIST-P E1 E2 KLIST => t or nil
        !          1214: KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
        !          1215: True if elements E1 and E2 match under the tests encoded in KLIST."
        !          1216:   (let ((test     (extract-from-klist :test klist))
        !          1217:         (test-not (extract-from-klist :test-not klist))
        !          1218:         (keyfn    (extract-from-klist :key klist 'identity)))
        !          1219:     (cond
        !          1220:      (test
        !          1221:       (funcall test (funcall keyfn e1) (funcall keyfn e2)))
        !          1222:      (test-not
        !          1223:       (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2))))
        !          1224:      (t                                 ;should never happen
        !          1225:       (error "Neither :test nor :test-not in `%s'"
        !          1226:              (prin1-to-string klist))))))
        !          1227: 
        !          1228: ;;;; end of cl-sequences.el
        !          1229: 
        !          1230: ;;;; MULTIPLE VALUES
        !          1231: ;;;;    This package approximates the behavior of the multiple-values
        !          1232: ;;;;    forms of Common Lisp.  
        !          1233: ;;;;
        !          1234: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !          1235: ;;;;       ([email protected])
        !          1236: 
        !          1237: 
        !          1238: 
        !          1239: ;;; Lisp indentation information
        !          1240: (put 'multiple-value-bind  'lisp-indent-hook 2)
        !          1241: (put 'multiple-value-setq  'lisp-indent-hook 2)
        !          1242: (put 'multiple-value-list  'lisp-indent-hook nil)
        !          1243: (put 'multiple-value-call  'lisp-indent-hook 1)
        !          1244: (put 'multiple-value-prog1 'lisp-indent-hook 1)
        !          1245: 
        !          1246: 
        !          1247: ;;; Global state of the package is kept here
        !          1248: (defvar *mvalues-values* nil
        !          1249:   "Most recently returned multiple-values")
        !          1250: (defvar *mvalues-count*  nil
        !          1251:   "Count of multiple-values returned, or nil if the mechanism was not used")
        !          1252: 
        !          1253: ;;; values is the standard multiple-value-return form.  Must be the
        !          1254: ;;; last thing evaluated inside a function.  If the caller is not
        !          1255: ;;; expecting multiple values, only the first one is passed.  (values)
        !          1256: ;;; is the same as no-values returned (unaware callers see nil). The
        !          1257: ;;; alternative (values-list <list>) is just a convenient shorthand
        !          1258: ;;; and complements multiple-value-list.
        !          1259: 
        !          1260: (defun values (&rest val-forms)
        !          1261:   "Produce multiple values (zero or more).  Each arg is one value.
        !          1262: See also `multiple-value-bind', which is one way to examine the
        !          1263: multiple values produced by a form.  If the containing form or caller
        !          1264: does not check specially to see multiple values, it will see only
        !          1265: the first value."
        !          1266:   (setq *mvalues-values* val-forms)
        !          1267:   (setq *mvalues-count*  (length *mvalues-values*))
        !          1268:   (car *mvalues-values*))
        !          1269: 
        !          1270: 
        !          1271: (defun values-list (&optional val-forms)
        !          1272:   "Produce multiple values (zero or mode).  Each element of LIST is one value.
        !          1273: This is equivalent to (apply 'values LIST)."
        !          1274:   (cond ((nlistp val-forms)
        !          1275:          (error "Argument to values-list must be a list, not `%s'"
        !          1276:                 (prin1-to-string val-forms))))
        !          1277:   (setq *mvalues-values* val-forms)
        !          1278:   (setq *mvalues-count* (length *mvalues-values*))
        !          1279:   (car *mvalues-values*))
        !          1280: 
        !          1281: 
        !          1282: ;;; Callers that want to see the multiple values use these macros.
        !          1283: 
        !          1284: (defmacro multiple-value-list (form)
        !          1285:   "Execute FORM and return a list of all the (multiple) values FORM produces.
        !          1286: See `values' and `multiple-value-bind'."
        !          1287:   (list 'progn
        !          1288:         (list 'setq '*mvalues-count* nil)
        !          1289:         (list 'let (list (list 'it '(gensym)))
        !          1290:               (list 'set 'it form)
        !          1291:               (list 'if '*mvalues-count*
        !          1292:                     (list 'copy-sequence '*mvalues-values*)
        !          1293:                     (list 'progn
        !          1294:                           (list 'setq '*mvalues-count* 1)
        !          1295:                           (list 'setq '*mvalues-values*
        !          1296:                                 (list 'list (list 'symbol-value 'it)))
        !          1297:                           (list 'copy-sequence '*mvalues-values*))))))
        !          1298: 
        !          1299: (defmacro multiple-value-call (function &rest args)
        !          1300:   "Call FUNCTION on all the values produced by the remaining arguments.
        !          1301: (multiple-value-call '+ (values 1 2) (values 3 4)) is 10."
        !          1302:   (let* ((result (gentemp))
        !          1303:          (arg    (gentemp)))
        !          1304:     (list 'apply (list 'function (eval function))
        !          1305:           (list 'let* (list (list result '()))
        !          1306:                 (list 'dolist (list arg (list 'quote args) result)
        !          1307:                       (list 'setq result
        !          1308:                             (list 'append
        !          1309:                                   result
        !          1310:                                   (list 'multiple-value-list
        !          1311:                                         (list 'eval arg)))))))))
        !          1312: 
        !          1313: (defmacro multiple-value-bind (vars form &rest body)
        !          1314:   "Bind VARS to the (multiple) values produced by FORM, then do BODY.
        !          1315: VARS is a list of variables; each is bound to one of FORM's values.
        !          1316: If FORM doesn't make enough values, the extra variables are bound to nil.
        !          1317: (Ordinary forms produce only one value; to produce more, use `values'.)
        !          1318: Extra values are ignored.
        !          1319: BODY (zero or more forms) is executed with the variables bound,
        !          1320: then the bindings are unwound."
        !          1321:   (let* ((vals   (gentemp))             ;name for intermediate values
        !          1322:          (clauses (mv-bind-clausify     ;convert into clauses usable
        !          1323:                    vars vals)))         ; in a let form
        !          1324:     (list* 'let*
        !          1325:            (cons (list vals (list 'multiple-value-list form))
        !          1326:                  clauses)
        !          1327:            body)))
        !          1328: 
        !          1329: (defmacro multiple-value-setq (vars form)
        !          1330:   "Set VARS to the (multiple) values produced by FORM.
        !          1331: VARS is a list of variables; each is set to one of FORM's values.
        !          1332: If FORM doesn't make enough values, the extra variables are set to nil.
        !          1333: (Ordinary forms produce only one value; to produce more, use `values'.)
        !          1334: Extra values are ignored."
        !          1335:   (let* ((vals (gentemp))               ;name for intermediate values
        !          1336:          (clauses (mv-bind-clausify     ;convert into clauses usable
        !          1337:                    vars vals)))         ; in a setq (after append).
        !          1338:     (list 'let*
        !          1339:           (list (list vals (list 'multiple-value-list form)))
        !          1340:           (cons 'setq (apply (function append) clauses)))))
        !          1341: 
        !          1342: (defmacro multiple-value-prog1 (form &rest body)
        !          1343:   "Evaluate FORM, then BODY, then produce the same values FORM produced.
        !          1344: Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2.
        !          1345: This is like `prog1' except that `prog1' would produce only one value,
        !          1346: which would be the first of FORM's values."
        !          1347:   (let* ((heldvalues (gentemp)))
        !          1348:     (cons 'let*
        !          1349:           (cons (list (list heldvalues (list 'multiple-value-list form)))
        !          1350:                 (append body (list (list 'values-list heldvalues)))))))
        !          1351: 
        !          1352: ;;; utility functions
        !          1353: ;;;
        !          1354: ;;; mv-bind-clausify makes the pairs needed to have the variables in
        !          1355: ;;; the variable list correspond with the values returned by the form.
        !          1356: ;;; vals is a fresh symbol that intervenes in all the bindings.
        !          1357: 
        !          1358: (defun mv-bind-clausify (vars vals)
        !          1359:   "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list
        !          1360: Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to
        !          1361: the length of VARS (a list of symbols).  VALS is just a fresh symbol."
        !          1362:   (if (or (nlistp vars)
        !          1363:           (notevery 'symbolp vars))
        !          1364:       (error "Expected a list of symbols, not `%s'"
        !          1365:              (prin1-to-string vars)))
        !          1366:   (let* ((nvars    (length vars))
        !          1367:          (clauses '()))
        !          1368:     (dotimes (n nvars clauses)
        !          1369:       (setq clauses (cons (list (nth n vars)
        !          1370:                                 (list 'nth n vals)) clauses)))))
        !          1371: 
        !          1372: ;;;; end of cl-multiple-values.el
        !          1373: 
        !          1374: ;;;; ARITH
        !          1375: ;;;;    This file provides integer arithmetic extensions.  Although
        !          1376: ;;;;    Emacs Lisp doesn't really support anything but integers, that
        !          1377: ;;;;    has still to be made to look more or less standard.
        !          1378: ;;;;
        !          1379: ;;;;
        !          1380: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !          1381: ;;;;       ([email protected])
        !          1382: 
        !          1383: 
        !          1384: (defun plusp (number)
        !          1385:   "True if NUMBER is strictly greater than zero."
        !          1386:   (> number 0))
        !          1387: 
        !          1388: (defun minusp (number)
        !          1389:   "True if NUMBER is strictly less than zero."
        !          1390:   (< number 0))
        !          1391: 
        !          1392: (defun oddp (number)
        !          1393:   "True if INTEGER is not divisible by 2."
        !          1394:   (/= (% number 2) 0))
        !          1395: 
        !          1396: (defun evenp (number)
        !          1397:   "True if INTEGER is divisible by 2."
        !          1398:   (= (% number 2) 0))
        !          1399: 
        !          1400: (defun abs (number)
        !          1401:   "Return the absolute value of NUMBER."
        !          1402:   (cond
        !          1403:    ((< number 0)
        !          1404:     (- 0 number))
        !          1405:    (t                                   ;number is >= 0
        !          1406:     number)))
        !          1407: 
        !          1408: (defun signum (number)
        !          1409:   "Return -1, 0 or 1 according to the sign of NUMBER."
        !          1410:   (cond
        !          1411:    ((< number 0)
        !          1412:     -1)
        !          1413:    ((> number 0)
        !          1414:     1)
        !          1415:    (t                                   ;exactly zero
        !          1416:     0)))
        !          1417: 
        !          1418: (defun gcd (&rest integers)
        !          1419:   "Return the greatest common divisor of all the arguments.
        !          1420: The arguments must be integers.  With no arguments, value is zero."
        !          1421:   (let ((howmany (length integers)))
        !          1422:     (cond
        !          1423:      ((= howmany 0)
        !          1424:       0)
        !          1425:      ((= howmany 1)
        !          1426:       (abs (car integers)))
        !          1427:      ((> howmany 2)
        !          1428:       (apply (function gcd)
        !          1429:        (cons (gcd (nth 0 integers) (nth 1 integers))
        !          1430:              (nthcdr 2 integers))))
        !          1431:      (t                                 ;howmany=2
        !          1432:       ;; essentially the euclidean algorithm
        !          1433:       (when (zerop (* (nth 0 integers) (nth 1 integers)))
        !          1434:         (error "A zero argument is invalid for `gcd'"))
        !          1435:       (do* ((absa (abs (nth 0 integers))) ; better to operate only
        !          1436:             (absb (abs (nth 1 integers))) ;on positives.
        !          1437:             (dd (max absa absb))        ; setup correct order for the
        !          1438:             (ds (min absa absb))        ;succesive divisions.
        !          1439:             ;; intermediate results
        !          1440:             (q 0)
        !          1441:             (r 0)
        !          1442:             ;; final results
        !          1443:             (done nil)                  ; flag: end of iterations
        !          1444:             (result 0))                 ; final value
        !          1445:           (done result)
        !          1446:         (setq q (/ dd ds))
        !          1447:         (setq r (% dd ds))
        !          1448:         (cond 
        !          1449:          ((zerop r) (setq done t) (setq result ds))
        !          1450:          ( t        (setq dd ds)  (setq ds r))))))))
        !          1451: 
        !          1452: (defun lcm (integer &rest more)
        !          1453:   "Return the least common multiple of all the arguments.
        !          1454: The arguments must be integers and there must be at least one of them."
        !          1455:   (let ((howmany (length more))
        !          1456:         (a       integer)
        !          1457:         (b       (nth 0 more))
        !          1458:         prod                            ; intermediate product
        !          1459:         (yetmore (nthcdr 1 more)))
        !          1460:     (cond
        !          1461:      ((zerop howmany)
        !          1462:       (abs a))
        !          1463:      ((> howmany 1)                     ; recursive case
        !          1464:       (apply (function lcm)
        !          1465:              (cons (lcm a b) yetmore)))
        !          1466:      (t                                 ; base case, just 2 args
        !          1467:       (setq prod (* a b))
        !          1468:       (cond
        !          1469:        ((zerop prod)
        !          1470:         0)
        !          1471:        (t
        !          1472:         (/ (abs prod) (gcd a b))))))))
        !          1473: 
        !          1474: (defun isqrt (number)
        !          1475:   "Return the integer square root of NUMBER.
        !          1476: NUMBER must not be negative.  Result is largest integer less than or
        !          1477: equal to the real square root of the argument."
        !          1478:   (cond
        !          1479:    ((minusp number)
        !          1480:     (error "Argument to `isqrt' must not be negative"))
        !          1481:    ((zerop number)
        !          1482:     0)
        !          1483:    ((<= number 3)
        !          1484:     1)
        !          1485:    (t
        !          1486:     ;; This is some sort of newtonian iteration, trying not to get in
        !          1487:     ;; an infinite loop.  That's why I catch 0, 1, 2 and 3 as special
        !          1488:     ;; cases, so then rounding won't make this iteration loop.
        !          1489:     (do* ((approx (/ number 2) iter)
        !          1490:           (done nil)
        !          1491:           (iter   0))
        !          1492:         (done (if (> (* approx approx) number)
        !          1493:                   (- approx 1)          ;reached from above
        !          1494:                   approx))
        !          1495:       (setq iter
        !          1496:             (/ (+ approx
        !          1497:                   (/ number approx)
        !          1498:                   (if (>= (% number approx) (/ approx 2))
        !          1499:                       1 0))
        !          1500:                2))
        !          1501:       (setq done (eql approx iter))))))
        !          1502: 
        !          1503: (defun floor (number &optional divisor)
        !          1504:   "Divide DIVIDEND by DIVISOR, rounding toward minus infinity.
        !          1505: DIVISOR defaults to 1.  The remainder is produced as a second value."
        !          1506:   (cond
        !          1507:    ((and (null divisor)                 ; trivial case
        !          1508:          (numberp number))
        !          1509:     (values number 0))
        !          1510:    (t                                   ; do the division
        !          1511:     (multiple-value-bind
        !          1512:         (q r s)
        !          1513:         (safe-idiv number divisor)
        !          1514:       (cond
        !          1515:        ((zerop s)
        !          1516:         (values 0 0))
        !          1517:        ((plusp s)
        !          1518:         (values q r))
        !          1519:        (t
        !          1520:         (unless (zerop r)
        !          1521:           (setq q (- 0 (+ q 1)))
        !          1522:           (setq r (- number (* q divisor))))
        !          1523:         (values q r)))))))
        !          1524: 
        !          1525: (defun ceiling (number &optional divisor)
        !          1526:   "Divide DIVIDEND by DIVISOR, rounding toward plus infinity.
        !          1527: DIVISOR defaults to 1.  The remainder is produced as a second value."
        !          1528:   (cond
        !          1529:    ((and (null divisor)                 ; trivial case
        !          1530:          (numberp number))
        !          1531:     (values number 0))
        !          1532:    (t                                   ; do the division
        !          1533:     (multiple-value-bind
        !          1534:         (q r s)
        !          1535:         (safe-idiv number divisor)
        !          1536:       (cond
        !          1537:        ((zerop s)
        !          1538:         (values 0 0))
        !          1539:        ((minusp s)
        !          1540:         (values q r))
        !          1541:        (t
        !          1542:         (unless (zerop r)
        !          1543:           (setq q (+ q 1))
        !          1544:           (setq r (- number (* q divisor))))
        !          1545:         (values q r)))))))
        !          1546: 
        !          1547: (defun truncate (number &optional divisor)
        !          1548:   "Divide DIVIDEND by DIVISOR, rounding toward zero.
        !          1549: DIVISOR defaults to 1.  The remainder is produced as a second value."
        !          1550:   (cond
        !          1551:    ((and (null divisor)                 ; trivial case
        !          1552:          (numberp number))
        !          1553:     (values number 0))
        !          1554:    (t                                   ; do the division
        !          1555:     (multiple-value-bind
        !          1556:         (q r s)
        !          1557:         (safe-idiv number divisor)
        !          1558:       (cond
        !          1559:        ((zerop s)
        !          1560:         (values 0 0))
        !          1561:        ((plusp s)
        !          1562:         (values q r))
        !          1563:        (t
        !          1564:         (unless (zerop r)
        !          1565:           (setq q (- 0 q))
        !          1566:           (setq r (- number (* q divisor))))
        !          1567:         (values q r)))))))
        !          1568: 
        !          1569: (defun round (number &optional divisor)
        !          1570:   "Divide DIVIDEND by DIVISOR, rounding to nearest integer.
        !          1571: DIVISOR defaults to 1.  The remainder is produced as a second value."
        !          1572:   (cond
        !          1573:    ((and (null divisor)                 ; trivial case
        !          1574:          (numberp number))
        !          1575:     (values number 0))    
        !          1576:    (t                                   ; do the division
        !          1577:     (multiple-value-bind
        !          1578:         (q r s)
        !          1579:         (safe-idiv number divisor)
        !          1580:       (setq r (abs r))
        !          1581:       ;; adjust magnitudes first, and then signs
        !          1582:       (let ((other-r (- (abs divisor) r)))
        !          1583:         (cond
        !          1584:          ((> r other-r)
        !          1585:           (setq q (+ q 1)))
        !          1586:          ((and (= r other-r)
        !          1587:                (oddp q))
        !          1588:           ;; round to even is mandatory
        !          1589:           (setq q (+ q 1))))
        !          1590:         (setq q (* s q))
        !          1591:         (setq r (- number (* q divisor)))
        !          1592:         (values q r))))))
        !          1593: 
        !          1594: (defun mod (number divisor)
        !          1595:   "Return remainder of X by Y (rounding quotient toward minus infinity).
        !          1596: That is, the remainder goes with the quotient produced by `floor'."
        !          1597:   (multiple-value-bind (q r) (floor number divisor)
        !          1598:     r))
        !          1599: 
        !          1600: (defun rem (number divisor)
        !          1601:   "Return remainder of X by Y (rounding quotient toward zero).
        !          1602: That is, the remainder goes with the quotient produced by `truncate'."
        !          1603:   (multiple-value-bind (q r) (truncate number divisor)
        !          1604:     r))
        !          1605: 
        !          1606: ;;; internal utilities
        !          1607: ;;;
        !          1608: ;;; safe-idiv performs an integer division with positive numbers only.
        !          1609: ;;; It is known that some machines/compilers implement weird remainder
        !          1610: ;;; computations when working with negatives, so the idea here is to
        !          1611: ;;; make sure we know what is coming back to the caller in all cases.
        !          1612: 
        !          1613: (defun safe-idiv (a b)
        !          1614:   "SAFE-IDIV A B => Q R S
        !          1615: Q=|A|/|B|, R is the rest, S is the sign of A/B."
        !          1616:   (unless (and (numberp a) (numberp b))
        !          1617:     (error "Arguments to `safe-idiv' must be numbers"))
        !          1618:   (when (zerop b)
        !          1619:     (error "Cannot divide %d by zero" a))
        !          1620:   (let* ((absa (abs a))
        !          1621:          (absb (abs b))
        !          1622:          (q    (/ absa absb))
        !          1623:          (s    (signum (* a b)))
        !          1624:          (r    (- a (* (* s q) b))))
        !          1625:     (values q r s)))
        !          1626: 
        !          1627: ;;;; end of cl-arith.el
        !          1628: 
        !          1629: ;;;; SETF
        !          1630: ;;;;    This file provides the setf macro and friends. The purpose has
        !          1631: ;;;;    been modest, only the simplest defsetf forms are accepted.
        !          1632: ;;;;    Use it and enjoy.
        !          1633: ;;;;
        !          1634: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !          1635: ;;;;       ([email protected])
        !          1636: 
        !          1637: 
        !          1638: (defkeyword :setf-update-fn
        !          1639:   "Property, its value is the function setf must invoke to update a
        !          1640: generalized variable whose access form is a function call of the
        !          1641: symbol that has this property.")
        !          1642: 
        !          1643: (defkeyword :setf-update-doc
        !          1644:   "Property of symbols that have a `defsetf' update function on them,
        !          1645: installed by the `defsetf' from its optional third argument.")
        !          1646: 
        !          1647: (defmacro setf (&rest pairs)
        !          1648:   "Generalized `setq' that can set things other than variable values.
        !          1649: A use of `setf' looks like (setf {PLACE VALUE}...).
        !          1650: The behavior of (setf PLACE VALUE) is to access the generalized variable
        !          1651: at PLACE and store VALUE there.  It returns VALUE.  If there is more
        !          1652: than one PLACE and VALUE, each PLACE is set from its VALUE before
        !          1653: the next PLACE is evaluated."
        !          1654:   (let ((nforms (length pairs)))
        !          1655:     ;; check the number of subforms
        !          1656:     (cond
        !          1657:      ((/= (% nforms 2) 0)
        !          1658:       (error "Odd number of arguments to `setf'"))
        !          1659:      ((= nforms 0)
        !          1660:       nil)
        !          1661:      ((> nforms 2)
        !          1662:       ;; this is the recursive case
        !          1663:       (cons 'progn
        !          1664:             (do*                        ;collect the place-value pairs
        !          1665:                 ((args pairs (cddr args))
        !          1666:                  (place (car args) (car args))
        !          1667:                  (value (cadr args) (cadr args))
        !          1668:                  (result '()))
        !          1669:                 ((endp args) (nreverse result))
        !          1670:               (setq result
        !          1671:                     (cons (list 'setf place value)
        !          1672:                           result)))))
        !          1673:      (t                                 ;i.e., nforms=2
        !          1674:       ;; this is the base case (SETF PLACE VALUE)
        !          1675:       (let* ((place (car pairs))
        !          1676:              (value (cadr pairs))
        !          1677:              (head  nil)
        !          1678:              (updatefn nil))
        !          1679:         ;; dispatch on the type of the PLACE
        !          1680:         (cond
        !          1681:          ((symbolp place)
        !          1682:           (list 'setq place value))
        !          1683:          ((and (listp place)
        !          1684:                (setq head (car place))
        !          1685:                (symbolp head)
        !          1686:                (setq updatefn (get head :setf-update-fn)))
        !          1687:          (if (or (and (consp updatefn) (eq (car updatefn) 'lambda))
        !          1688:                  (and (symbolp updatefn)
        !          1689:                       (fboundp updatefn)
        !          1690:                       (let ((defn (symbol-function updatefn)))
        !          1691:                         (or (subrp defn)
        !          1692:                             (and (consp defn) (eq (car defn) 'lambda))))))
        !          1693:              (cons updatefn (append (cdr place) (list value)))
        !          1694:            (multiple-value-bind
        !          1695:                (bindings newsyms)
        !          1696:                (pair-with-newsyms (append (cdr place) (list value)))
        !          1697:              ;; this let* gets new symbols to ensure adequate order of
        !          1698:              ;; evaluation of the subforms.
        !          1699:              (list 'let
        !          1700:                    bindings              
        !          1701:                    (cons updatefn newsyms)))))
        !          1702:          (t
        !          1703:           (error "No `setf' update-function for `%s'"
        !          1704:                  (prin1-to-string place)))))))))
        !          1705: 
        !          1706: (defmacro defsetf (accessfn updatefn &optional docstring)
        !          1707:   "Define how `setf' works on a certain kind of generalized variable.
        !          1708: A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]).
        !          1709: ACCESSFN is a symbol.  UPDATEFN is a function or macro which takes
        !          1710: one more argument than ACCESSFN does.  DEFSETF defines the translation
        !          1711: of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL).
        !          1712: The function UPDATEFN must return its last arg, after performing the
        !          1713: updating called for."
        !          1714:   ;; reject ill-formed requests.  too bad one can't test for functionp
        !          1715:   ;; or macrop.
        !          1716:   (when (not (symbolp accessfn))
        !          1717:     (error "First argument of `defsetf' must be a symbol, not `%s'"
        !          1718:            (prin1-to-string accessfn)))
        !          1719:   ;; update properties
        !          1720:   (put accessfn :setf-update-fn updatefn)
        !          1721:   (put accessfn :setf-update-doc docstring))
        !          1722: 
        !          1723: ;;; This section provides the "default" setfs for Common-Emacs-Lisp
        !          1724: ;;; The user will not normally add anything to this, although
        !          1725: ;;; defstruct will introduce new ones as a matter of fact.
        !          1726: ;;;
        !          1727: ;;; Apply is a special case.   The Common Lisp
        !          1728: ;;; standard makes the case of apply be useful when the user writes
        !          1729: ;;; something like (apply #'name ...), Emacs Lisp doesn't have the #
        !          1730: ;;; stuff, but it has (function ...).  Notice that V18 includes a new
        !          1731: ;;; apply: this file is compatible with V18 and pre-V18 Emacses.
        !          1732: 
        !          1733: ;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the
        !          1734: ;;; (correct) left to right sequence *before* checking for apply
        !          1735: ;;; methods (which should really be an special case inside setf).  Due
        !          1736: ;;; to this, the lambda expression defsetf'd to apply will succeed in
        !          1737: ;;; applying the right function even if the name was not quoted, but
        !          1738: ;;; computed!  That extension is not Common Lisp (nor is particularly
        !          1739: ;;; useful, I think).
        !          1740: 
        !          1741: (defsetf apply
        !          1742:   (lambda (&rest args)
        !          1743:     ;; dissasemble the calling form
        !          1744:     ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too)
        !          1745:     (let* ((fnform (car args))          ;functional form
        !          1746:            (applyargs (append           ;arguments "to apply fnform"
        !          1747:                        (apply 'list* (butlast (cdr args)))
        !          1748:                        (last args)))
        !          1749:            (newupdater nil))            ; its update-fn, if any
        !          1750:       (cond
        !          1751:        ((and (symbolp fnform)
        !          1752:              (setq newupdater (get fnform :setf-update-fn)))
        !          1753:         ;; just do it
        !          1754:         (apply  newupdater applyargs))
        !          1755:        (t
        !          1756:         (error "Can't `setf' to `%s'"
        !          1757:                (prin1-to-string fnform))))))
        !          1758:   "`apply' is a special case for `setf'")
        !          1759: 
        !          1760: 
        !          1761: (defsetf aref
        !          1762:   aset
        !          1763:   "`setf' inversion for `aref'")
        !          1764: 
        !          1765: (defsetf nth
        !          1766:   setnth
        !          1767:   "`setf' inversion for `nth'")
        !          1768: 
        !          1769: (defsetf nthcdr
        !          1770:   setnthcdr
        !          1771:   "`setf' inversion for `nthcdr'")
        !          1772: 
        !          1773: (defsetf elt
        !          1774:   setelt
        !          1775:   "`setf' inversion for `elt'")
        !          1776: 
        !          1777: (defsetf first
        !          1778:   (lambda (list val) (setnth 0 list val))
        !          1779:   "`setf' inversion for `first'")
        !          1780: 
        !          1781: (defsetf second
        !          1782:   (lambda (list val) (setnth 1 list val))
        !          1783:   "`setf' inversion for `second'")
        !          1784: 
        !          1785: (defsetf third
        !          1786:   (lambda (list val) (setnth 2 list val))
        !          1787:   "`setf' inversion for `third'")
        !          1788: 
        !          1789: (defsetf fourth
        !          1790:   (lambda (list val) (setnth 3 list val))
        !          1791:   "`setf' inversion for `fourth'")
        !          1792: 
        !          1793: (defsetf fifth
        !          1794:   (lambda (list val) (setnth 4 list val))
        !          1795:   "`setf' inversion for `fifth'")
        !          1796: 
        !          1797: (defsetf sixth
        !          1798:   (lambda (list val) (setnth 5 list val))
        !          1799:   "`setf' inversion for `sixth'")
        !          1800: 
        !          1801: (defsetf seventh
        !          1802:   (lambda (list val) (setnth 6 list val))
        !          1803:   "`setf' inversion for `seventh'")
        !          1804: 
        !          1805: (defsetf eighth
        !          1806:   (lambda (list val) (setnth 7 list val))
        !          1807:   "`setf' inversion for `eighth'")
        !          1808: 
        !          1809: (defsetf ninth
        !          1810:   (lambda (list val) (setnth 8 list val))
        !          1811:   "`setf' inversion for `ninth'")
        !          1812: 
        !          1813: (defsetf tenth
        !          1814:   (lambda (list val) (setnth 9 list val))
        !          1815:   "`setf' inversion for `tenth'")
        !          1816: 
        !          1817: (defsetf rest
        !          1818:   (lambda (list val) (setcdr list val))
        !          1819:   "`setf' inversion for `rest'")
        !          1820: 
        !          1821: (defsetf car setcar "Replace the car of a cons")
        !          1822: 
        !          1823: (defsetf cdr setcdr "Replace the cdr of a cons")
        !          1824: 
        !          1825: (defsetf caar
        !          1826:   (lambda (list val) (setcar (nth 0 list) val))
        !          1827:   "`setf' inversion for `caar'")
        !          1828: 
        !          1829: (defsetf cadr
        !          1830:   (lambda (list val) (setcar (cdr list) val))
        !          1831:   "`setf' inversion for `cadr'")
        !          1832: 
        !          1833: (defsetf cdar
        !          1834:   (lambda (list val) (setcdr (car list) val))
        !          1835:   "`setf' inversion for `cdar'")
        !          1836: 
        !          1837: (defsetf cddr
        !          1838:   (lambda (list val) (setcdr (cdr list) val))
        !          1839:   "`setf' inversion for `cddr'")
        !          1840: 
        !          1841: (defsetf caaar
        !          1842:   (lambda (list val) (setcar (caar list) val))
        !          1843:   "`setf' inversion for `caaar'")
        !          1844: 
        !          1845: (defsetf caadr
        !          1846:   (lambda (list val) (setcar (cadr list) val))
        !          1847:   "`setf' inversion for `caadr'")
        !          1848: 
        !          1849: (defsetf cadar
        !          1850:   (lambda (list val) (setcar (cdar list) val))
        !          1851:   "`setf' inversion for `cadar'")
        !          1852: 
        !          1853: (defsetf cdaar
        !          1854:   (lambda (list val) (setcdr (caar list) val))
        !          1855:   "`setf' inversion for `cdaar'")
        !          1856: 
        !          1857: (defsetf caddr
        !          1858:   (lambda (list val) (setcar (cddr list) val))
        !          1859:   "`setf' inversion for `caddr'")
        !          1860: 
        !          1861: (defsetf cdadr
        !          1862:   (lambda (list val) (setcdr (cadr list) val))
        !          1863:   "`setf' inversion for `cdadr'")
        !          1864: 
        !          1865: (defsetf cddar
        !          1866:   (lambda (list val) (setcdr (cdar list) val))
        !          1867:   "`setf' inversion for `cddar'")
        !          1868: 
        !          1869: (defsetf cdddr
        !          1870:   (lambda (list val) (setcdr (cddr list) val))
        !          1871:   "`setf' inversion for `cdddr'")
        !          1872: 
        !          1873: (defsetf caaaar
        !          1874:   (lambda (list val) (setcar (caaar list) val))
        !          1875:   "`setf' inversion for `caaaar'")
        !          1876: 
        !          1877: (defsetf caaadr
        !          1878:   (lambda (list val) (setcar (caadr list) val))
        !          1879:   "`setf' inversion for `caaadr'")
        !          1880: 
        !          1881: (defsetf caadar
        !          1882:   (lambda (list val) (setcar (cadar list) val))
        !          1883:   "`setf' inversion for `caadar'")
        !          1884: 
        !          1885: (defsetf cadaar
        !          1886:   (lambda (list val) (setcar (cdaar list) val))
        !          1887:   "`setf' inversion for `cadaar'")
        !          1888: 
        !          1889: (defsetf cdaaar
        !          1890:   (lambda (list val) (setcdr (caar list) val))
        !          1891:   "`setf' inversion for `cdaaar'")
        !          1892: 
        !          1893: (defsetf caaddr
        !          1894:   (lambda (list val) (setcar (caddr list) val))
        !          1895:   "`setf' inversion for `caaddr'")
        !          1896: 
        !          1897: (defsetf cadadr
        !          1898:   (lambda (list val) (setcar (cdadr list) val))
        !          1899:   "`setf' inversion for `cadadr'")
        !          1900: 
        !          1901: (defsetf cdaadr
        !          1902:   (lambda (list val) (setcdr (caadr list) val))
        !          1903:   "`setf' inversion for `cdaadr'")
        !          1904: 
        !          1905: (defsetf caddar
        !          1906:   (lambda (list val) (setcar (cddar list) val))
        !          1907:   "`setf' inversion for `caddar'")
        !          1908: 
        !          1909: (defsetf cdadar
        !          1910:   (lambda (list val) (setcdr (cadar list) val))
        !          1911:   "`setf' inversion for `cdadar'")
        !          1912: 
        !          1913: (defsetf cddaar
        !          1914:   (lambda (list val) (setcdr (cdaar list) val))
        !          1915:   "`setf' inversion for `cddaar'")
        !          1916: 
        !          1917: (defsetf cadddr
        !          1918:   (lambda (list val) (setcar (cdddr list) val))
        !          1919:   "`setf' inversion for `cadddr'")
        !          1920: 
        !          1921: (defsetf cddadr
        !          1922:   (lambda (list val) (setcdr (cdadr list) val))
        !          1923:   "`setf' inversion for `cddadr'")
        !          1924: 
        !          1925: (defsetf cdaddr
        !          1926:   (lambda (list val) (setcdr (caddr list) val))
        !          1927:   "`setf' inversion for `cdaddr'")
        !          1928: 
        !          1929: (defsetf cdddar
        !          1930:   (lambda (list val) (setcdr (cddar list) val))
        !          1931:   "`setf' inversion for `cdddar'")
        !          1932: 
        !          1933: (defsetf cddddr
        !          1934:   (lambda (list val) (setcdr (cddr list) val))
        !          1935:   "`setf' inversion for `cddddr'")
        !          1936: 
        !          1937: 
        !          1938: (defsetf get
        !          1939:   put
        !          1940:   "`setf' inversion for `get' is `put'")
        !          1941: 
        !          1942: (defsetf symbol-function
        !          1943:   fset
        !          1944:   "`setf' inversion for `symbol-function' is `fset'")
        !          1945: 
        !          1946: (defsetf symbol-plist
        !          1947:   setplist
        !          1948:   "`setf' inversion for `symbol-plist' is `setplist'")
        !          1949: 
        !          1950: (defsetf symbol-value
        !          1951:   set
        !          1952:   "`setf' inversion for `symbol-value' is `set'")
        !          1953: 
        !          1954: ;;; Modify macros
        !          1955: ;;;
        !          1956: ;;; It could be nice to implement define-modify-macro, but I don't
        !          1957: ;;; think it really pays.
        !          1958: 
        !          1959: (defmacro incf (ref &optional delta)
        !          1960:   "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)"
        !          1961:   (if (null delta)
        !          1962:       (setq delta 1))
        !          1963:   (list 'setf ref (list '+ ref delta)))
        !          1964: 
        !          1965: (defmacro decf (ref &optional delta)
        !          1966:   "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)"
        !          1967:   (if (null delta)
        !          1968:       (setq delta 1))
        !          1969:   (list 'setf ref (list '- ref delta)))
        !          1970: 
        !          1971: (defmacro push (item ref)
        !          1972:   "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)"
        !          1973:   (list 'setf ref (list 'cons item ref)))
        !          1974: 
        !          1975: (defmacro pushnew (item ref)
        !          1976:   "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)"
        !          1977:   (list 'setf ref (list 'adjoin item ref)))
        !          1978: 
        !          1979: (defmacro pop (ref)
        !          1980:   "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))"
        !          1981:   (let ((listname (gensym)))
        !          1982:     (list 'let (list (list listname ref))
        !          1983:           (list 'prog1
        !          1984:                 (list 'car listname)
        !          1985:                 (list 'setf ref (list 'cdr listname))))))
        !          1986: 
        !          1987: ;;; PSETF
        !          1988: ;;;
        !          1989: ;;; Psetf is the generalized variable equivalent of psetq.  The right
        !          1990: ;;; hand sides are evaluated and assigned (via setf) to the left hand
        !          1991: ;;; sides. The evaluations are done in an environment where they
        !          1992: ;;; appear to occur in parallel.
        !          1993: 
        !          1994: (defmacro psetf (&rest pairs)
        !          1995:   "(psetf {PLACE VALUE}...): Set several generalized variables in parallel.
        !          1996: All the VALUEs are computed, and then all the PLACEs are stored as in `setf'.
        !          1997: See also `psetq', `shiftf' and `rotatef'."
        !          1998:   (unless (evenp (length pairs))
        !          1999:     (error "Odd number of arguments to `psetf'"))
        !          2000:   (multiple-value-bind
        !          2001:       (places forms)
        !          2002:       (unzip-list pairs)
        !          2003:     ;; obtain fresh symbols to simulate the parallelism
        !          2004:     (multiple-value-bind
        !          2005:         (bindings newsyms)
        !          2006:         (pair-with-newsyms forms)
        !          2007:       (list 'let
        !          2008:             bindings
        !          2009:             (cons 'setf (zip-lists places newsyms))
        !          2010:             nil))))
        !          2011: 
        !          2012: ;;; SHIFTF and ROTATEF 
        !          2013: ;;;
        !          2014: 
        !          2015: (defmacro shiftf (&rest forms)
        !          2016:   "(shiftf PLACE1 PLACE2... NEWVALUE): set PLACE1 to PLACE2, PLACE2 to PLACE3...
        !          2017: Each PLACE is set to the old value of the following PLACE,
        !          2018: and the last PLACE is set to the value NEWVALUE."
        !          2019:   (unless (> (length forms) 1)
        !          2020:     (error "`shiftf' needs more than one argument"))
        !          2021:   (let ((places (butlast forms))
        !          2022:        (newvalue (car (last forms))))
        !          2023:     ;; the places are accessed to fresh symbols
        !          2024:     (multiple-value-bind
        !          2025:        (bindings newsyms)
        !          2026:        (pair-with-newsyms places)
        !          2027:       (list 'let bindings
        !          2028:            (cons 'setf
        !          2029:                  (zip-lists places
        !          2030:                             (append (cdr newsyms) (list newvalue))))
        !          2031:            (car newsyms)))))
        !          2032: 
        !          2033: (defmacro rotatef (&rest places)
        !          2034:   "(rotatef PLACE...) sets each PLACE to the old value of the following PLACE.
        !          2035: The last PLACE is set to the old value of the first PLACE.
        !          2036: Thus, the values rotate through the PLACEs."
        !          2037:   (cond
        !          2038:    ((null places)
        !          2039:     nil)
        !          2040:    (t
        !          2041:     (multiple-value-bind
        !          2042:        (bindings newsyms)
        !          2043:        (pair-with-newsyms places)
        !          2044:       (list
        !          2045:        'let bindings
        !          2046:        (cons 'setf
        !          2047:             (zip-lists places
        !          2048:                        (append (cdr newsyms) (list (car newsyms)))))
        !          2049:        nil)))))
        !          2050: 
        !          2051: ;;;; STRUCTS
        !          2052: ;;;;    This file provides the structures mechanism.  See the
        !          2053: ;;;;    documentation for Common-Lisp's defstruct.  Mine doesn't
        !          2054: ;;;;    implement all the functionality of the standard, although some
        !          2055: ;;;;    more could be grafted if so desired.  More details along with
        !          2056: ;;;;    the code.
        !          2057: ;;;;
        !          2058: ;;;;
        !          2059: ;;;;    Cesar Quiroz @ UofR DofCSc - Dec. 1986
        !          2060: ;;;;       ([email protected])
        !          2061: 
        !          2062: 
        !          2063: (defkeyword :include             "Syntax of `defstruct'")
        !          2064: (defkeyword :named               "Syntax of `defstruct'")
        !          2065: (defkeyword :conc-name           "Syntax of `defstruct'")
        !          2066: (defkeyword :copier              "Syntax of `defstruct'")
        !          2067: (defkeyword :predicate           "Syntax of `defstruct'")
        !          2068: (defkeyword :print-function      "Syntax of `defstruct'")
        !          2069: (defkeyword :type                "Syntax of `defstruct'")
        !          2070: (defkeyword :initial-offset      "Syntax of `defstruct'")
        !          2071: 
        !          2072: (defkeyword :structure-doc       "Documentation string for a structure.")
        !          2073: (defkeyword :structure-slotsn    "Number of slots in structure")
        !          2074: (defkeyword :structure-slots     "List of the slot's names")
        !          2075: (defkeyword :structure-indices   "List of (KEYWORD-NAME . INDEX)")
        !          2076: (defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)")
        !          2077: 
        !          2078: 
        !          2079: (defmacro defstruct (&rest args)
        !          2080:   "(defstruct NAME [DOC-STRING] . SLOTS)  define NAME as structure type.
        !          2081: NAME must be a symbol, the name of the new structure.  It could also
        !          2082: be a list (NAME . OPTIONS), but not all options are supported currently.
        !          2083: As of Dec. 1986, this is supporting :conc-name, :copier and :predicate
        !          2084: completely, :include arguably completely and :constructor only to
        !          2085: change the name of the default constructor.  No BOA constructors allowed.
        !          2086: The DOC-STRING is established as the 'structure-doc' property of NAME.
        !          2087: The SLOTS are one or more of the following:
        !          2088: SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME
        !          2089: list of SYMBOL and VALUE -- meaning that VALUE is the initial value of
        !          2090: the slot.
        !          2091: `defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the
        !          2092: structure, and functions with the same name as the slots to access
        !          2093: them.  `setf' of the accessors sets their values."
        !          2094:   (multiple-value-bind
        !          2095:       (name options docstring slotsn slots initlist)
        !          2096:       (parse$defstruct$args args)
        !          2097:     ;; Names for the member functions come from the options.  The
        !          2098:     ;; slots* stuff collects info about the slots declared explicitly. 
        !          2099:     (multiple-value-bind
        !          2100:         (conc-name constructor copier predicate moreslotsn moreslots moreinits)
        !          2101:         (parse$defstruct$options name options slots)
        !          2102:       ;; The moreslots* stuff refers to slots gained as a consequence
        !          2103:       ;; of (:include clauses).
        !          2104:       (when (and (numberp moreslotsn)
        !          2105:                  (> moreslotsn 0))
        !          2106:         (setf slotsn (+ slotsn moreslotsn))
        !          2107:         (setf slots (append moreslots slots))
        !          2108:         (setf initlist (append moreinits initlist)))
        !          2109:       (unless (> slotsn 0)
        !          2110:         (error "%s needs at least one slot"
        !          2111:                (prin1-to-string name)))
        !          2112:       (let ((dups (duplicate-symbols-p slots)))
        !          2113:         (when dups
        !          2114:           (error "`%s' are duplicates"
        !          2115:                  (prin1-to-string dups))))
        !          2116:       (setq initlist (simplify$inits slots initlist))
        !          2117:       (let (properties functions keywords accessors alterators returned)
        !          2118:         ;; compute properties of NAME
        !          2119:         (setq properties
        !          2120:               (list
        !          2121:                (list 'put (list 'quote name) :structure-doc
        !          2122:                      docstring)
        !          2123:                (list 'put (list 'quote name) :structure-slotsn
        !          2124:                      slotsn)
        !          2125:                (list 'put (list 'quote name) :structure-slots
        !          2126:                      (list 'quote slots))
        !          2127:                (list 'put (list 'quote name) :structure-initforms
        !          2128:                      (list 'quote initlist))
        !          2129:                (list 'put (list 'quote name) :structure-indices
        !          2130:                      (list 'quote (extract$indices initlist)))))
        !          2131: 
        !          2132:         ;; Compute functions associated with NAME.  This is not
        !          2133:        ;; handling BOA constructors yet, but here would be the place.
        !          2134:         (setq functions
        !          2135:               (list
        !          2136:                (list 'fset (list 'quote constructor)
        !          2137:                      (list 'function
        !          2138:                            (list 'lambda (list '&rest 'args)
        !          2139:                                  (list 'make$structure$instance
        !          2140:                                        (list 'quote name)
        !          2141:                                        'args))))
        !          2142:                (list 'fset (list 'quote copier)
        !          2143:                      (list 'function
        !          2144:                            (list 'lambda (list 'struct)
        !          2145:                                  (list 'copy-vector 'struct))))
        !          2146:                (list 'fset (list 'quote predicate)
        !          2147:                      (list 'function
        !          2148:                            (list 'lambda (list 'thing)
        !          2149:                                  (list 'and
        !          2150:                                        (list 'vectorp 'thing)
        !          2151:                                        (list 'eq
        !          2152:                                              (list 'elt 'thing 0)
        !          2153:                                              (list 'quote name))
        !          2154:                                        (list '=
        !          2155:                                              (list 'length 'thing)
        !          2156:                                              (1+ slotsn))))))))
        !          2157:         ;; compute accessors for NAME's slots
        !          2158:         (multiple-value-setq
        !          2159:             (accessors alterators keywords)
        !          2160:             (build$accessors$for name conc-name predicate slots slotsn))
        !          2161:         ;; generate returned value -- not defined by the standard
        !          2162:         (setq returned
        !          2163:               (list
        !          2164:                (cons 'vector
        !          2165:                      (mapcar
        !          2166:                       '(lambda (x) (list 'quote x))
        !          2167:                       (cons name slots)))))
        !          2168:         ;; generate code
        !          2169:         (cons 'progn
        !          2170:               (nconc properties functions keywords
        !          2171:                      accessors alterators returned))))))
        !          2172: 
        !          2173: (defun parse$defstruct$args (args)
        !          2174:   "PARSE$DEFSTRUCT$ARGS ARGS => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST
        !          2175: NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots,
        !          2176: SLOTS=list of their names, INITLIST=alist (keyword . initform)."
        !          2177:   (let (name                            ;args=(symbol...) or ((symbol...)...)
        !          2178:         options                         ;args=((symbol . options) ...)
        !          2179:         (docstring "")                  ;args=(head docstring . slotargs)
        !          2180:         slotargs                        ;second or third cdr of args
        !          2181:         (slotsn 0)                      ;number of slots 
        !          2182:         (slots '())                     ;list of slot names
        !          2183:         (initlist '()))                 ;list of (slot keyword . initform)
        !          2184:     ;; extract name and options
        !          2185:     (cond
        !          2186:      ((symbolp (car args))              ;simple name
        !          2187:       (setq name    (car args)
        !          2188:             options '()))
        !          2189:      ((and (listp   (car args))         ;(name . options)
        !          2190:            (symbolp (caar args)))
        !          2191:       (setq name    (caar args)
        !          2192:             options (cdar args)))
        !          2193:      (t
        !          2194:       (error "First arg to `defstruct' must be symbol or (symbol ...)")))
        !          2195:     (setq slotargs (cdr args))
        !          2196:     ;; is there a docstring?
        !          2197:     (when (stringp (car slotargs))
        !          2198:       (setq docstring (car slotargs)
        !          2199:             slotargs  (cdr slotargs)))
        !          2200:     ;; now for the slots
        !          2201:     (multiple-value-bind
        !          2202:         (slotsn slots initlist)
        !          2203:         (process$slots slotargs)
        !          2204:       (values name options docstring slotsn slots initlist))))
        !          2205: 
        !          2206: (defun process$slots (slots)
        !          2207:   "PROCESS$SLOTS SLOTS => SLOTSN SLOTSLIST INITLIST
        !          2208: Converts a list of symbols or lists of symbol and form into the last 3
        !          2209: values returned by PARSE$DEFSTRUCT$ARGS."
        !          2210:   (let ((slotsn (length slots))         ;number of slots
        !          2211:         slotslist                       ;(slot1 slot2 ...)
        !          2212:         initlist)                       ;((:slot1 . init1) ...)
        !          2213:     (do*
        !          2214:         ((ptr  slots     (cdr ptr))
        !          2215:          (this (car ptr) (car ptr)))
        !          2216:         ((endp ptr))
        !          2217:       (cond
        !          2218:        ((symbolp this)
        !          2219:         (setq slotslist (cons this slotslist))
        !          2220:         (setq initlist (acons (keyword-of this) nil initlist)))
        !          2221:        ((and (listp this)
        !          2222:              (symbolp (car this)))
        !          2223:         (let ((name (car this))
        !          2224:               (form (cadr this)))
        !          2225:           ;; this silently ignores any slot options.  bad...
        !          2226:           (setq slotslist (cons name slotslist))
        !          2227:           (setq initlist  (acons (keyword-of name) form initlist))))
        !          2228:        (t
        !          2229:         (error "Slot should be symbol or (symbol ...), not `%s'"
        !          2230:                (prin1-to-string this)))))
        !          2231:     (values slotsn (nreverse slotslist) (nreverse initlist))))
        !          2232: 
        !          2233: (defun parse$defstruct$options (name options slots)
        !          2234:   "PARSE$DEFSTRUCT$OPTIONS NAME OPTIONS SLOTS => CONC-NAME CONST COPIER PRED
        !          2235: Returns at least those 4 values (a string and 3 symbols, to name the necessary
        !          2236: functions),  might return also things discovered by actually
        !          2237: inspecting the options, namely MORESLOTSN MORESLOTS MOREINITS, as can
        !          2238: be created by :include, and perhaps a list of BOACONSTRUCTORS."
        !          2239:   (let* ((namestring (symbol-name name))
        !          2240:          ;; to build the return values
        !          2241:          (conc-name  (concat namestring "-"))
        !          2242:          (const (intern (concat "make-" namestring)))
        !          2243:          (copier (intern (concat "copy-" namestring)))
        !          2244:          (pred (intern (concat namestring "-p")))
        !          2245:          (moreslotsn 0)
        !          2246:          (moreslots '())
        !          2247:          (moreinits '())
        !          2248:          ;; auxiliaries
        !          2249:          option-head                    ;When an option is not a plain
        !          2250:          option-second                  ; keyword, it must be a list of
        !          2251:          option-rest                    ; the form (head second . rest)
        !          2252:          these-slotsn                   ;When :include is found, the
        !          2253:          these-slots                    ; info about the included
        !          2254:          these-inits                    ; structure is added here.
        !          2255:          )
        !          2256:     ;; Values above are the defaults.  Now we read the options themselves
        !          2257:     (dolist (option options)
        !          2258:       ;; 2 cases arise, as options must be a keyword or a list
        !          2259:       (cond
        !          2260:        ((keywordp option)
        !          2261:         (case option
        !          2262:           (:named
        !          2263:            )                            ;ignore silently
        !          2264:           (t
        !          2265:            (error "Can't recognize option `%s'"
        !          2266:                   (prin1-to-string option)))))
        !          2267:        ((and (listp option)
        !          2268:              (keywordp (setq option-head (car option))))
        !          2269:         (setq option-second (second option))
        !          2270:         (setq option-rest   (nthcdr 2 option))
        !          2271:         (case option-head
        !          2272:           (:conc-name
        !          2273:            (setq conc-name
        !          2274:                  (cond
        !          2275:                   ((stringp option-second)
        !          2276:                    option-second)
        !          2277:                   ((null option-second)
        !          2278:                    "")
        !          2279:                   (t
        !          2280:                    (error "`%s' is invalid as `conc-name'"
        !          2281:                           (prin1-to-string option-second))))))
        !          2282:           (:copier
        !          2283:            (setq copier
        !          2284:                  (cond
        !          2285:                   ((and (symbolp option-second)
        !          2286:                         (null option-rest))
        !          2287:                    option-second)
        !          2288:                   (t
        !          2289:                    (error "Can't recognize option `%s'"
        !          2290:                           (prin1-to-string option))))))
        !          2291: 
        !          2292:           (:constructor                 ;no BOA-constructors allowed
        !          2293:            (setq const
        !          2294:                  (cond
        !          2295:                   ((and (symbolp option-second)
        !          2296:                         (null option-rest))
        !          2297:                    option-second)
        !          2298:                   (t
        !          2299:                    (error "Can't recognize option `%s'"
        !          2300:                           (prin1-to-string option))))))
        !          2301:           (:predicate
        !          2302:            (setq pred
        !          2303:                  (cond
        !          2304:                   ((and (symbolp option-second)
        !          2305:                         (null option-rest))
        !          2306:                    option-second)
        !          2307:                   (t
        !          2308:                    (error "Can't recognize option `%s'"
        !          2309:                           (prin1-to-string option))))))
        !          2310:           (:include
        !          2311:            (unless (symbolp option-second)
        !          2312:              (error "Arg to `:include' should be a symbol, not `%s'"
        !          2313:                     (prin1-to-string option-second)))
        !          2314:            (setq these-slotsn (get option-second :structure-slotsn)
        !          2315:                  these-slots  (get option-second :structure-slots)
        !          2316:                  these-inits  (get option-second :structure-initforms))
        !          2317:            (unless (and (numberp these-slotsn)
        !          2318:                         (> these-slotsn 0))
        !          2319:              (error "`%s' is not a valid structure"
        !          2320:                     (prin1-to-string option-second)))
        !          2321:            (multiple-value-bind
        !          2322:                (xtra-slotsn xtra-slots xtra-inits)
        !          2323:                (process$slots option-rest)
        !          2324:              (when (> xtra-slotsn 0)
        !          2325:                (dolist (xslot xtra-slots)
        !          2326:                  (unless (memq xslot these-slots)
        !          2327:                    (error "`%s' is not a slot of `%s'"
        !          2328:                           (prin1-to-string xslot)
        !          2329:                           (prin1-to-string option-second))))
        !          2330:                (setq these-inits (append xtra-inits these-inits)))
        !          2331:              (setq moreslotsn (+ moreslotsn these-slotsn))
        !          2332:              (setq moreslots  (append these-slots moreslots))
        !          2333:              (setq moreinits  (append these-inits moreinits))))
        !          2334:           ((:print-function :type :initial-offset)
        !          2335:            )                            ;ignore silently
        !          2336:           (t
        !          2337:            (error "Can't recognize option `%s'"
        !          2338:                   (prin1-to-string option)))))
        !          2339:        (t
        !          2340:         (error "Can't recognize option `%s'"
        !          2341:                (prin1-to-string option)))))
        !          2342:     ;; Return values found
        !          2343:     (values conc-name const copier pred
        !          2344:             moreslotsn moreslots moreinits)))
        !          2345: 
        !          2346: (defun simplify$inits (slots initlist)
        !          2347:   "SIMPLIFY$INITS SLOTS INITLIST => new INITLIST
        !          2348: Removes from INITLIST - an ALIST - any shadowed bindings."
        !          2349:   (let ((result '())                    ;built here
        !          2350:         key                             ;from the slot 
        !          2351:         )
        !          2352:     (dolist (slot slots)
        !          2353:       (setq key (keyword-of slot))
        !          2354:       (setq result (acons key (cdr (assoc key initlist)) result)))
        !          2355:     (nreverse result)))
        !          2356: 
        !          2357: (defun extract$indices (initlist)
        !          2358:   "EXTRACT$INDICES INITLIST => indices list
        !          2359: Kludge.  From a list of pairs (keyword . form) build a list of pairs
        !          2360: of the form (keyword . position in list from 0).  Useful to precompute
        !          2361: some of the work of MAKE$STRUCTURE$INSTANCE."
        !          2362:   (let ((result '())
        !          2363:         (index   0))
        !          2364:     (dolist (entry initlist (nreverse result))
        !          2365:       (setq result (acons (car entry) index result)
        !          2366:             index  (+ index 1)))))
        !          2367: 
        !          2368: (defun build$accessors$for (name conc-name predicate slots slotsn)
        !          2369:   "BUILD$ACCESSORS$FOR NAME PREDICATE SLOTS SLOTSN  => FSETS DEFSETFS KWDS
        !          2370: Generate the code for accesors and defsetfs of a structure called
        !          2371: NAME, whose slots are SLOTS.  Also, establishes the keywords for the
        !          2372: slots names."
        !          2373:   (do ((i 0 (1+ i))
        !          2374:        (accessors '())
        !          2375:        (alterators '())
        !          2376:        (keywords '())
        !          2377:        (canonic  ""))                   ;slot name with conc-name prepended
        !          2378:       ((>= i slotsn)
        !          2379:        (values
        !          2380:         (nreverse accessors) (nreverse alterators) (nreverse keywords)))
        !          2381:     (setq canonic (intern (concat conc-name (symbol-name (nth i slots)))))
        !          2382:     (setq accessors
        !          2383:           (cons
        !          2384:            (list 'fset (list 'quote canonic)
        !          2385:                  (list 'function
        !          2386:                        (list 'lambda (list 'object)
        !          2387:                              (list 'cond
        !          2388:                                    (list (list predicate 'object)
        !          2389:                                          (list 'aref 'object (1+ i)))
        !          2390:                                    (list 't
        !          2391:                                          (list 'error
        !          2392:                                                "`%s' not a %s."
        !          2393:                                                (list 'prin1-to-string
        !          2394:                                                      'object)
        !          2395:                                                (list 'prin1-to-string
        !          2396:                                                      (list 'quote
        !          2397:                                                            name))))))))
        !          2398:            accessors))
        !          2399:     (setq alterators
        !          2400:            (cons
        !          2401:             (list 'defsetf canonic
        !          2402:                   (list 'lambda (list 'object 'newval)
        !          2403:                         (list 'cond
        !          2404:                               (list (list predicate 'object)
        !          2405:                                     (list 'aset 'object (1+ i) 'newval))
        !          2406:                               (list 't
        !          2407:                                     (list 'error
        !          2408:                                           "`%s' not a `%s'"
        !          2409:                                           (list 'prin1-to-string
        !          2410:                                                 'object)
        !          2411:                                           (list 'prin1-to-string
        !          2412:                                                 (list 'quote
        !          2413:                                                       name)))))))
        !          2414:             alterators))
        !          2415:     (setq keywords
        !          2416:           (cons (list 'defkeyword (keyword-of (nth i slots)))
        !          2417:                 keywords))))
        !          2418: 
        !          2419: (defun make$structure$instance (name args)
        !          2420:   "MAKE$STRUCTURE$INSTANCE NAME ARGS => new struct NAME
        !          2421: A struct of type NAME is created, some slots might be initialized
        !          2422: according to ARGS (the &rest argument of MAKE-name)."
        !          2423:   (unless (symbolp name)
        !          2424:     (error "`%s' is not a possible name for a structure"
        !          2425:            (prin1-to-string name)))
        !          2426:   (let ((initforms (get name :structure-initforms))
        !          2427:         (slotsn    (get name :structure-slotsn))
        !          2428:         (indices   (get name :structure-indices))
        !          2429:         initalist                       ;pairlis'd on initforms
        !          2430:         initializers                    ;definitive initializers
        !          2431:         )
        !          2432:     ;; check sanity of the request
        !          2433:     (unless (and (numberp slotsn)
        !          2434:                  (> slotsn 0))
        !          2435:       (error "`%s' is not a defined structure"
        !          2436:              (prin1-to-string name)))
        !          2437:     (unless (evenp (length args))
        !          2438:       (error "Slot initializers `%s' not of even length"
        !          2439:              (prin1-to-string args)))
        !          2440:     ;; analyze the initializers provided by the call
        !          2441:     (multiple-value-bind
        !          2442:         (speckwds specvals)             ;keywords and values given 
        !          2443:         (unzip-list args)               ; by the user
        !          2444:       ;; check that all the arguments are introduced by keywords 
        !          2445:       (unless (every (function keywordp) speckwds)
        !          2446:         (error "All of the names in `%s' should be keywords"
        !          2447:                (prin1-to-string speckwds)))
        !          2448:       ;; check that all the keywords are known
        !          2449:       (dolist (kwd speckwds)
        !          2450:         (unless (numberp (cdr (assoc kwd indices)))
        !          2451:           (error "`%s' is not a valid slot name for %s"
        !          2452:                  (prin1-to-string kwd) (prin1-to-string name))))
        !          2453:       ;; update initforms
        !          2454:       (setq initalist
        !          2455:             (pairlis speckwds
        !          2456:                      (do* ;;protect values from further evaluation
        !          2457:                          ((ptr specvals (cdr ptr))
        !          2458:                           (val (car ptr) (car ptr))
        !          2459:                           (result '()))
        !          2460:                          ((endp ptr) (nreverse result))
        !          2461:                        (setq result
        !          2462:                              (cons (list 'quote val)
        !          2463:                                    result)))
        !          2464:                      (copy-sequence initforms)))
        !          2465:       ;; compute definitive initializers
        !          2466:       (setq initializers
        !          2467:             (do* ;;gather the values of the most definitive forms
        !          2468:                 ((ptr indices (cdr ptr))
        !          2469:                  (key (caar ptr) (caar ptr))
        !          2470:                  (result '()))
        !          2471:                 ((endp ptr) (nreverse result))
        !          2472:               (setq result
        !          2473:                     (cons (eval (cdr (assoc key initalist))) result))))
        !          2474:       ;; do real initialization
        !          2475:       (apply (function vector)
        !          2476:              (cons name initializers)))))
        !          2477: 
        !          2478: ;;;; end of cl-structs.el
        !          2479: 
        !          2480: ;;;; end of cl.el

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.