2480 lines
88 KiB
EmacsLisp
2480 lines
88 KiB
EmacsLisp
;; Common-Lisp extensions for GNU Emacs Lisp.
|
||
;; Copyright (C) 1987, 1988 Free Software Foundation, Inc.
|
||
|
||
;; This file is part of GNU Emacs.
|
||
|
||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 1, or (at your option)
|
||
;; any later version.
|
||
|
||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with GNU Emacs; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
||
|
||
;;;;
|
||
;;;; These are extensions to Emacs Lisp that provide some form of
|
||
;;;; Common Lisp compatibility, beyond what is already built-in
|
||
;;;; in Emacs Lisp.
|
||
;;;;
|
||
;;;; When developing them, I had the code spread among several files.
|
||
;;;; This file 'cl.el' is a concatenation of those original files,
|
||
;;;; minus some declarations that became redundant. The marks between
|
||
;;;; the original files can be found easily, as they are lines that
|
||
;;;; begin with four semicolons (as this does). The names of the
|
||
;;;; original parts follow the four semicolons in uppercase, those
|
||
;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS,
|
||
;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT. If you
|
||
;;;; add functions to this file, you might want to put them in a place
|
||
;;;; that is compatible with the division above (or invent your own
|
||
;;;; categories).
|
||
;;;;
|
||
;;;; To compile this file, make sure you load it first. This is
|
||
;;;; because many things are implemented as macros and now that all
|
||
;;;; the files are concatenated together one cannot ensure that
|
||
;;;; declaration always precedes use.
|
||
;;;;
|
||
;;;; Bug reports, suggestions and comments,
|
||
;;;; to quiroz@cs.rochester.edu
|
||
|
||
(provide 'cl)
|
||
|
||
|
||
;;;; GLOBAL
|
||
;;;; This file provides utilities and declarations that are global
|
||
;;;; to Common Lisp and so might be used by more than one of the
|
||
;;;; other libraries. Especially, I intend to keep here some
|
||
;;;; utilities that help parsing/destructuring some difficult calls.
|
||
;;;;
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
(defmacro psetq (&rest pairs)
|
||
"(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE.
|
||
All the VALUEs are evaluated, and then all the VARIABLEs are set.
|
||
Aside from order of evaluation, this is the same as `setq'."
|
||
(let ((nforms (length pairs)) ;count of args
|
||
;; next are used to destructure the call
|
||
symbols ;even numbered args
|
||
forms ;odd numbered args
|
||
;; these are used to generate code
|
||
bindings ;for the let
|
||
newsyms ;list of gensyms
|
||
assignments ;for the setq
|
||
;; auxiliary indices
|
||
i)
|
||
;; check there is a reasonable number of forms
|
||
(if (/= (% nforms 2) 0)
|
||
(error "Odd number of arguments to `psetq'"))
|
||
|
||
;; destructure the args
|
||
(let ((ptr pairs) ;traverses the args
|
||
var ;visits each symbol position
|
||
)
|
||
(while ptr
|
||
(setq var (car ptr)) ;next variable
|
||
(if (not (symbolp var))
|
||
(error "`psetq' expected a symbol, found '%s'."
|
||
(prin1-to-string var)))
|
||
(setq symbols (cons var symbols))
|
||
(setq forms (cons (car (cdr ptr)) forms))
|
||
(setq ptr (cdr (cdr ptr)))))
|
||
|
||
;; assign new symbols to the bindings
|
||
(let ((ptr forms) ;traverses the forms
|
||
form ;each form goes here
|
||
newsym ;gensym for current value of form
|
||
)
|
||
(while ptr
|
||
(setq form (car ptr))
|
||
(setq newsym (gensym))
|
||
(setq bindings (cons (list newsym form) bindings))
|
||
(setq newsyms (cons newsym newsyms))
|
||
(setq ptr (cdr ptr))))
|
||
(setq newsyms (nreverse newsyms)) ;to sync with symbols
|
||
|
||
;; pair symbols with newsyms for assignment
|
||
(let ((ptr1 symbols) ;traverses original names
|
||
(ptr2 newsyms) ;traverses new symbols
|
||
)
|
||
(while ptr1
|
||
(setq assignments
|
||
(cons (car ptr1) (cons (car ptr2) assignments)))
|
||
(setq ptr1 (cdr ptr1))
|
||
(setq ptr2 (cdr ptr2))))
|
||
|
||
;; generate code
|
||
(list 'let
|
||
bindings
|
||
(cons 'setq assignments)
|
||
nil)))
|
||
|
||
;;; utilities
|
||
;;;
|
||
;;; pair-with-newsyms takes a list and returns a list of lists of the
|
||
;;; form (newsym form), such that a let* can then bind the evaluation
|
||
;;; of the forms to the newsyms. The idea is to guarantee correct
|
||
;;; order of evaluation of the subforms of a setf. It also returns a
|
||
;;; list of the newsyms generated, in the corresponding order.
|
||
|
||
(defun pair-with-newsyms (oldforms)
|
||
"PAIR-WITH-NEWSYMS OLDFORMS
|
||
The top-level components of the list oldforms are paired with fresh
|
||
symbols, the pairings list and the newsyms list are returned."
|
||
(do ((ptr oldforms (cdr ptr))
|
||
(bindings '())
|
||
(newsyms '()))
|
||
((endp ptr) (values (nreverse bindings) (nreverse newsyms)))
|
||
(let ((newsym (gentemp)))
|
||
(setq bindings (cons (list newsym (car ptr)) bindings))
|
||
(setq newsyms (cons newsym newsyms)))))
|
||
|
||
(defun zip-lists (evens odds)
|
||
"Merge two lists EVENS and ODDS, taking elts from each list alternatingly.
|
||
EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose
|
||
even numbered elements (0,2,...) come from EVENS and whose odd
|
||
numbered elements (1,3,...) come from ODDS.
|
||
The construction stops when the shorter list is exhausted."
|
||
(do* ((p0 evens (cdr p0))
|
||
(p1 odds (cdr p1))
|
||
(even (car p0) (car p0))
|
||
(odd (car p1) (car p1))
|
||
(result '()))
|
||
((or (endp p0) (endp p1))
|
||
(nreverse result))
|
||
(setq result
|
||
(cons odd (cons even result)))))
|
||
|
||
(defun unzip-list (list)
|
||
"Extract even and odd elements of LIST into two separate lists.
|
||
The argument LIST is separated in two strands, the even and the odd
|
||
numbered elements. Numbering starts with 0, so the first element
|
||
belongs in EVENS. No check is made that there is an even number of
|
||
elements to start with."
|
||
(do* ((ptr list (cddr ptr))
|
||
(this (car ptr) (car ptr))
|
||
(next (cadr ptr) (cadr ptr))
|
||
(evens '())
|
||
(odds '()))
|
||
((endp ptr)
|
||
(values (nreverse evens) (nreverse odds)))
|
||
(setq evens (cons this evens))
|
||
(setq odds (cons next odds))))
|
||
|
||
(defun reassemble-argslists (argslists)
|
||
"(reassemble-argslists ARGSLISTS).
|
||
ARGSLISTS is a list of sequences. Return a list of lists, the first
|
||
sublist being all the entries coming from ELT 0 of the original
|
||
sublists, the next those coming from ELT 1 and so on, until the
|
||
shortest list is exhausted."
|
||
(let* ((minlen (apply 'min (mapcar 'length argslists)))
|
||
(result '()))
|
||
(dotimes (i minlen (nreverse result))
|
||
;; capture all the elements at index i
|
||
(setq result
|
||
(cons (mapcar
|
||
(function (lambda (sublist) (elt sublist i)))
|
||
argslists)
|
||
result)))))
|
||
|
||
;;; to help parsing keyword arguments
|
||
|
||
(defun build-klist (argslist acceptable)
|
||
"Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE.
|
||
ARGSLIST is a list, presumably the &rest argument of a call, whose
|
||
even numbered elements must be keywords.
|
||
ACCEPTABLE is a list of keywords, the only ones that are truly acceptable.
|
||
The result is an alist containing the arguments named by the keywords
|
||
in ACCEPTABLE, or nil if something failed."
|
||
|
||
;; check legality of the arguments, then destructure them
|
||
(unless (and (listp argslist)
|
||
(evenp (length argslist)))
|
||
(error "Odd number of keyword-args"))
|
||
(unless (and (listp acceptable)
|
||
(every 'keywordp acceptable))
|
||
(error "Second arg should be a list of keywords"))
|
||
(multiple-value-bind
|
||
(keywords forms)
|
||
(unzip-list argslist)
|
||
(unless (every 'keywordp keywords)
|
||
(error "Expected keywords, found `%s'"
|
||
(prin1-to-string keywords)))
|
||
(do* ;pick up the pieces
|
||
((auxlist ;auxiliary a-list, may
|
||
(pairlis keywords forms)) ;contain repetitions and junk
|
||
(ptr acceptable (cdr ptr)) ;pointer in acceptable
|
||
(this (car ptr) (car ptr)) ;current acceptable keyword
|
||
(auxval nil) ;used to move values around
|
||
(alist '())) ;used to build the result
|
||
((endp ptr) alist)
|
||
;; if THIS appears in auxlist, use its value
|
||
(when (setq auxval (assoc this auxlist))
|
||
(setq alist (cons auxval alist))))))
|
||
|
||
|
||
;;; Checking that a list of symbols contains no duplicates is a common
|
||
;;; task when checking the legality of some macros. The check for 'eq
|
||
;;; pairs can be too expensive, as it is quadratic on the length of
|
||
;;; the list. I use a 4-pass, linear, counting approach. It surely
|
||
;;; loses on small lists (less than 5 elements?), but should win for
|
||
;;; larger lists. The fourth pass could be eliminated.
|
||
;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the
|
||
;;; 4th pass.
|
||
(defun duplicate-symbols-p (list)
|
||
"Find all symbols appearing more than once in LIST.
|
||
Return a list of all such duplicates; `nil' if there are no duplicates."
|
||
(let ((duplicates '()) ;result built here
|
||
(propname (gensym)) ;we use a fresh property
|
||
)
|
||
;; check validity
|
||
(unless (and (listp list)
|
||
(every 'symbolp list))
|
||
(error "A list of symbols is needed"))
|
||
;; pass 1: mark
|
||
(dolist (x list)
|
||
(put x propname 0))
|
||
;; pass 2: count
|
||
(dolist (x list)
|
||
(put x propname (1+ (get x propname))))
|
||
;; pass 3: collect
|
||
(dolist (x list)
|
||
(if (> (get x propname) 1)
|
||
(setq duplicates (cons x duplicates))))
|
||
;; pass 4: unmark. eliminated.
|
||
;; (dolist (x list) (remprop x propname))
|
||
;; return result
|
||
duplicates))
|
||
|
||
;;;; end of cl-global.el
|
||
|
||
;;;; SYMBOLS
|
||
;;;; This file provides the gentemp function, which generates fresh
|
||
;;;; symbols, plus some other minor Common Lisp symbol tools.
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
;;; Keywords. There are no packages in Emacs Lisp, so this is only a
|
||
;;; kludge around to let things be "as if" a keyword package was around.
|
||
|
||
(defmacro defkeyword (x &optional docstring)
|
||
"Make symbol X a keyword (symbol whose value is itself).
|
||
Optional second argument is a documentation string for it."
|
||
(cond
|
||
((symbolp x)
|
||
(list 'defconst x (list 'quote x)))
|
||
(t
|
||
(error "`%s' is not a symbol" (prin1-to-string x)))))
|
||
|
||
(defun keywordp (sym)
|
||
"Return `t' if SYM is a keyword."
|
||
(cond
|
||
((and (symbolp sym)
|
||
(char-equal (aref (symbol-name sym) 0) ?\:))
|
||
;; looks like one, make sure value is right
|
||
(set sym sym))
|
||
(t
|
||
nil)))
|
||
|
||
(defun keyword-of (sym)
|
||
"Return a keyword that is naturally associated with symbol SYM.
|
||
If SYM is keyword, the value is SYM.
|
||
Otherwise it is a keyword whose name is `:' followed by SYM's name."
|
||
(cond
|
||
((keywordp sym)
|
||
sym)
|
||
((symbolp sym)
|
||
(let ((newsym (intern (concat ":" (symbol-name sym)))))
|
||
(set newsym newsym)))
|
||
(t
|
||
(error "Expected a symbol, not `%s'" (prin1-to-string sym)))))
|
||
|
||
;;; Temporary symbols.
|
||
;;;
|
||
|
||
(defvar *gentemp-index* 0
|
||
"Integer used by gentemp to produce new names.")
|
||
|
||
(defvar *gentemp-prefix* "T$$_"
|
||
"Names generated by gentemp begin with this string by default.")
|
||
|
||
(defun gentemp (&optional prefix oblist)
|
||
"Generate a fresh interned symbol.
|
||
There are 2 optional arguments, PREFIX and OBLIST. PREFIX is the
|
||
string that begins the new name, OBLIST is the obarray used to search for
|
||
old names. The defaults are just right, YOU SHOULD NEVER NEED THESE
|
||
ARGUMENTS IN YOUR OWN CODE."
|
||
(if (null prefix)
|
||
(setq prefix *gentemp-prefix*))
|
||
(if (null oblist)
|
||
(setq oblist obarray)) ;default for the intern functions
|
||
(let ((newsymbol nil)
|
||
(newname))
|
||
(while (not newsymbol)
|
||
(setq newname (concat prefix *gentemp-index*))
|
||
(setq *gentemp-index* (+ *gentemp-index* 1))
|
||
(if (not (intern-soft newname oblist))
|
||
(setq newsymbol (intern newname oblist))))
|
||
newsymbol))
|
||
|
||
(defvar *gensym-index* 0
|
||
"Integer used by gensym to produce new names.")
|
||
|
||
(defvar *gensym-prefix* "G$$_"
|
||
"Names generated by gensym begin with this string by default.")
|
||
|
||
(defun gensym (&optional prefix)
|
||
"Generate a fresh uninterned symbol.
|
||
There is an optional argument, PREFIX. PREFIX is the
|
||
string that begins the new name. Most people take just the default,
|
||
except when debugging needs suggest otherwise."
|
||
(if (null prefix)
|
||
(setq prefix *gensym-prefix*))
|
||
(let ((newsymbol nil)
|
||
(newname ""))
|
||
(while (not newsymbol)
|
||
(setq newname (concat prefix *gensym-index*))
|
||
(setq *gensym-index* (+ *gensym-index* 1))
|
||
(if (not (intern-soft newname))
|
||
(setq newsymbol (make-symbol newname))))
|
||
newsymbol))
|
||
|
||
;;;; end of cl-symbols.el
|
||
|
||
;;;; CONDITIONALS
|
||
;;;; This file provides some of the conditional constructs of
|
||
;;;; Common Lisp. Total compatibility is again impossible, as the
|
||
;;;; 'if' form is different in both languages, so only a good
|
||
;;;; approximation is desired.
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
;;; indentation info
|
||
(put 'case 'lisp-indent-hook 1)
|
||
(put 'ecase 'lisp-indent-hook 1)
|
||
(put 'when 'lisp-indent-hook 1)
|
||
(put 'unless 'lisp-indent-hook 1)
|
||
|
||
;;; WHEN and UNLESS
|
||
;;; These two forms are simplified ifs, with a single branch.
|
||
|
||
(defmacro when (condition &rest body)
|
||
"(when CONDITION . BODY) => evaluate BODY if CONDITION is true."
|
||
(list* 'if (list 'not condition) '() body))
|
||
|
||
(defmacro unless (condition &rest body)
|
||
"(unless CONDITION . BODY) => evaluate BODY if CONDITION is false."
|
||
(list* 'if condition '() body))
|
||
|
||
;;; CASE and ECASE
|
||
;;; CASE selects among several clauses, based on the value (evaluated)
|
||
;;; of a expression and a list of (unevaluated) key values. ECASE is
|
||
;;; the same, but signals an error if no clause is activated.
|
||
|
||
(defmacro case (expr &rest cases)
|
||
"(case EXPR . CASES) => evals EXPR, chooses from CASES on that value.
|
||
EXPR -> any form
|
||
CASES -> list of clauses, non empty
|
||
CLAUSE -> HEAD . BODY
|
||
HEAD -> t = catch all, must be last clause
|
||
-> otherwise = same as t
|
||
-> nil = illegal
|
||
-> atom = activated if (eql EXPR HEAD)
|
||
-> list of atoms = activated if (member EXPR HEAD)
|
||
BODY -> list of forms, implicit PROGN is built around it.
|
||
EXPR is evaluated only once."
|
||
(let* ((newsym (gentemp))
|
||
(clauses (case-clausify cases newsym)))
|
||
;; convert case into a cond inside a let
|
||
(list 'let
|
||
(list (list newsym expr))
|
||
(list* 'cond (nreverse clauses)))))
|
||
|
||
(defmacro ecase (expr &rest cases)
|
||
"(ecase EXPR . CASES) => like `case', but error if no case fits.
|
||
`t'-clauses are not allowed."
|
||
(let* ((newsym (gentemp))
|
||
(clauses (case-clausify cases newsym)))
|
||
;; check that no 't clause is present.
|
||
;; case-clausify would put one such at the beginning of clauses
|
||
(if (eq (caar clauses) t)
|
||
(error "No clause-head should be `t' or `otherwise' for `ecase'"))
|
||
;; insert error-catching clause
|
||
(setq clauses
|
||
(cons
|
||
(list 't (list 'error
|
||
"ecase on %s = %s failed to take any branch."
|
||
(list 'quote expr)
|
||
(list 'prin1-to-string newsym)))
|
||
clauses))
|
||
;; generate code as usual
|
||
(list 'let
|
||
(list (list newsym expr))
|
||
(list* 'cond (nreverse clauses)))))
|
||
|
||
|
||
(defun case-clausify (cases newsym)
|
||
"CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond'
|
||
Converts the CASES of a [e]case macro into cond clauses to be
|
||
evaluated inside a let that binds NEWSYM. Returns the clauses in
|
||
reverse order."
|
||
(do* ((currentpos cases (cdr currentpos))
|
||
(nextpos (cdr cases) (cdr nextpos))
|
||
(curclause (car cases) (car currentpos))
|
||
(result '()))
|
||
((endp currentpos) result)
|
||
(let ((head (car curclause))
|
||
(body (cdr curclause)))
|
||
;; construct a cond-clause according to the head
|
||
(cond
|
||
((null head)
|
||
(error "Case clauses cannot have null heads: `%s'"
|
||
(prin1-to-string curclause)))
|
||
((or (eq head 't)
|
||
(eq head 'otherwise))
|
||
;; check it is the last clause
|
||
(if (not (endp nextpos))
|
||
(error "Clause with `t' or `otherwise' head must be last"))
|
||
;; accept this clause as a 't' for cond
|
||
(setq result (cons (cons 't body) result)))
|
||
((atom head)
|
||
(setq result
|
||
(cons (cons (list 'eql newsym (list 'quote head)) body)
|
||
result)))
|
||
((listp head)
|
||
(setq result
|
||
(cons (cons (list 'member newsym (list 'quote head)) body)
|
||
result)))
|
||
(t
|
||
;; catch-all for this parser
|
||
(error "Don't know how to parse case clause `%s'."
|
||
(prin1-to-string head)))))))
|
||
|
||
;;;; end of cl-conditionals.el
|
||
|
||
;;;; ITERATIONS
|
||
;;;; This file provides simple iterative macros (a la Common Lisp)
|
||
;;;; constructed on the basis of let, let* and while, which are the
|
||
;;;; primitive binding/iteration constructs of Emacs Lisp
|
||
;;;;
|
||
;;;; The Common Lisp iterations use to have a block named nil
|
||
;;;; wrapped around them, and allow declarations at the beginning
|
||
;;;; of their bodies and you can return a value using (return ...).
|
||
;;;; Nothing of the sort exists in Emacs Lisp, so I haven't tried
|
||
;;;; to imitate these behaviors.
|
||
;;;;
|
||
;;;; Other than the above, the semantics of Common Lisp are
|
||
;;;; correctly reproduced to the extent this was reasonable.
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
;;; some lisp-indentation information
|
||
(put 'do 'lisp-indent-hook 2)
|
||
(put 'do* 'lisp-indent-hook 2)
|
||
(put 'dolist 'lisp-indent-hook 1)
|
||
(put 'dotimes 'lisp-indent-hook 1)
|
||
(put 'do-symbols 'lisp-indent-hook 1)
|
||
(put 'do-all-symbols 'lisp-indent-hook 1)
|
||
|
||
|
||
(defmacro do (stepforms endforms &rest body)
|
||
"(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables.
|
||
STEPFORMS must be a list of symbols or lists. In the second case, the
|
||
lists must start with a symbol and contain up to two more forms. In
|
||
the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms
|
||
are the initial value (def. NIL) and the form to step (def. itself).
|
||
The values used by initialization and stepping are computed in parallel.
|
||
The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION
|
||
evaluates to true in any iteration, ENDBODY is evaluated and the last
|
||
form in it is returned.
|
||
The BODY (which may be empty) is evaluated at every iteration, with
|
||
the symbols of the STEPFORMS bound to the initial or stepped values."
|
||
;; check the syntax of the macro
|
||
(and (check-do-stepforms stepforms)
|
||
(check-do-endforms endforms))
|
||
;; construct emacs-lisp equivalent
|
||
(let ((initlist (extract-do-inits stepforms))
|
||
(steplist (extract-do-steps stepforms))
|
||
(endcond (car endforms))
|
||
(endbody (cdr endforms)))
|
||
(cons 'let (cons initlist
|
||
(cons (cons 'while (cons (list 'not endcond)
|
||
(append body steplist)))
|
||
(append endbody))))))
|
||
|
||
|
||
(defmacro do* (stepforms endforms &rest body)
|
||
"`do*' is to `do' as `let*' is to `let'.
|
||
STEPFORMS must be a list of symbols or lists. In the second case, the
|
||
lists must start with a symbol and contain up to two more forms. In
|
||
the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms
|
||
are the initial value (def. NIL) and the form to step (def. itself).
|
||
Initializations and steppings are done in the sequence they are written.
|
||
The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION
|
||
evaluates to true in any iteration, ENDBODY is evaluated and the last
|
||
form in it is returned.
|
||
The BODY (which may be empty) is evaluated at every iteration, with
|
||
the symbols of the STEPFORMS bound to the initial or stepped values."
|
||
;; check the syntax of the macro
|
||
(and (check-do-stepforms stepforms)
|
||
(check-do-endforms endforms))
|
||
;; construct emacs-lisp equivalent
|
||
(let ((initlist (extract-do-inits stepforms))
|
||
(steplist (extract-do*-steps stepforms))
|
||
(endcond (car endforms))
|
||
(endbody (cdr endforms)))
|
||
(cons 'let* (cons initlist
|
||
(cons (cons 'while (cons (list 'not endcond)
|
||
(append body steplist)))
|
||
(append endbody))))))
|
||
|
||
|
||
;;; DO and DO* share the syntax checking functions that follow.
|
||
|
||
(defun check-do-stepforms (forms)
|
||
"True if FORMS is a valid stepforms for the do[*] macro (q.v.)"
|
||
(cond
|
||
((nlistp forms)
|
||
(error "Init/Step form for do[*] should be a list, not `%s'"
|
||
(prin1-to-string forms)))
|
||
(t ;valid list
|
||
;; each entry must be a symbol, or a list whose car is a symbol
|
||
;; and whose length is no more than three
|
||
(mapcar
|
||
(function
|
||
(lambda (entry)
|
||
(cond
|
||
((or (symbolp entry)
|
||
(and (listp entry)
|
||
(symbolp (car entry))
|
||
(< (length entry) 4)))
|
||
t)
|
||
(t
|
||
(error
|
||
"Init/Step must be symbol or (symbol [init [step]]), not `%s'"
|
||
(prin1-to-string entry))))))
|
||
forms))))
|
||
|
||
(defun check-do-endforms (forms)
|
||
"True if FORMS is a valid endforms for the do[*] macro (q.v.)"
|
||
(cond
|
||
((listp forms)
|
||
t)
|
||
(t
|
||
(error "Termination form for do macro should be a list, not `%s'"
|
||
(prin1-to-string forms)))))
|
||
|
||
(defun extract-do-inits (forms)
|
||
"Returns a list of the initializations (for do) in FORMS
|
||
-a stepforms, see the do macro-. Forms is assumed syntactically valid."
|
||
(mapcar
|
||
(function
|
||
(lambda (entry)
|
||
(cond
|
||
((symbolp entry)
|
||
(list entry nil))
|
||
((listp entry)
|
||
(list (car entry) (cadr entry))))))
|
||
forms))
|
||
|
||
;;; There used to be a reason to deal with DO differently than with
|
||
;;; DO*. The writing of PSETQ has made it largely unnecessary.
|
||
|
||
(defun extract-do-steps (forms)
|
||
"EXTRACT-DO-STEPS FORMS => an s-expr
|
||
FORMS is the stepforms part of a DO macro (q.v.). This function
|
||
constructs an s-expression that does the stepping at the end of an
|
||
iteration."
|
||
(list (cons 'psetq (select-stepping-forms forms))))
|
||
|
||
(defun extract-do*-steps (forms)
|
||
"EXTRACT-DO*-STEPS FORMS => an s-expr
|
||
FORMS is the stepforms part of a DO* macro (q.v.). This function
|
||
constructs an s-expression that does the stepping at the end of an
|
||
iteration."
|
||
(list (cons 'setq (select-stepping-forms forms))))
|
||
|
||
(defun select-stepping-forms (forms)
|
||
"Separate only the forms that cause stepping."
|
||
(let ((result '()) ;ends up being (... var form ...)
|
||
(ptr forms) ;to traverse the forms
|
||
entry ;to explore each form in turn
|
||
)
|
||
(while ptr ;(not (endp entry)) might be safer
|
||
(setq entry (car ptr))
|
||
(cond
|
||
((and (listp entry)
|
||
(= (length entry) 3))
|
||
(setq result (append ;append in reverse order!
|
||
(list (caddr entry) (car entry))
|
||
result))))
|
||
(setq ptr (cdr ptr))) ;step in the list of forms
|
||
;;put things back in the
|
||
;;correct order before return
|
||
(nreverse result)))
|
||
|
||
;;; Other iterative constructs
|
||
|
||
(defmacro dolist (stepform &rest body)
|
||
"(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST.
|
||
The RESULTFORM defaults to nil. The VAR is bound to successive
|
||
elements of the value of LIST and remains bound (to the nil value) when the
|
||
RESULTFORM is evaluated."
|
||
;; check sanity
|
||
(cond
|
||
((nlistp stepform)
|
||
(error "Stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'"
|
||
(prin1-to-string stepform)))
|
||
((not (symbolp (car stepform)))
|
||
(error "First component of stepform should be a symbol, not `%s'"
|
||
(prin1-to-string (car stepform))))
|
||
((> (length stepform) 3)
|
||
(error "Too many components in stepform `%s'"
|
||
(prin1-to-string stepform))))
|
||
;; generate code
|
||
(let* ((var (car stepform))
|
||
(listform (cadr stepform))
|
||
(resultform (caddr stepform)))
|
||
(list 'progn
|
||
(list 'mapcar
|
||
(list 'function
|
||
(cons 'lambda (cons (list var) body)))
|
||
listform)
|
||
(list 'let
|
||
(list (list var nil))
|
||
resultform))))
|
||
|
||
(defmacro dotimes (stepform &rest body)
|
||
"(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR.
|
||
The COUNTFORM should return a positive integer. The VAR is bound to
|
||
successive integers from 0 to COUNTFORM-1 and the BODY is repeated for
|
||
each of them. At the end, the RESULTFORM is evaluated and its value
|
||
returned. During this last evaluation, the VAR is still bound, and its
|
||
value is the number of times the iteration occurred. An omitted RESULTFORM
|
||
defaults to nil."
|
||
;; check sanity
|
||
(cond
|
||
((nlistp stepform)
|
||
(error "Stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'"
|
||
(prin1-to-string stepform)))
|
||
((not (symbolp (car stepform)))
|
||
(error "First component of stepform should be a symbol, not `%s'"
|
||
(prin1-to-string (car stepform))))
|
||
((> (length stepform) 3)
|
||
(error "Too many components in stepform `%s'"
|
||
(prin1-to-string stepform))))
|
||
;; generate code
|
||
(let* ((var (car stepform))
|
||
(countform (cadr stepform))
|
||
(resultform (caddr stepform))
|
||
(newsym (gentemp)))
|
||
(list
|
||
'let* (list (list newsym countform))
|
||
(list*
|
||
'do*
|
||
(list (list var 0 (list '+ var 1)))
|
||
(list (list '>= var newsym) resultform)
|
||
body))))
|
||
|
||
(defmacro do-symbols (stepform &rest body)
|
||
"(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY)
|
||
The VAR is bound to each of the symbols in OBARRAY (def. obarray) and
|
||
the BODY is repeatedly performed for each of those bindings. At the
|
||
end, RESULTFORM (def. nil) is evaluated and its value returned.
|
||
During this last evaluation, the VAR is still bound and its value is nil.
|
||
See also the function `mapatoms'."
|
||
;; check sanity
|
||
(cond
|
||
((nlistp stepform)
|
||
(error "Stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'"
|
||
(prin1-to-string stepform)))
|
||
((not (symbolp (car stepform)))
|
||
(error "First component of stepform should be a symbol, not `%s'"
|
||
(prin1-to-string (car stepform))))
|
||
((> (length stepform) 3)
|
||
(error "Too many components in stepform `%s'"
|
||
(prin1-to-string stepform))))
|
||
;; generate code
|
||
(let* ((var (car stepform))
|
||
(oblist (cadr stepform))
|
||
(resultform (caddr stepform)))
|
||
(list 'progn
|
||
(list 'mapatoms
|
||
(list 'function
|
||
(cons 'lambda (cons (list var) body)))
|
||
oblist)
|
||
(list 'let
|
||
(list (list var nil))
|
||
resultform))))
|
||
|
||
|
||
(defmacro do-all-symbols (stepform &rest body)
|
||
"(do-all-symbols (VAR [RESULTFORM]) . BODY)
|
||
Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)."
|
||
(list*
|
||
'do-symbols
|
||
(list (car stepform) 'obarray (cadr stepform))
|
||
body))
|
||
|
||
(defmacro loop (&rest body)
|
||
"(loop . BODY) repeats BODY indefinitely and does not return.
|
||
Normally BODY uses `throw' or `signal' to cause an exit.
|
||
The forms in BODY should be lists, as non-lists are reserved for new features."
|
||
;; check that the body doesn't have atomic forms
|
||
(if (nlistp body)
|
||
(error "Body of `loop' should be a list of lists or nil")
|
||
;; ok, it is a list, check for atomic components
|
||
(mapcar
|
||
(function (lambda (component)
|
||
(if (nlistp component)
|
||
(error "Components of `loop' should be lists"))))
|
||
body)
|
||
;; build the infinite loop
|
||
(cons 'while (cons 't body))))
|
||
|
||
;;;; end of cl-iterations.el
|
||
|
||
;;;; LISTS
|
||
;;;; This file provides some of the lists machinery of Common-Lisp
|
||
;;;; in a way compatible with Emacs Lisp. Especially, see the the
|
||
;;;; typical c[ad]*r functions.
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
|
||
|
||
;;; Synonyms for list functions
|
||
(defun first (x)
|
||
"Synonym for `car'"
|
||
(car x))
|
||
|
||
(defun second (x)
|
||
"Return the second element of the list LIST."
|
||
(nth 1 x))
|
||
|
||
(defun third (x)
|
||
"Return the third element of the list LIST."
|
||
(nth 2 x))
|
||
|
||
(defun fourth (x)
|
||
"Return the fourth element of the list LIST."
|
||
(nth 3 x))
|
||
|
||
(defun fifth (x)
|
||
"Return the fifth element of the list LIST."
|
||
(nth 4 x))
|
||
|
||
(defun sixth (x)
|
||
"Return the sixth element of the list LIST."
|
||
(nth 5 x))
|
||
|
||
(defun seventh (x)
|
||
"Return the seventh element of the list LIST."
|
||
(nth 6 x))
|
||
|
||
(defun eighth (x)
|
||
"Return the eighth element of the list LIST."
|
||
(nth 7 x))
|
||
|
||
(defun ninth (x)
|
||
"Return the ninth element of the list LIST."
|
||
(nth 8 x))
|
||
|
||
(defun tenth (x)
|
||
"Return the tenth element of the list LIST."
|
||
(nth 9 x))
|
||
|
||
(defun rest (x)
|
||
"Synonym for `cdr'"
|
||
(cdr x))
|
||
|
||
(defun endp (x)
|
||
"t if X is nil, nil if X is a cons; error otherwise."
|
||
(if (listp x)
|
||
(null x)
|
||
(error "endp received a non-cons, non-null argument `%s'"
|
||
(prin1-to-string x))))
|
||
|
||
(defun last (x)
|
||
"Returns the last link in the list LIST."
|
||
(if (nlistp x)
|
||
(error "Arg to `last' must be a list"))
|
||
(do ((current-cons x (cdr current-cons))
|
||
(next-cons (cdr x) (cdr next-cons)))
|
||
((endp next-cons) current-cons)))
|
||
|
||
(defun list-length (x) ;taken from CLtL sect. 15.2
|
||
"Returns the length of a non-circular list, or `nil' for a circular one."
|
||
(do ((n 0) ;counter
|
||
(fast x (cddr fast)) ;fast pointer, leaps by 2
|
||
(slow x (cdr slow)) ;slow pointer, leaps by 1
|
||
(ready nil)) ;indicates termination
|
||
(ready n)
|
||
(cond
|
||
((endp fast)
|
||
(setq ready t)) ;return n
|
||
((endp (cdr fast))
|
||
(setq n (+ n 1))
|
||
(setq ready t)) ;return n+1
|
||
((and (eq fast slow) (> n 0))
|
||
(setq n nil)
|
||
(setq ready t)) ;return nil
|
||
(t
|
||
(setq n (+ n 2)))))) ;just advance counter
|
||
|
||
(defun member (item list)
|
||
"Look for ITEM in LIST; return first link in LIST whose car is `eql' to ITEM."
|
||
(let ((ptr list)
|
||
(done nil)
|
||
(result '()))
|
||
(while (not (or done (endp ptr)))
|
||
(cond ((eql item (car ptr))
|
||
(setq done t)
|
||
(setq result ptr)))
|
||
(setq ptr (cdr ptr)))
|
||
result))
|
||
|
||
(defun butlast (list &optional n)
|
||
"Return a new list like LIST but sans the last N elements.
|
||
N defaults to 1. If the list doesn't have N elements, nil is returned."
|
||
(if (null n) (setq n 1))
|
||
(reverse (nthcdr n (reverse list))))
|
||
|
||
(defun list* (arg &rest others)
|
||
"Return a new list containing the first arguments consed onto the last arg.
|
||
Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)."
|
||
(if (null others)
|
||
arg
|
||
(let* ((allargs (cons arg others))
|
||
(front (butlast allargs))
|
||
(back (last allargs)))
|
||
(rplacd (last front) (car back))
|
||
front)))
|
||
|
||
(defun adjoin (item list)
|
||
"Return a list which contains ITEM but is otherwise like LIST.
|
||
If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST).
|
||
When comparing ITEM against elements, `eql' is used."
|
||
(cond
|
||
((member item list)
|
||
list)
|
||
(t
|
||
(cons item list))))
|
||
|
||
(defun ldiff (list sublist)
|
||
"Return a new list like LIST but sans SUBLIST.
|
||
SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
|
||
(do ((result '())
|
||
(curcons list (cdr curcons)))
|
||
((or (endp curcons) (eq curcons sublist))
|
||
(reverse result))
|
||
(setq result (cons (car curcons) result))))
|
||
|
||
;;; The popular c[ad]*r functions.
|
||
|
||
(defun caar (X)
|
||
"Return the car of the car of X."
|
||
(car (car X)))
|
||
|
||
(defun cadr (X)
|
||
"Return the car of the cdr of X."
|
||
(car (cdr X)))
|
||
|
||
(defun cdar (X)
|
||
"Return the cdr of the car of X."
|
||
(cdr (car X)))
|
||
|
||
(defun cddr (X)
|
||
"Return the cdr of the cdr of X."
|
||
(cdr (cdr X)))
|
||
|
||
(defun caaar (X)
|
||
"Return the car of the car of the car of X."
|
||
(car (car (car X))))
|
||
|
||
(defun caadr (X)
|
||
"Return the car of the car of the cdr of X."
|
||
(car (car (cdr X))))
|
||
|
||
(defun cadar (X)
|
||
"Return the car of the cdr of the car of X."
|
||
(car (cdr (car X))))
|
||
|
||
(defun cdaar (X)
|
||
"Return the cdr of the car of the car of X."
|
||
(cdr (car (car X))))
|
||
|
||
(defun caddr (X)
|
||
"Return the car of the cdr of the cdr of X."
|
||
(car (cdr (cdr X))))
|
||
|
||
(defun cdadr (X)
|
||
"Return the cdr of the car of the cdr of X."
|
||
(cdr (car (cdr X))))
|
||
|
||
(defun cddar (X)
|
||
"Return the cdr of the cdr of the car of X."
|
||
(cdr (cdr (car X))))
|
||
|
||
(defun cdddr (X)
|
||
"Return the cdr of the cdr of the cdr of X."
|
||
(cdr (cdr (cdr X))))
|
||
|
||
(defun caaaar (X)
|
||
"Return the car of the car of the car of the car of X."
|
||
(car (car (car (car X)))))
|
||
|
||
(defun caaadr (X)
|
||
"Return the car of the car of the car of the cdr of X."
|
||
(car (car (car (cdr X)))))
|
||
|
||
(defun caadar (X)
|
||
"Return the car of the car of the cdr of the car of X."
|
||
(car (car (cdr (car X)))))
|
||
|
||
(defun cadaar (X)
|
||
"Return the car of the cdr of the car of the car of X."
|
||
(car (cdr (car (car X)))))
|
||
|
||
(defun cdaaar (X)
|
||
"Return the cdr of the car of the car of the car of X."
|
||
(cdr (car (car (car X)))))
|
||
|
||
(defun caaddr (X)
|
||
"Return the car of the car of the cdr of the cdr of X."
|
||
(car (car (cdr (cdr X)))))
|
||
|
||
(defun cadadr (X)
|
||
"Return the car of the cdr of the car of the cdr of X."
|
||
(car (cdr (car (cdr X)))))
|
||
|
||
(defun cdaadr (X)
|
||
"Return the cdr of the car of the car of the cdr of X."
|
||
(cdr (car (car (cdr X)))))
|
||
|
||
(defun caddar (X)
|
||
"Return the car of the cdr of the cdr of the car of X."
|
||
(car (cdr (cdr (car X)))))
|
||
|
||
(defun cdadar (X)
|
||
"Return the cdr of the car of the cdr of the car of X."
|
||
(cdr (car (cdr (car X)))))
|
||
|
||
(defun cddaar (X)
|
||
"Return the cdr of the cdr of the car of the car of X."
|
||
(cdr (cdr (car (car X)))))
|
||
|
||
(defun cadddr (X)
|
||
"Return the car of the cdr of the cdr of the cdr of X."
|
||
(car (cdr (cdr (cdr X)))))
|
||
|
||
(defun cddadr (X)
|
||
"Return the cdr of the cdr of the car of the cdr of X."
|
||
(cdr (cdr (car (cdr X)))))
|
||
|
||
(defun cdaddr (X)
|
||
"Return the cdr of the car of the cdr of the cdr of X."
|
||
(cdr (car (cdr (cdr X)))))
|
||
|
||
(defun cdddar (X)
|
||
"Return the cdr of the cdr of the cdr of the car of X."
|
||
(cdr (cdr (cdr (car X)))))
|
||
|
||
(defun cddddr (X)
|
||
"Return the cdr of the cdr of the cdr of the cdr of X."
|
||
(cdr (cdr (cdr (cdr X)))))
|
||
|
||
;;; some inverses of the accessors are needed for setf purposes
|
||
|
||
(defun setnth (n list newval)
|
||
"Set (nth N LIST) to NEWVAL. Returns NEWVAL."
|
||
(rplaca (nthcdr n list) newval))
|
||
|
||
(defun setnthcdr (n list newval)
|
||
"SETNTHCDR N LIST NEWVAL => NEWVAL
|
||
As a side effect, sets the Nth cdr of LIST to NEWVAL."
|
||
(cond
|
||
((< n 0)
|
||
(error "N must be 0 or greater, not %d" n))
|
||
((= n 0)
|
||
(rplaca list (car newval))
|
||
(rplacd list (cdr newval))
|
||
newval)
|
||
(t
|
||
(rplacd (nthcdr (- n 1) list) newval))))
|
||
|
||
;;; A-lists machinery
|
||
|
||
(defun acons (key item alist)
|
||
"Return a new alist with KEY paired with ITEM; otherwise like ALIST.
|
||
Does not copy ALIST."
|
||
(cons (cons key item) alist))
|
||
|
||
(defun pairlis (keys data &optional alist)
|
||
"Return a new alist with each elt of KEYS paired with an elt of DATA;
|
||
optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must
|
||
have the same length."
|
||
(unless (= (length keys) (length data))
|
||
(error "Keys and data should be the same length"))
|
||
(do* ;;collect keys and data in front of alist
|
||
((kptr keys (cdr kptr)) ;traverses the keys
|
||
(dptr data (cdr dptr)) ;traverses the data
|
||
(key (car kptr) (car kptr)) ;current key
|
||
(item (car dptr) (car dptr)) ;current data item
|
||
(result alist))
|
||
((endp kptr) result)
|
||
(setq result (acons key item result))))
|
||
|
||
;;;; end of cl-lists.el
|
||
|
||
;;;; SEQUENCES
|
||
;;;; Emacs Lisp provides many of the 'sequences' functionality of
|
||
;;;; Common Lisp. This file provides a few things that were left out.
|
||
;;;;
|
||
|
||
|
||
(defkeyword :test "Used to designate positive (selection) tests.")
|
||
(defkeyword :test-not "Used to designate negative (rejection) tests.")
|
||
(defkeyword :key "Used to designate component extractions.")
|
||
(defkeyword :predicate "Used to define matching of sequence components.")
|
||
(defkeyword :start "Inclusive low index in sequence")
|
||
(defkeyword :end "Exclusive high index in sequence")
|
||
(defkeyword :start1 "Inclusive low index in first of two sequences.")
|
||
(defkeyword :start2 "Inclusive low index in second of two sequences.")
|
||
(defkeyword :end1 "Exclusive high index in first of two sequences.")
|
||
(defkeyword :end2 "Exclusive high index in second of two sequences.")
|
||
(defkeyword :count "Number of elements to affect.")
|
||
(defkeyword :from-end "T when counting backwards.")
|
||
|
||
(defun some (pred seq &rest moreseqs)
|
||
"Test PREDICATE on each element of SEQUENCE; is it ever non-nil?
|
||
Extra args are additional sequences; PREDICATE gets one arg from each
|
||
sequence and we advance down all the sequences together in lock-step.
|
||
A sequence means either a list or a vector."
|
||
(let ((args (reassemble-argslists (list* seq moreseqs))))
|
||
(do* ((ready nil) ;flag: return when t
|
||
(result nil) ;resulting value
|
||
(applyval nil) ;result of applying pred once
|
||
(remaining args
|
||
(cdr remaining)) ;remaining argument sets
|
||
(current (car remaining) ;current argument set
|
||
(car remaining)))
|
||
((or ready (endp remaining)) result)
|
||
(setq applyval (apply pred current))
|
||
(when applyval
|
||
(setq ready t)
|
||
(setq result applyval)))))
|
||
|
||
(defun every (pred seq &rest moreseqs)
|
||
"Test PREDICATE on each element of SEQUENCE; is it always non-nil?
|
||
Extra args are additional sequences; PREDICATE gets one arg from each
|
||
sequence and we advance down all the sequences together in lock-step.
|
||
A sequence means either a list or a vector."
|
||
(let ((args (reassemble-argslists (list* seq moreseqs))))
|
||
(do* ((ready nil) ;flag: return when t
|
||
(result t) ;resulting value
|
||
(applyval nil) ;result of applying pred once
|
||
(remaining args
|
||
(cdr remaining)) ;remaining argument sets
|
||
(current (car remaining) ;current argument set
|
||
(car remaining)))
|
||
((or ready (endp remaining)) result)
|
||
(setq applyval (apply pred current))
|
||
(unless applyval
|
||
(setq ready t)
|
||
(setq result nil)))))
|
||
|
||
(defun notany (pred seq &rest moreseqs)
|
||
"Test PREDICATE on each element of SEQUENCE; is it always nil?
|
||
Extra args are additional sequences; PREDICATE gets one arg from each
|
||
sequence and we advance down all the sequences together in lock-step.
|
||
A sequence means either a list or a vector."
|
||
(let ((args (reassemble-argslists (list* seq moreseqs))))
|
||
(do* ((ready nil) ;flag: return when t
|
||
(result t) ;resulting value
|
||
(applyval nil) ;result of applying pred once
|
||
(remaining args
|
||
(cdr remaining)) ;remaining argument sets
|
||
(current (car remaining) ;current argument set
|
||
(car remaining)))
|
||
((or ready (endp remaining)) result)
|
||
(setq applyval (apply pred current))
|
||
(when applyval
|
||
(setq ready t)
|
||
(setq result nil)))))
|
||
|
||
(defun notevery (pred seq &rest moreseqs)
|
||
"Test PREDICATE on each element of SEQUENCE; is it sometimes nil?
|
||
Extra args are additional sequences; PREDICATE gets one arg from each
|
||
sequence and we advance down all the sequences together in lock-step.
|
||
A sequence means either a list or a vector."
|
||
(let ((args (reassemble-argslists (list* seq moreseqs))))
|
||
(do* ((ready nil) ;flag: return when t
|
||
(result nil) ;resulting value
|
||
(applyval nil) ;result of applying pred once
|
||
(remaining args
|
||
(cdr remaining)) ;remaining argument sets
|
||
(current (car remaining) ;current argument set
|
||
(car remaining)))
|
||
((or ready (endp remaining)) result)
|
||
(setq applyval (apply pred current))
|
||
(unless applyval
|
||
(setq ready t)
|
||
(setq result t)))))
|
||
|
||
|
||
|
||
;;; an inverse of elt is needed for setf purposes
|
||
|
||
(defun setelt (seq n newval)
|
||
"In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL.
|
||
A sequence means either a list or a vector."
|
||
(let ((l (length seq)))
|
||
(cond
|
||
((or (< n 0)
|
||
(>= n l))
|
||
(error "N(%d) should be between 0 and %d" n l))
|
||
(t
|
||
;; only two cases need be considered
|
||
(cond
|
||
((listp seq)
|
||
(setnth n seq newval))
|
||
((arrayp seq)
|
||
(aset seq n newval))
|
||
(t
|
||
(error "SEQ should be a sequence, not `%s'"
|
||
(prin1-to-string seq))))))))
|
||
|
||
;;; Testing with keyword arguments.
|
||
;;;
|
||
;;; Many of the sequence functions use keywords to denote some stylized
|
||
;;; form of selecting entries in a sequence. The involved arguments
|
||
;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key
|
||
;;; marker), then they are passed to build-klist, who
|
||
;;; constructs an association list. That association list is used to
|
||
;;; test for satisfaction and matching.
|
||
|
||
(defun extract-from-klist (key klist &optional default)
|
||
"EXTRACT-FROM-KLIST KEY KLIST [DEFAULT] => value of KEY or DEFAULT
|
||
Extract value associated with KEY in KLIST (return DEFAULT if nil)."
|
||
(let ((retrieved (cdr (assoc key klist))))
|
||
(or retrieved default)))
|
||
|
||
(defun add-to-klist (key item klist)
|
||
"ADD-TO-KLIST KEY ITEM KLIST => new KLIST
|
||
Add association (KEY . ITEM) to KLIST."
|
||
(setq klist (acons key item klist)))
|
||
|
||
(defun elt-satisfies-test-p (item elt klist)
|
||
"ELT-SATISFIES-TEST-P ITEM ELT KLIST => t or nil
|
||
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
|
||
True if the given ITEM and ELT satisfy the test."
|
||
(let ((test (extract-from-klist :test klist))
|
||
(test-not (extract-from-klist :test-not klist))
|
||
(keyfn (extract-from-klist :key klist 'identity)))
|
||
(cond
|
||
(test
|
||
(funcall test item (funcall keyfn elt)))
|
||
(test-not
|
||
(not (funcall test-not item (funcall keyfn elt))))
|
||
(t ;should never happen
|
||
(error "Neither :test nor :test-not in `%s'"
|
||
(prin1-to-string klist))))))
|
||
|
||
(defun elt-satisfies-if-p (item klist)
|
||
"ELT-SATISFIES-IF-P ITEM KLIST => t or nil
|
||
True if an -if style function was called and ITEM satisfies the
|
||
predicate under :predicate in KLIST."
|
||
(let ((predicate (extract-from-klist :predicate klist))
|
||
(keyfn (extract-from-klist :key 'identity)))
|
||
(funcall predicate item (funcall keyfn elt))))
|
||
|
||
(defun elt-satisfies-if-not-p (item klist)
|
||
"ELT-SATISFIES-IF-NOT-P ITEM KLIST => t or nil
|
||
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
|
||
True if an -if-not style function was called and ITEM does not satisfy
|
||
the predicate under :predicate in KLIST."
|
||
(let ((predicate (extract-from-klist :predicate klist))
|
||
(keyfn (extract-from-klist :key 'identity)))
|
||
(not (funcall predicate item (funcall keyfn elt)))))
|
||
|
||
(defun elts-match-under-klist-p (e1 e2 klist)
|
||
"ELTS-MATCH-UNDER-KLIST-P E1 E2 KLIST => t or nil
|
||
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
|
||
True if elements E1 and E2 match under the tests encoded in KLIST."
|
||
(let ((test (extract-from-klist :test klist))
|
||
(test-not (extract-from-klist :test-not klist))
|
||
(keyfn (extract-from-klist :key klist 'identity)))
|
||
(cond
|
||
(test
|
||
(funcall test (funcall keyfn e1) (funcall keyfn e2)))
|
||
(test-not
|
||
(not (funcall test-not (funcall keyfn e1) (funcall keyfn e2))))
|
||
(t ;should never happen
|
||
(error "Neither :test nor :test-not in `%s'"
|
||
(prin1-to-string klist))))))
|
||
|
||
;;;; end of cl-sequences.el
|
||
|
||
;;;; MULTIPLE VALUES
|
||
;;;; This package approximates the behavior of the multiple-values
|
||
;;;; forms of Common Lisp.
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
|
||
|
||
;;; Lisp indentation information
|
||
(put 'multiple-value-bind 'lisp-indent-hook 2)
|
||
(put 'multiple-value-setq 'lisp-indent-hook 2)
|
||
(put 'multiple-value-list 'lisp-indent-hook nil)
|
||
(put 'multiple-value-call 'lisp-indent-hook 1)
|
||
(put 'multiple-value-prog1 'lisp-indent-hook 1)
|
||
|
||
|
||
;;; Global state of the package is kept here
|
||
(defvar *mvalues-values* nil
|
||
"Most recently returned multiple-values")
|
||
(defvar *mvalues-count* nil
|
||
"Count of multiple-values returned, or nil if the mechanism was not used")
|
||
|
||
;;; values is the standard multiple-value-return form. Must be the
|
||
;;; last thing evaluated inside a function. If the caller is not
|
||
;;; expecting multiple values, only the first one is passed. (values)
|
||
;;; is the same as no-values returned (unaware callers see nil). The
|
||
;;; alternative (values-list <list>) is just a convenient shorthand
|
||
;;; and complements multiple-value-list.
|
||
|
||
(defun values (&rest val-forms)
|
||
"Produce multiple values (zero or more). Each arg is one value.
|
||
See also `multiple-value-bind', which is one way to examine the
|
||
multiple values produced by a form. If the containing form or caller
|
||
does not check specially to see multiple values, it will see only
|
||
the first value."
|
||
(setq *mvalues-values* val-forms)
|
||
(setq *mvalues-count* (length *mvalues-values*))
|
||
(car *mvalues-values*))
|
||
|
||
|
||
(defun values-list (&optional val-forms)
|
||
"Produce multiple values (zero or mode). Each element of LIST is one value.
|
||
This is equivalent to (apply 'values LIST)."
|
||
(cond ((nlistp val-forms)
|
||
(error "Argument to values-list must be a list, not `%s'"
|
||
(prin1-to-string val-forms))))
|
||
(setq *mvalues-values* val-forms)
|
||
(setq *mvalues-count* (length *mvalues-values*))
|
||
(car *mvalues-values*))
|
||
|
||
|
||
;;; Callers that want to see the multiple values use these macros.
|
||
|
||
(defmacro multiple-value-list (form)
|
||
"Execute FORM and return a list of all the (multiple) values FORM produces.
|
||
See `values' and `multiple-value-bind'."
|
||
(list 'progn
|
||
(list 'setq '*mvalues-count* nil)
|
||
(list 'let (list (list 'it '(gensym)))
|
||
(list 'set 'it form)
|
||
(list 'if '*mvalues-count*
|
||
(list 'copy-sequence '*mvalues-values*)
|
||
(list 'progn
|
||
(list 'setq '*mvalues-count* 1)
|
||
(list 'setq '*mvalues-values*
|
||
(list 'list (list 'symbol-value 'it)))
|
||
(list 'copy-sequence '*mvalues-values*))))))
|
||
|
||
(defmacro multiple-value-call (function &rest args)
|
||
"Call FUNCTION on all the values produced by the remaining arguments.
|
||
(multiple-value-call '+ (values 1 2) (values 3 4)) is 10."
|
||
(let* ((result (gentemp))
|
||
(arg (gentemp)))
|
||
(list 'apply (list 'function (eval function))
|
||
(list 'let* (list (list result '()))
|
||
(list 'dolist (list arg (list 'quote args) result)
|
||
(list 'setq result
|
||
(list 'append
|
||
result
|
||
(list 'multiple-value-list
|
||
(list 'eval arg)))))))))
|
||
|
||
(defmacro multiple-value-bind (vars form &rest body)
|
||
"Bind VARS to the (multiple) values produced by FORM, then do BODY.
|
||
VARS is a list of variables; each is bound to one of FORM's values.
|
||
If FORM doesn't make enough values, the extra variables are bound to nil.
|
||
(Ordinary forms produce only one value; to produce more, use `values'.)
|
||
Extra values are ignored.
|
||
BODY (zero or more forms) is executed with the variables bound,
|
||
then the bindings are unwound."
|
||
(let* ((vals (gentemp)) ;name for intermediate values
|
||
(clauses (mv-bind-clausify ;convert into clauses usable
|
||
vars vals))) ; in a let form
|
||
(list* 'let*
|
||
(cons (list vals (list 'multiple-value-list form))
|
||
clauses)
|
||
body)))
|
||
|
||
(defmacro multiple-value-setq (vars form)
|
||
"Set VARS to the (multiple) values produced by FORM.
|
||
VARS is a list of variables; each is set to one of FORM's values.
|
||
If FORM doesn't make enough values, the extra variables are set to nil.
|
||
(Ordinary forms produce only one value; to produce more, use `values'.)
|
||
Extra values are ignored."
|
||
(let* ((vals (gentemp)) ;name for intermediate values
|
||
(clauses (mv-bind-clausify ;convert into clauses usable
|
||
vars vals))) ; in a setq (after append).
|
||
(list 'let*
|
||
(list (list vals (list 'multiple-value-list form)))
|
||
(cons 'setq (apply (function append) clauses)))))
|
||
|
||
(defmacro multiple-value-prog1 (form &rest body)
|
||
"Evaluate FORM, then BODY, then produce the same values FORM produced.
|
||
Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2.
|
||
This is like `prog1' except that `prog1' would produce only one value,
|
||
which would be the first of FORM's values."
|
||
(let* ((heldvalues (gentemp)))
|
||
(cons 'let*
|
||
(cons (list (list heldvalues (list 'multiple-value-list form)))
|
||
(append body (list (list 'values-list heldvalues)))))))
|
||
|
||
;;; utility functions
|
||
;;;
|
||
;;; mv-bind-clausify makes the pairs needed to have the variables in
|
||
;;; the variable list correspond with the values returned by the form.
|
||
;;; vals is a fresh symbol that intervenes in all the bindings.
|
||
|
||
(defun mv-bind-clausify (vars vals)
|
||
"MV-BIND-CLAUSIFY VARS VALS => Auxiliary list
|
||
Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to
|
||
the length of VARS (a list of symbols). VALS is just a fresh symbol."
|
||
(if (or (nlistp vars)
|
||
(notevery 'symbolp vars))
|
||
(error "Expected a list of symbols, not `%s'"
|
||
(prin1-to-string vars)))
|
||
(let* ((nvars (length vars))
|
||
(clauses '()))
|
||
(dotimes (n nvars clauses)
|
||
(setq clauses (cons (list (nth n vars)
|
||
(list 'nth n vals)) clauses)))))
|
||
|
||
;;;; end of cl-multiple-values.el
|
||
|
||
;;;; ARITH
|
||
;;;; This file provides integer arithmetic extensions. Although
|
||
;;;; Emacs Lisp doesn't really support anything but integers, that
|
||
;;;; has still to be made to look more or less standard.
|
||
;;;;
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
|
||
(defun plusp (number)
|
||
"True if NUMBER is strictly greater than zero."
|
||
(> number 0))
|
||
|
||
(defun minusp (number)
|
||
"True if NUMBER is strictly less than zero."
|
||
(< number 0))
|
||
|
||
(defun oddp (number)
|
||
"True if INTEGER is not divisible by 2."
|
||
(/= (% number 2) 0))
|
||
|
||
(defun evenp (number)
|
||
"True if INTEGER is divisible by 2."
|
||
(= (% number 2) 0))
|
||
|
||
(defun abs (number)
|
||
"Return the absolute value of NUMBER."
|
||
(cond
|
||
((< number 0)
|
||
(- 0 number))
|
||
(t ;number is >= 0
|
||
number)))
|
||
|
||
(defun signum (number)
|
||
"Return -1, 0 or 1 according to the sign of NUMBER."
|
||
(cond
|
||
((< number 0)
|
||
-1)
|
||
((> number 0)
|
||
1)
|
||
(t ;exactly zero
|
||
0)))
|
||
|
||
(defun gcd (&rest integers)
|
||
"Return the greatest common divisor of all the arguments.
|
||
The arguments must be integers. With no arguments, value is zero."
|
||
(let ((howmany (length integers)))
|
||
(cond
|
||
((= howmany 0)
|
||
0)
|
||
((= howmany 1)
|
||
(abs (car integers)))
|
||
((> howmany 2)
|
||
(apply (function gcd)
|
||
(cons (gcd (nth 0 integers) (nth 1 integers))
|
||
(nthcdr 2 integers))))
|
||
(t ;howmany=2
|
||
;; essentially the euclidean algorithm
|
||
(when (zerop (* (nth 0 integers) (nth 1 integers)))
|
||
(error "A zero argument is invalid for `gcd'"))
|
||
(do* ((absa (abs (nth 0 integers))) ; better to operate only
|
||
(absb (abs (nth 1 integers))) ;on positives.
|
||
(dd (max absa absb)) ; setup correct order for the
|
||
(ds (min absa absb)) ;succesive divisions.
|
||
;; intermediate results
|
||
(q 0)
|
||
(r 0)
|
||
;; final results
|
||
(done nil) ; flag: end of iterations
|
||
(result 0)) ; final value
|
||
(done result)
|
||
(setq q (/ dd ds))
|
||
(setq r (% dd ds))
|
||
(cond
|
||
((zerop r) (setq done t) (setq result ds))
|
||
( t (setq dd ds) (setq ds r))))))))
|
||
|
||
(defun lcm (integer &rest more)
|
||
"Return the least common multiple of all the arguments.
|
||
The arguments must be integers and there must be at least one of them."
|
||
(let ((howmany (length more))
|
||
(a integer)
|
||
(b (nth 0 more))
|
||
prod ; intermediate product
|
||
(yetmore (nthcdr 1 more)))
|
||
(cond
|
||
((zerop howmany)
|
||
(abs a))
|
||
((> howmany 1) ; recursive case
|
||
(apply (function lcm)
|
||
(cons (lcm a b) yetmore)))
|
||
(t ; base case, just 2 args
|
||
(setq prod (* a b))
|
||
(cond
|
||
((zerop prod)
|
||
0)
|
||
(t
|
||
(/ (abs prod) (gcd a b))))))))
|
||
|
||
(defun isqrt (number)
|
||
"Return the integer square root of NUMBER.
|
||
NUMBER must not be negative. Result is largest integer less than or
|
||
equal to the real square root of the argument."
|
||
(cond
|
||
((minusp number)
|
||
(error "Argument to `isqrt' must not be negative"))
|
||
((zerop number)
|
||
0)
|
||
((<= number 3)
|
||
1)
|
||
(t
|
||
;; This is some sort of newtonian iteration, trying not to get in
|
||
;; an infinite loop. That's why I catch 0, 1, 2 and 3 as special
|
||
;; cases, so then rounding won't make this iteration loop.
|
||
(do* ((approx (/ number 2) iter)
|
||
(done nil)
|
||
(iter 0))
|
||
(done (if (> (* approx approx) number)
|
||
(- approx 1) ;reached from above
|
||
approx))
|
||
(setq iter
|
||
(/ (+ approx
|
||
(/ number approx)
|
||
(if (>= (% number approx) (/ approx 2))
|
||
1 0))
|
||
2))
|
||
(setq done (eql approx iter))))))
|
||
|
||
(defun floor (number &optional divisor)
|
||
"Divide DIVIDEND by DIVISOR, rounding toward minus infinity.
|
||
DIVISOR defaults to 1. The remainder is produced as a second value."
|
||
(cond
|
||
((and (null divisor) ; trivial case
|
||
(numberp number))
|
||
(values number 0))
|
||
(t ; do the division
|
||
(multiple-value-bind
|
||
(q r s)
|
||
(safe-idiv number divisor)
|
||
(cond
|
||
((zerop s)
|
||
(values 0 0))
|
||
((plusp s)
|
||
(values q r))
|
||
(t
|
||
(unless (zerop r)
|
||
(setq q (- 0 (+ q 1)))
|
||
(setq r (- number (* q divisor))))
|
||
(values q r)))))))
|
||
|
||
(defun ceiling (number &optional divisor)
|
||
"Divide DIVIDEND by DIVISOR, rounding toward plus infinity.
|
||
DIVISOR defaults to 1. The remainder is produced as a second value."
|
||
(cond
|
||
((and (null divisor) ; trivial case
|
||
(numberp number))
|
||
(values number 0))
|
||
(t ; do the division
|
||
(multiple-value-bind
|
||
(q r s)
|
||
(safe-idiv number divisor)
|
||
(cond
|
||
((zerop s)
|
||
(values 0 0))
|
||
((minusp s)
|
||
(values q r))
|
||
(t
|
||
(unless (zerop r)
|
||
(setq q (+ q 1))
|
||
(setq r (- number (* q divisor))))
|
||
(values q r)))))))
|
||
|
||
(defun truncate (number &optional divisor)
|
||
"Divide DIVIDEND by DIVISOR, rounding toward zero.
|
||
DIVISOR defaults to 1. The remainder is produced as a second value."
|
||
(cond
|
||
((and (null divisor) ; trivial case
|
||
(numberp number))
|
||
(values number 0))
|
||
(t ; do the division
|
||
(multiple-value-bind
|
||
(q r s)
|
||
(safe-idiv number divisor)
|
||
(cond
|
||
((zerop s)
|
||
(values 0 0))
|
||
((plusp s)
|
||
(values q r))
|
||
(t
|
||
(unless (zerop r)
|
||
(setq q (- 0 q))
|
||
(setq r (- number (* q divisor))))
|
||
(values q r)))))))
|
||
|
||
(defun round (number &optional divisor)
|
||
"Divide DIVIDEND by DIVISOR, rounding to nearest integer.
|
||
DIVISOR defaults to 1. The remainder is produced as a second value."
|
||
(cond
|
||
((and (null divisor) ; trivial case
|
||
(numberp number))
|
||
(values number 0))
|
||
(t ; do the division
|
||
(multiple-value-bind
|
||
(q r s)
|
||
(safe-idiv number divisor)
|
||
(setq r (abs r))
|
||
;; adjust magnitudes first, and then signs
|
||
(let ((other-r (- (abs divisor) r)))
|
||
(cond
|
||
((> r other-r)
|
||
(setq q (+ q 1)))
|
||
((and (= r other-r)
|
||
(oddp q))
|
||
;; round to even is mandatory
|
||
(setq q (+ q 1))))
|
||
(setq q (* s q))
|
||
(setq r (- number (* q divisor)))
|
||
(values q r))))))
|
||
|
||
(defun mod (number divisor)
|
||
"Return remainder of X by Y (rounding quotient toward minus infinity).
|
||
That is, the remainder goes with the quotient produced by `floor'."
|
||
(multiple-value-bind (q r) (floor number divisor)
|
||
r))
|
||
|
||
(defun rem (number divisor)
|
||
"Return remainder of X by Y (rounding quotient toward zero).
|
||
That is, the remainder goes with the quotient produced by `truncate'."
|
||
(multiple-value-bind (q r) (truncate number divisor)
|
||
r))
|
||
|
||
;;; internal utilities
|
||
;;;
|
||
;;; safe-idiv performs an integer division with positive numbers only.
|
||
;;; It is known that some machines/compilers implement weird remainder
|
||
;;; computations when working with negatives, so the idea here is to
|
||
;;; make sure we know what is coming back to the caller in all cases.
|
||
|
||
(defun safe-idiv (a b)
|
||
"SAFE-IDIV A B => Q R S
|
||
Q=|A|/|B|, R is the rest, S is the sign of A/B."
|
||
(unless (and (numberp a) (numberp b))
|
||
(error "Arguments to `safe-idiv' must be numbers"))
|
||
(when (zerop b)
|
||
(error "Cannot divide %d by zero" a))
|
||
(let* ((absa (abs a))
|
||
(absb (abs b))
|
||
(q (/ absa absb))
|
||
(s (* (signum a) (signum b)))
|
||
(r (- a (* (* s q) b))))
|
||
(values q r s)))
|
||
|
||
;;;; end of cl-arith.el
|
||
|
||
;;;; SETF
|
||
;;;; This file provides the setf macro and friends. The purpose has
|
||
;;;; been modest, only the simplest defsetf forms are accepted.
|
||
;;;; Use it and enjoy.
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
|
||
(defkeyword :setf-update-fn
|
||
"Property, its value is the function setf must invoke to update a
|
||
generalized variable whose access form is a function call of the
|
||
symbol that has this property.")
|
||
|
||
(defkeyword :setf-update-doc
|
||
"Property of symbols that have a `defsetf' update function on them,
|
||
installed by the `defsetf' from its optional third argument.")
|
||
|
||
(defmacro setf (&rest pairs)
|
||
"Generalized `setq' that can set things other than variable values.
|
||
A use of `setf' looks like (setf {PLACE VALUE}...).
|
||
The behavior of (setf PLACE VALUE) is to access the generalized variable
|
||
at PLACE and store VALUE there. It returns VALUE. If there is more
|
||
than one PLACE and VALUE, each PLACE is set from its VALUE before
|
||
the next PLACE is evaluated."
|
||
(let ((nforms (length pairs)))
|
||
;; check the number of subforms
|
||
(cond
|
||
((/= (% nforms 2) 0)
|
||
(error "Odd number of arguments to `setf'"))
|
||
((= nforms 0)
|
||
nil)
|
||
((> nforms 2)
|
||
;; this is the recursive case
|
||
(cons 'progn
|
||
(do* ;collect the place-value pairs
|
||
((args pairs (cddr args))
|
||
(place (car args) (car args))
|
||
(value (cadr args) (cadr args))
|
||
(result '()))
|
||
((endp args) (nreverse result))
|
||
(setq result
|
||
(cons (list 'setf place value)
|
||
result)))))
|
||
(t ;i.e., nforms=2
|
||
;; this is the base case (SETF PLACE VALUE)
|
||
(let* ((place (car pairs))
|
||
(value (cadr pairs))
|
||
(head nil)
|
||
(updatefn nil))
|
||
;; dispatch on the type of the PLACE
|
||
(cond
|
||
((symbolp place)
|
||
(list 'setq place value))
|
||
((and (listp place)
|
||
(setq head (car place))
|
||
(symbolp head)
|
||
(setq updatefn (get head :setf-update-fn)))
|
||
(if (or (and (consp updatefn) (eq (car updatefn) 'lambda))
|
||
(and (symbolp updatefn)
|
||
(fboundp updatefn)
|
||
(let ((defn (symbol-function updatefn)))
|
||
(or (subrp defn)
|
||
(and (consp defn) (eq (car defn) 'lambda))))))
|
||
(cons updatefn (append (cdr place) (list value)))
|
||
(multiple-value-bind
|
||
(bindings newsyms)
|
||
(pair-with-newsyms (append (cdr place) (list value)))
|
||
;; this let* gets new symbols to ensure adequate order of
|
||
;; evaluation of the subforms.
|
||
(list 'let
|
||
bindings
|
||
(cons updatefn newsyms)))))
|
||
(t
|
||
(error "No `setf' update-function for `%s'"
|
||
(prin1-to-string place)))))))))
|
||
|
||
(defmacro defsetf (accessfn updatefn &optional docstring)
|
||
"Define how `setf' works on a certain kind of generalized variable.
|
||
A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]).
|
||
ACCESSFN is a symbol. UPDATEFN is a function or macro which takes
|
||
one more argument than ACCESSFN does. DEFSETF defines the translation
|
||
of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL).
|
||
The function UPDATEFN must return its last arg, after performing the
|
||
updating called for."
|
||
;; reject ill-formed requests. too bad one can't test for functionp
|
||
;; or macrop.
|
||
(when (not (symbolp accessfn))
|
||
(error "First argument of `defsetf' must be a symbol, not `%s'"
|
||
(prin1-to-string accessfn)))
|
||
;; update properties
|
||
(put accessfn :setf-update-fn updatefn)
|
||
(put accessfn :setf-update-doc docstring))
|
||
|
||
;;; This section provides the "default" setfs for Common-Emacs-Lisp
|
||
;;; The user will not normally add anything to this, although
|
||
;;; defstruct will introduce new ones as a matter of fact.
|
||
;;;
|
||
;;; Apply is a special case. The Common Lisp
|
||
;;; standard makes the case of apply be useful when the user writes
|
||
;;; something like (apply #'name ...), Emacs Lisp doesn't have the #
|
||
;;; stuff, but it has (function ...). Notice that V18 includes a new
|
||
;;; apply: this file is compatible with V18 and pre-V18 Emacses.
|
||
|
||
;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the
|
||
;;; (correct) left to right sequence *before* checking for apply
|
||
;;; methods (which should really be an special case inside setf). Due
|
||
;;; to this, the lambda expression defsetf'd to apply will succeed in
|
||
;;; applying the right function even if the name was not quoted, but
|
||
;;; computed! That extension is not Common Lisp (nor is particularly
|
||
;;; useful, I think).
|
||
|
||
(defsetf apply
|
||
(lambda (&rest args)
|
||
;; dissasemble the calling form
|
||
;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too)
|
||
(let* ((fnform (car args)) ;functional form
|
||
(applyargs (append ;arguments "to apply fnform"
|
||
(apply 'list* (butlast (cdr args)))
|
||
(last args)))
|
||
(newupdater nil)) ; its update-fn, if any
|
||
(cond
|
||
((and (symbolp fnform)
|
||
(setq newupdater (get fnform :setf-update-fn)))
|
||
;; just do it
|
||
(apply newupdater applyargs))
|
||
(t
|
||
(error "Can't `setf' to `%s'"
|
||
(prin1-to-string fnform))))))
|
||
"`apply' is a special case for `setf'")
|
||
|
||
|
||
(defsetf aref
|
||
aset
|
||
"`setf' inversion for `aref'")
|
||
|
||
(defsetf nth
|
||
setnth
|
||
"`setf' inversion for `nth'")
|
||
|
||
(defsetf nthcdr
|
||
setnthcdr
|
||
"`setf' inversion for `nthcdr'")
|
||
|
||
(defsetf elt
|
||
setelt
|
||
"`setf' inversion for `elt'")
|
||
|
||
(defsetf first
|
||
(lambda (list val) (setnth 0 list val))
|
||
"`setf' inversion for `first'")
|
||
|
||
(defsetf second
|
||
(lambda (list val) (setnth 1 list val))
|
||
"`setf' inversion for `second'")
|
||
|
||
(defsetf third
|
||
(lambda (list val) (setnth 2 list val))
|
||
"`setf' inversion for `third'")
|
||
|
||
(defsetf fourth
|
||
(lambda (list val) (setnth 3 list val))
|
||
"`setf' inversion for `fourth'")
|
||
|
||
(defsetf fifth
|
||
(lambda (list val) (setnth 4 list val))
|
||
"`setf' inversion for `fifth'")
|
||
|
||
(defsetf sixth
|
||
(lambda (list val) (setnth 5 list val))
|
||
"`setf' inversion for `sixth'")
|
||
|
||
(defsetf seventh
|
||
(lambda (list val) (setnth 6 list val))
|
||
"`setf' inversion for `seventh'")
|
||
|
||
(defsetf eighth
|
||
(lambda (list val) (setnth 7 list val))
|
||
"`setf' inversion for `eighth'")
|
||
|
||
(defsetf ninth
|
||
(lambda (list val) (setnth 8 list val))
|
||
"`setf' inversion for `ninth'")
|
||
|
||
(defsetf tenth
|
||
(lambda (list val) (setnth 9 list val))
|
||
"`setf' inversion for `tenth'")
|
||
|
||
(defsetf rest
|
||
(lambda (list val) (setcdr list val))
|
||
"`setf' inversion for `rest'")
|
||
|
||
(defsetf car setcar "Replace the car of a cons")
|
||
|
||
(defsetf cdr setcdr "Replace the cdr of a cons")
|
||
|
||
(defsetf caar
|
||
(lambda (list val) (setcar (nth 0 list) val))
|
||
"`setf' inversion for `caar'")
|
||
|
||
(defsetf cadr
|
||
(lambda (list val) (setcar (cdr list) val))
|
||
"`setf' inversion for `cadr'")
|
||
|
||
(defsetf cdar
|
||
(lambda (list val) (setcdr (car list) val))
|
||
"`setf' inversion for `cdar'")
|
||
|
||
(defsetf cddr
|
||
(lambda (list val) (setcdr (cdr list) val))
|
||
"`setf' inversion for `cddr'")
|
||
|
||
(defsetf caaar
|
||
(lambda (list val) (setcar (caar list) val))
|
||
"`setf' inversion for `caaar'")
|
||
|
||
(defsetf caadr
|
||
(lambda (list val) (setcar (cadr list) val))
|
||
"`setf' inversion for `caadr'")
|
||
|
||
(defsetf cadar
|
||
(lambda (list val) (setcar (cdar list) val))
|
||
"`setf' inversion for `cadar'")
|
||
|
||
(defsetf cdaar
|
||
(lambda (list val) (setcdr (caar list) val))
|
||
"`setf' inversion for `cdaar'")
|
||
|
||
(defsetf caddr
|
||
(lambda (list val) (setcar (cddr list) val))
|
||
"`setf' inversion for `caddr'")
|
||
|
||
(defsetf cdadr
|
||
(lambda (list val) (setcdr (cadr list) val))
|
||
"`setf' inversion for `cdadr'")
|
||
|
||
(defsetf cddar
|
||
(lambda (list val) (setcdr (cdar list) val))
|
||
"`setf' inversion for `cddar'")
|
||
|
||
(defsetf cdddr
|
||
(lambda (list val) (setcdr (cddr list) val))
|
||
"`setf' inversion for `cdddr'")
|
||
|
||
(defsetf caaaar
|
||
(lambda (list val) (setcar (caaar list) val))
|
||
"`setf' inversion for `caaaar'")
|
||
|
||
(defsetf caaadr
|
||
(lambda (list val) (setcar (caadr list) val))
|
||
"`setf' inversion for `caaadr'")
|
||
|
||
(defsetf caadar
|
||
(lambda (list val) (setcar (cadar list) val))
|
||
"`setf' inversion for `caadar'")
|
||
|
||
(defsetf cadaar
|
||
(lambda (list val) (setcar (cdaar list) val))
|
||
"`setf' inversion for `cadaar'")
|
||
|
||
(defsetf cdaaar
|
||
(lambda (list val) (setcdr (caar list) val))
|
||
"`setf' inversion for `cdaaar'")
|
||
|
||
(defsetf caaddr
|
||
(lambda (list val) (setcar (caddr list) val))
|
||
"`setf' inversion for `caaddr'")
|
||
|
||
(defsetf cadadr
|
||
(lambda (list val) (setcar (cdadr list) val))
|
||
"`setf' inversion for `cadadr'")
|
||
|
||
(defsetf cdaadr
|
||
(lambda (list val) (setcdr (caadr list) val))
|
||
"`setf' inversion for `cdaadr'")
|
||
|
||
(defsetf caddar
|
||
(lambda (list val) (setcar (cddar list) val))
|
||
"`setf' inversion for `caddar'")
|
||
|
||
(defsetf cdadar
|
||
(lambda (list val) (setcdr (cadar list) val))
|
||
"`setf' inversion for `cdadar'")
|
||
|
||
(defsetf cddaar
|
||
(lambda (list val) (setcdr (cdaar list) val))
|
||
"`setf' inversion for `cddaar'")
|
||
|
||
(defsetf cadddr
|
||
(lambda (list val) (setcar (cdddr list) val))
|
||
"`setf' inversion for `cadddr'")
|
||
|
||
(defsetf cddadr
|
||
(lambda (list val) (setcdr (cdadr list) val))
|
||
"`setf' inversion for `cddadr'")
|
||
|
||
(defsetf cdaddr
|
||
(lambda (list val) (setcdr (caddr list) val))
|
||
"`setf' inversion for `cdaddr'")
|
||
|
||
(defsetf cdddar
|
||
(lambda (list val) (setcdr (cddar list) val))
|
||
"`setf' inversion for `cdddar'")
|
||
|
||
(defsetf cddddr
|
||
(lambda (list val) (setcdr (cddr list) val))
|
||
"`setf' inversion for `cddddr'")
|
||
|
||
|
||
(defsetf get
|
||
put
|
||
"`setf' inversion for `get' is `put'")
|
||
|
||
(defsetf symbol-function
|
||
fset
|
||
"`setf' inversion for `symbol-function' is `fset'")
|
||
|
||
(defsetf symbol-plist
|
||
setplist
|
||
"`setf' inversion for `symbol-plist' is `setplist'")
|
||
|
||
(defsetf symbol-value
|
||
set
|
||
"`setf' inversion for `symbol-value' is `set'")
|
||
|
||
;;; Modify macros
|
||
;;;
|
||
;;; It could be nice to implement define-modify-macro, but I don't
|
||
;;; think it really pays.
|
||
|
||
(defmacro incf (ref &optional delta)
|
||
"(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)"
|
||
(if (null delta)
|
||
(setq delta 1))
|
||
(list 'setf ref (list '+ ref delta)))
|
||
|
||
(defmacro decf (ref &optional delta)
|
||
"(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)"
|
||
(if (null delta)
|
||
(setq delta 1))
|
||
(list 'setf ref (list '- ref delta)))
|
||
|
||
(defmacro push (item ref)
|
||
"(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)"
|
||
(list 'setf ref (list 'cons item ref)))
|
||
|
||
(defmacro pushnew (item ref)
|
||
"(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)"
|
||
(list 'setf ref (list 'adjoin item ref)))
|
||
|
||
(defmacro pop (ref)
|
||
"(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))"
|
||
(let ((listname (gensym)))
|
||
(list 'let (list (list listname ref))
|
||
(list 'prog1
|
||
(list 'car listname)
|
||
(list 'setf ref (list 'cdr listname))))))
|
||
|
||
;;; PSETF
|
||
;;;
|
||
;;; Psetf is the generalized variable equivalent of psetq. The right
|
||
;;; hand sides are evaluated and assigned (via setf) to the left hand
|
||
;;; sides. The evaluations are done in an environment where they
|
||
;;; appear to occur in parallel.
|
||
|
||
(defmacro psetf (&rest pairs)
|
||
"(psetf {PLACE VALUE}...): Set several generalized variables in parallel.
|
||
All the VALUEs are computed, and then all the PLACEs are stored as in `setf'.
|
||
See also `psetq', `shiftf' and `rotatef'."
|
||
(unless (evenp (length pairs))
|
||
(error "Odd number of arguments to `psetf'"))
|
||
(multiple-value-bind
|
||
(places forms)
|
||
(unzip-list pairs)
|
||
;; obtain fresh symbols to simulate the parallelism
|
||
(multiple-value-bind
|
||
(bindings newsyms)
|
||
(pair-with-newsyms forms)
|
||
(list 'let
|
||
bindings
|
||
(cons 'setf (zip-lists places newsyms))
|
||
nil))))
|
||
|
||
;;; SHIFTF and ROTATEF
|
||
;;;
|
||
|
||
(defmacro shiftf (&rest forms)
|
||
"(shiftf PLACE1 PLACE2... NEWVALUE): set PLACE1 to PLACE2, PLACE2 to PLACE3...
|
||
Each PLACE is set to the old value of the following PLACE,
|
||
and the last PLACE is set to the value NEWVALUE."
|
||
(unless (> (length forms) 1)
|
||
(error "`shiftf' needs more than one argument"))
|
||
(let ((places (butlast forms))
|
||
(newvalue (car (last forms))))
|
||
;; the places are accessed to fresh symbols
|
||
(multiple-value-bind
|
||
(bindings newsyms)
|
||
(pair-with-newsyms places)
|
||
(list 'let bindings
|
||
(cons 'setf
|
||
(zip-lists places
|
||
(append (cdr newsyms) (list newvalue))))
|
||
(car newsyms)))))
|
||
|
||
(defmacro rotatef (&rest places)
|
||
"(rotatef PLACE...) sets each PLACE to the old value of the following PLACE.
|
||
The last PLACE is set to the old value of the first PLACE.
|
||
Thus, the values rotate through the PLACEs."
|
||
(cond
|
||
((null places)
|
||
nil)
|
||
(t
|
||
(multiple-value-bind
|
||
(bindings newsyms)
|
||
(pair-with-newsyms places)
|
||
(list
|
||
'let bindings
|
||
(cons 'setf
|
||
(zip-lists places
|
||
(append (cdr newsyms) (list (car newsyms)))))
|
||
nil)))))
|
||
|
||
;;;; STRUCTS
|
||
;;;; This file provides the structures mechanism. See the
|
||
;;;; documentation for Common-Lisp's defstruct. Mine doesn't
|
||
;;;; implement all the functionality of the standard, although some
|
||
;;;; more could be grafted if so desired. More details along with
|
||
;;;; the code.
|
||
;;;;
|
||
;;;;
|
||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||
;;;; (quiroz@cs.rochester.edu)
|
||
|
||
|
||
(defkeyword :include "Syntax of `defstruct'")
|
||
(defkeyword :named "Syntax of `defstruct'")
|
||
(defkeyword :conc-name "Syntax of `defstruct'")
|
||
(defkeyword :copier "Syntax of `defstruct'")
|
||
(defkeyword :predicate "Syntax of `defstruct'")
|
||
(defkeyword :print-function "Syntax of `defstruct'")
|
||
(defkeyword :type "Syntax of `defstruct'")
|
||
(defkeyword :initial-offset "Syntax of `defstruct'")
|
||
|
||
(defkeyword :structure-doc "Documentation string for a structure.")
|
||
(defkeyword :structure-slotsn "Number of slots in structure")
|
||
(defkeyword :structure-slots "List of the slot's names")
|
||
(defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)")
|
||
(defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)")
|
||
|
||
|
||
(defmacro defstruct (&rest args)
|
||
"(defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type.
|
||
NAME must be a symbol, the name of the new structure. It could also
|
||
be a list (NAME . OPTIONS), but not all options are supported currently.
|
||
As of Dec. 1986, this is supporting :conc-name, :copier and :predicate
|
||
completely, :include arguably completely and :constructor only to
|
||
change the name of the default constructor. No BOA constructors allowed.
|
||
The DOC-STRING is established as the 'structure-doc' property of NAME.
|
||
The SLOTS are one or more of the following:
|
||
SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME
|
||
list of SYMBOL and VALUE -- meaning that VALUE is the initial value of
|
||
the slot.
|
||
`defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the
|
||
structure, and functions with the same name as the slots to access
|
||
them. `setf' of the accessors sets their values."
|
||
(multiple-value-bind
|
||
(name options docstring slotsn slots initlist)
|
||
(parse$defstruct$args args)
|
||
;; Names for the member functions come from the options. The
|
||
;; slots* stuff collects info about the slots declared explicitly.
|
||
(multiple-value-bind
|
||
(conc-name constructor copier predicate moreslotsn moreslots moreinits)
|
||
(parse$defstruct$options name options slots)
|
||
;; The moreslots* stuff refers to slots gained as a consequence
|
||
;; of (:include clauses).
|
||
(when (and (numberp moreslotsn)
|
||
(> moreslotsn 0))
|
||
(setf slotsn (+ slotsn moreslotsn))
|
||
(setf slots (append moreslots slots))
|
||
(setf initlist (append moreinits initlist)))
|
||
(unless (> slotsn 0)
|
||
(error "%s needs at least one slot"
|
||
(prin1-to-string name)))
|
||
(let ((dups (duplicate-symbols-p slots)))
|
||
(when dups
|
||
(error "`%s' are duplicates"
|
||
(prin1-to-string dups))))
|
||
(setq initlist (simplify$inits slots initlist))
|
||
(let (properties functions keywords accessors alterators returned)
|
||
;; compute properties of NAME
|
||
(setq properties
|
||
(list
|
||
(list 'put (list 'quote name) :structure-doc
|
||
docstring)
|
||
(list 'put (list 'quote name) :structure-slotsn
|
||
slotsn)
|
||
(list 'put (list 'quote name) :structure-slots
|
||
(list 'quote slots))
|
||
(list 'put (list 'quote name) :structure-initforms
|
||
(list 'quote initlist))
|
||
(list 'put (list 'quote name) :structure-indices
|
||
(list 'quote (extract$indices initlist)))))
|
||
|
||
;; Compute functions associated with NAME. This is not
|
||
;; handling BOA constructors yet, but here would be the place.
|
||
(setq functions
|
||
(list
|
||
(list 'fset (list 'quote constructor)
|
||
(list 'function
|
||
(list 'lambda (list '&rest 'args)
|
||
(list 'make$structure$instance
|
||
(list 'quote name)
|
||
'args))))
|
||
(list 'fset (list 'quote copier)
|
||
(list 'function
|
||
(list 'lambda (list 'struct)
|
||
(list 'copy-vector 'struct))))
|
||
(list 'fset (list 'quote predicate)
|
||
(list 'function
|
||
(list 'lambda (list 'thing)
|
||
(list 'and
|
||
(list 'vectorp 'thing)
|
||
(list 'eq
|
||
(list 'elt 'thing 0)
|
||
(list 'quote name))
|
||
(list '=
|
||
(list 'length 'thing)
|
||
(1+ slotsn))))))))
|
||
;; compute accessors for NAME's slots
|
||
(multiple-value-setq
|
||
(accessors alterators keywords)
|
||
(build$accessors$for name conc-name predicate slots slotsn))
|
||
;; generate returned value -- not defined by the standard
|
||
(setq returned
|
||
(list
|
||
(cons 'vector
|
||
(mapcar
|
||
'(lambda (x) (list 'quote x))
|
||
(cons name slots)))))
|
||
;; generate code
|
||
(cons 'progn
|
||
(nconc properties functions keywords
|
||
accessors alterators returned))))))
|
||
|
||
(defun parse$defstruct$args (args)
|
||
"PARSE$DEFSTRUCT$ARGS ARGS => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST
|
||
NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots,
|
||
SLOTS=list of their names, INITLIST=alist (keyword . initform)."
|
||
(let (name ;args=(symbol...) or ((symbol...)...)
|
||
options ;args=((symbol . options) ...)
|
||
(docstring "") ;args=(head docstring . slotargs)
|
||
slotargs ;second or third cdr of args
|
||
(slotsn 0) ;number of slots
|
||
(slots '()) ;list of slot names
|
||
(initlist '())) ;list of (slot keyword . initform)
|
||
;; extract name and options
|
||
(cond
|
||
((symbolp (car args)) ;simple name
|
||
(setq name (car args)
|
||
options '()))
|
||
((and (listp (car args)) ;(name . options)
|
||
(symbolp (caar args)))
|
||
(setq name (caar args)
|
||
options (cdar args)))
|
||
(t
|
||
(error "First arg to `defstruct' must be symbol or (symbol ...)")))
|
||
(setq slotargs (cdr args))
|
||
;; is there a docstring?
|
||
(when (stringp (car slotargs))
|
||
(setq docstring (car slotargs)
|
||
slotargs (cdr slotargs)))
|
||
;; now for the slots
|
||
(multiple-value-bind
|
||
(slotsn slots initlist)
|
||
(process$slots slotargs)
|
||
(values name options docstring slotsn slots initlist))))
|
||
|
||
(defun process$slots (slots)
|
||
"PROCESS$SLOTS SLOTS => SLOTSN SLOTSLIST INITLIST
|
||
Converts a list of symbols or lists of symbol and form into the last 3
|
||
values returned by PARSE$DEFSTRUCT$ARGS."
|
||
(let ((slotsn (length slots)) ;number of slots
|
||
slotslist ;(slot1 slot2 ...)
|
||
initlist) ;((:slot1 . init1) ...)
|
||
(do*
|
||
((ptr slots (cdr ptr))
|
||
(this (car ptr) (car ptr)))
|
||
((endp ptr))
|
||
(cond
|
||
((symbolp this)
|
||
(setq slotslist (cons this slotslist))
|
||
(setq initlist (acons (keyword-of this) nil initlist)))
|
||
((and (listp this)
|
||
(symbolp (car this)))
|
||
(let ((name (car this))
|
||
(form (cadr this)))
|
||
;; this silently ignores any slot options. bad...
|
||
(setq slotslist (cons name slotslist))
|
||
(setq initlist (acons (keyword-of name) form initlist))))
|
||
(t
|
||
(error "Slot should be symbol or (symbol ...), not `%s'"
|
||
(prin1-to-string this)))))
|
||
(values slotsn (nreverse slotslist) (nreverse initlist))))
|
||
|
||
(defun parse$defstruct$options (name options slots)
|
||
"PARSE$DEFSTRUCT$OPTIONS NAME OPTIONS SLOTS => CONC-NAME CONST COPIER PRED
|
||
Returns at least those 4 values (a string and 3 symbols, to name the necessary
|
||
functions), might return also things discovered by actually
|
||
inspecting the options, namely MORESLOTSN MORESLOTS MOREINITS, as can
|
||
be created by :include, and perhaps a list of BOACONSTRUCTORS."
|
||
(let* ((namestring (symbol-name name))
|
||
;; to build the return values
|
||
(conc-name (concat namestring "-"))
|
||
(const (intern (concat "make-" namestring)))
|
||
(copier (intern (concat "copy-" namestring)))
|
||
(pred (intern (concat namestring "-p")))
|
||
(moreslotsn 0)
|
||
(moreslots '())
|
||
(moreinits '())
|
||
;; auxiliaries
|
||
option-head ;When an option is not a plain
|
||
option-second ; keyword, it must be a list of
|
||
option-rest ; the form (head second . rest)
|
||
these-slotsn ;When :include is found, the
|
||
these-slots ; info about the included
|
||
these-inits ; structure is added here.
|
||
)
|
||
;; Values above are the defaults. Now we read the options themselves
|
||
(dolist (option options)
|
||
;; 2 cases arise, as options must be a keyword or a list
|
||
(cond
|
||
((keywordp option)
|
||
(case option
|
||
(:named
|
||
) ;ignore silently
|
||
(t
|
||
(error "Can't recognize option `%s'"
|
||
(prin1-to-string option)))))
|
||
((and (listp option)
|
||
(keywordp (setq option-head (car option))))
|
||
(setq option-second (second option))
|
||
(setq option-rest (nthcdr 2 option))
|
||
(case option-head
|
||
(:conc-name
|
||
(setq conc-name
|
||
(cond
|
||
((stringp option-second)
|
||
option-second)
|
||
((null option-second)
|
||
"")
|
||
(t
|
||
(error "`%s' is invalid as `conc-name'"
|
||
(prin1-to-string option-second))))))
|
||
(:copier
|
||
(setq copier
|
||
(cond
|
||
((and (symbolp option-second)
|
||
(null option-rest))
|
||
option-second)
|
||
(t
|
||
(error "Can't recognize option `%s'"
|
||
(prin1-to-string option))))))
|
||
|
||
(:constructor ;no BOA-constructors allowed
|
||
(setq const
|
||
(cond
|
||
((and (symbolp option-second)
|
||
(null option-rest))
|
||
option-second)
|
||
(t
|
||
(error "Can't recognize option `%s'"
|
||
(prin1-to-string option))))))
|
||
(:predicate
|
||
(setq pred
|
||
(cond
|
||
((and (symbolp option-second)
|
||
(null option-rest))
|
||
option-second)
|
||
(t
|
||
(error "Can't recognize option `%s'"
|
||
(prin1-to-string option))))))
|
||
(:include
|
||
(unless (symbolp option-second)
|
||
(error "Arg to `:include' should be a symbol, not `%s'"
|
||
(prin1-to-string option-second)))
|
||
(setq these-slotsn (get option-second :structure-slotsn)
|
||
these-slots (get option-second :structure-slots)
|
||
these-inits (get option-second :structure-initforms))
|
||
(unless (and (numberp these-slotsn)
|
||
(> these-slotsn 0))
|
||
(error "`%s' is not a valid structure"
|
||
(prin1-to-string option-second)))
|
||
(multiple-value-bind
|
||
(xtra-slotsn xtra-slots xtra-inits)
|
||
(process$slots option-rest)
|
||
(when (> xtra-slotsn 0)
|
||
(dolist (xslot xtra-slots)
|
||
(unless (memq xslot these-slots)
|
||
(error "`%s' is not a slot of `%s'"
|
||
(prin1-to-string xslot)
|
||
(prin1-to-string option-second))))
|
||
(setq these-inits (append xtra-inits these-inits)))
|
||
(setq moreslotsn (+ moreslotsn these-slotsn))
|
||
(setq moreslots (append these-slots moreslots))
|
||
(setq moreinits (append these-inits moreinits))))
|
||
((:print-function :type :initial-offset)
|
||
) ;ignore silently
|
||
(t
|
||
(error "Can't recognize option `%s'"
|
||
(prin1-to-string option)))))
|
||
(t
|
||
(error "Can't recognize option `%s'"
|
||
(prin1-to-string option)))))
|
||
;; Return values found
|
||
(values conc-name const copier pred
|
||
moreslotsn moreslots moreinits)))
|
||
|
||
(defun simplify$inits (slots initlist)
|
||
"SIMPLIFY$INITS SLOTS INITLIST => new INITLIST
|
||
Removes from INITLIST - an ALIST - any shadowed bindings."
|
||
(let ((result '()) ;built here
|
||
key ;from the slot
|
||
)
|
||
(dolist (slot slots)
|
||
(setq key (keyword-of slot))
|
||
(setq result (acons key (cdr (assoc key initlist)) result)))
|
||
(nreverse result)))
|
||
|
||
(defun extract$indices (initlist)
|
||
"EXTRACT$INDICES INITLIST => indices list
|
||
Kludge. From a list of pairs (keyword . form) build a list of pairs
|
||
of the form (keyword . position in list from 0). Useful to precompute
|
||
some of the work of MAKE$STRUCTURE$INSTANCE."
|
||
(let ((result '())
|
||
(index 0))
|
||
(dolist (entry initlist (nreverse result))
|
||
(setq result (acons (car entry) index result)
|
||
index (+ index 1)))))
|
||
|
||
(defun build$accessors$for (name conc-name predicate slots slotsn)
|
||
"BUILD$ACCESSORS$FOR NAME PREDICATE SLOTS SLOTSN => FSETS DEFSETFS KWDS
|
||
Generate the code for accesors and defsetfs of a structure called
|
||
NAME, whose slots are SLOTS. Also, establishes the keywords for the
|
||
slots names."
|
||
(do ((i 0 (1+ i))
|
||
(accessors '())
|
||
(alterators '())
|
||
(keywords '())
|
||
(canonic "")) ;slot name with conc-name prepended
|
||
((>= i slotsn)
|
||
(values
|
||
(nreverse accessors) (nreverse alterators) (nreverse keywords)))
|
||
(setq canonic (intern (concat conc-name (symbol-name (nth i slots)))))
|
||
(setq accessors
|
||
(cons
|
||
(list 'fset (list 'quote canonic)
|
||
(list 'function
|
||
(list 'lambda (list 'object)
|
||
(list 'cond
|
||
(list (list predicate 'object)
|
||
(list 'aref 'object (1+ i)))
|
||
(list 't
|
||
(list 'error
|
||
"`%s' not a %s."
|
||
(list 'prin1-to-string
|
||
'object)
|
||
(list 'prin1-to-string
|
||
(list 'quote
|
||
name))))))))
|
||
accessors))
|
||
(setq alterators
|
||
(cons
|
||
(list 'defsetf canonic
|
||
(list 'lambda (list 'object 'newval)
|
||
(list 'cond
|
||
(list (list predicate 'object)
|
||
(list 'aset 'object (1+ i) 'newval))
|
||
(list 't
|
||
(list 'error
|
||
"`%s' not a `%s'"
|
||
(list 'prin1-to-string
|
||
'object)
|
||
(list 'prin1-to-string
|
||
(list 'quote
|
||
name)))))))
|
||
alterators))
|
||
(setq keywords
|
||
(cons (list 'defkeyword (keyword-of (nth i slots)))
|
||
keywords))))
|
||
|
||
(defun make$structure$instance (name args)
|
||
"MAKE$STRUCTURE$INSTANCE NAME ARGS => new struct NAME
|
||
A struct of type NAME is created, some slots might be initialized
|
||
according to ARGS (the &rest argument of MAKE-name)."
|
||
(unless (symbolp name)
|
||
(error "`%s' is not a possible name for a structure"
|
||
(prin1-to-string name)))
|
||
(let ((initforms (get name :structure-initforms))
|
||
(slotsn (get name :structure-slotsn))
|
||
(indices (get name :structure-indices))
|
||
initalist ;pairlis'd on initforms
|
||
initializers ;definitive initializers
|
||
)
|
||
;; check sanity of the request
|
||
(unless (and (numberp slotsn)
|
||
(> slotsn 0))
|
||
(error "`%s' is not a defined structure"
|
||
(prin1-to-string name)))
|
||
(unless (evenp (length args))
|
||
(error "Slot initializers `%s' not of even length"
|
||
(prin1-to-string args)))
|
||
;; analyze the initializers provided by the call
|
||
(multiple-value-bind
|
||
(speckwds specvals) ;keywords and values given
|
||
(unzip-list args) ; by the user
|
||
;; check that all the arguments are introduced by keywords
|
||
(unless (every (function keywordp) speckwds)
|
||
(error "All of the names in `%s' should be keywords"
|
||
(prin1-to-string speckwds)))
|
||
;; check that all the keywords are known
|
||
(dolist (kwd speckwds)
|
||
(unless (numberp (cdr (assoc kwd indices)))
|
||
(error "`%s' is not a valid slot name for %s"
|
||
(prin1-to-string kwd) (prin1-to-string name))))
|
||
;; update initforms
|
||
(setq initalist
|
||
(pairlis speckwds
|
||
(do* ;;protect values from further evaluation
|
||
((ptr specvals (cdr ptr))
|
||
(val (car ptr) (car ptr))
|
||
(result '()))
|
||
((endp ptr) (nreverse result))
|
||
(setq result
|
||
(cons (list 'quote val)
|
||
result)))
|
||
(copy-sequence initforms)))
|
||
;; compute definitive initializers
|
||
(setq initializers
|
||
(do* ;;gather the values of the most definitive forms
|
||
((ptr indices (cdr ptr))
|
||
(key (caar ptr) (caar ptr))
|
||
(result '()))
|
||
((endp ptr) (nreverse result))
|
||
(setq result
|
||
(cons (eval (cdr (assoc key initalist))) result))))
|
||
;; do real initialization
|
||
(apply (function vector)
|
||
(cons name initializers)))))
|
||
|
||
;;;; end of cl-structs.el
|
||
|
||
;;;; end of cl.el
|