Return to cl.el CVS log

Up to [Apple XNU] / GNUtools / emacs / lisp

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

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