Mercurial > emacs
changeset 1553:6b409871cc4a
* cl.el: New version - 3.0 - from Cesar Quiroz.
| author | Jim Blandy <jimb@redhat.com> |
|---|---|
| date | Sat, 07 Nov 1992 06:11:16 +0000 |
| parents | f2901040a07b |
| children | 5af75a1a9a24 |
| files | lisp/=cl.el |
| diffstat | 1 files changed, 359 insertions(+), 242 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/=cl.el Sat Nov 07 06:10:53 1992 +0000 +++ b/lisp/=cl.el Sat Nov 07 06:11:16 1992 +0000 @@ -1,11 +1,10 @@ -;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp. - -;; Copyright (C) 1987, 1988, 1989 Free Software Foundation, Inc. +;; Common-Lisp extensions for GNU Emacs Lisp. +;; Copyright (C) 1987, 1988, 1989, 1992 Free Software Foundation, Inc. ;; Author: Cesar Quiroz <quiroz@cs.rochester.edu> ;; Keywords: extensions -(defvar cl-version "2.0 beta 29 October 1989") +(defvar cl-version "3.0 beta 01 November 1992") ;; This file is part of GNU Emacs. @@ -24,6 +23,29 @@ ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. +;;; Notes from Rob Austein on his mods +;; yaya:/usr/u/sra/cl/cl.el, 5-May-1991 16:01:34, sra +;; +;; Slightly hacked copy of cl.el 2.0 beta 27. +;; +;; Various minor performance improvements: +;; a) Don't use MAPCAR when we're going to discard its results. +;; b) Make various macros a little more clever about optimizing +;; generated code in common cases. +;; c) Fix DEFSETF to expand to the right code at compile-time. +;; d) Make various macros cleverer about generating reasonable +;; code when compiled, particularly forms like DEFSTRUCT which +;; are usually used at top-level and thus are only compiled if +;; you use Hallvard Furuseth's hacked bytecomp.el. +;; +;; New features: GETF, REMF, and REMPROP. +;; +;; Notes: +;; 1) I'm sceptical about the FBOUNDP checks in SETF. Why should +;; the SETF expansion fail because the SETF method isn't defined +;; at compile time? Lisp is going to check for a binding at run-time +;; anyway, so maybe we should just assume the user's right here. + ;;; Commentary: ;;;; These are extensions to Emacs Lisp that provide some form of @@ -47,6 +69,9 @@ ;;;; the files are concatenated together one cannot ensure that ;;;; declaration always precedes use. ;;;; +;;;; Bug reports, suggestions and comments, +;;;; to quiroz@cs.rochester.edu + ;;;; GLOBAL ;;;; This file provides utilities and declarations that are global @@ -64,29 +89,23 @@ ;;; Code: -(defmacro psetq (&rest body) - "(psetq {var value }...) => nil -Like setq, but all the values are computed before any assignment is made." - (let ((length (length body))) - (cond ((/= (% length 2) 0) - (error "psetq needs an even number of arguments, %d given" - length)) - ((null body) - '()) - (t - (list 'prog1 nil - (let ((setqs '()) - (bodyforms (reverse body))) - (while bodyforms - (let* ((value (car bodyforms)) - (place (cadr bodyforms))) - (setq bodyforms (cddr bodyforms)) - (if (null setqs) - (setq setqs (list 'setq place value)) - (setq setqs (list 'setq place - (list 'prog1 value - setqs)))))) - setqs)))))) +;;; This version is due to Hallvard Furuseth (hallvard@ifi.uio.no, 6 Jul 91) +(defmacro psetq (&rest args) + "(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'." + ;; check there is a reasonable number of forms + (if (/= (% (length args) 2) 0) + (error "Odd number of arguments to `psetq'")) + (setq args (copy-sequence args)) ;for safety below + (prog1 (cons 'setq args) + (while (progn (if (not (symbolp (car args))) + (error "`psetq' expected a symbol, found '%s'." + (prin1-to-string (car args)))) + (cdr (cdr args))) + (setcdr args (list (list 'prog1 (nth 1 args) + (cons 'setq + (setq args (cdr (cdr args)))))))))) ;;; utilities ;;; @@ -111,8 +130,8 @@ (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. +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)) @@ -164,9 +183,11 @@ ;;; larger lists. The fourth pass could be eliminated. ;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the ;;; 4th pass. +;;; +;;; [22 April 1991, sra] REMPROP now in library, so restored 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." +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 ) @@ -184,8 +205,9 @@ (dolist (x list) (if (> (get x propname) 1) (setq duplicates (cons x duplicates)))) - ;; pass 4: unmark. eliminated. - ;; (dolist (x list) (remprop x propname)) + ;; pass 4: unmark. + (dolist (x list) + (remprop x propname)) ;; return result duplicates)) @@ -203,14 +225,14 @@ (defmacro defkeyword (x &optional docstring) "Make symbol X a keyword (symbol whose value is itself). -Optional second arg DOCSTRING is a documentation string for it." +Optional second argument is a documentation string for it." (cond ((symbolp x) (list 'defconst x (list 'quote x) docstring)) (t (error "`%s' is not a symbol" (prin1-to-string x))))) (defun keywordp (sym) - "Return t if SYM is a keyword." + "t if SYM is a keyword." (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:)) ;; looks like one, make sure value is right (set sym sym) @@ -232,17 +254,17 @@ ;;; (defvar *gentemp-index* 0 - "Integer used by `gentemp' to produce new names.") + "Integer used by gentemp to produce new names.") (defvar *gentemp-prefix* "T$$_" - "Names generated by `gentemp begin' with this string by default.") + "Names generated by gentemp begin with this string by default.") (defun gentemp (&optional prefix oblist) "Generate a fresh interned symbol. -There are two 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." +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) @@ -257,15 +279,16 @@ newsymbol)) (defvar *gensym-index* 0 - "Integer used by `gensym' to produce new names.") + "Integer used by gensym to produce new names.") (defvar *gensym-prefix* "G$$_" - "Names generated by `gensym' begin with this string by default.") + "Names generated by gensym begin with this string by default.") (defun gensym (&optional prefix) "Generate a fresh uninterned symbol. -Optional arg PREFIX is the string that begins the new name. Most people -take just the default, except when debugging needs suggest otherwise." +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) @@ -289,10 +312,10 @@ ;;;; (quiroz@cs.rochester.edu) ;;; indentation info -(put 'case 'lisp-indent-function 1) -(put 'ecase 'lisp-indent-function 1) -(put 'when 'lisp-indent-function 1) -(put 'unless 'lisp-indent-function 1) +(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. @@ -408,29 +431,26 @@ ;;;; (quiroz@cs.rochester.edu) ;;; some lisp-indentation information -(put 'do 'lisp-indent-function 2) -(put 'do* 'lisp-indent-function 2) -(put 'dolist 'lisp-indent-function 1) -(put 'dotimes 'lisp-indent-function 1) -(put 'do-symbols 'lisp-indent-function 1) -(put 'do-all-symbols 'lisp-indent-function 1) +(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 two forms + "(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." - +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)) @@ -448,16 +468,13 @@ (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 two forms are -the initial value (def. NIL) and the form to step (def. itself). - +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 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 @@ -501,8 +518,7 @@ (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." +--a stepforms, see the do macro--. FORMS is assumed syntactically valid." (mapcar (function (lambda (entry) @@ -516,15 +532,17 @@ ;;; 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." + "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." + "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) @@ -546,8 +564,8 @@ (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 +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 @@ -563,23 +581,27 @@ ;; 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)))) + (resultform (caddr stepform)) + (listsym (gentemp))) + (nconc + (list 'let (list var (list listsym listform)) + (nconc + (list 'while listsym + (list 'setq + var (list 'car listsym) + listsym (list 'cdr listsym))) + body)) + (and resultform + (cons (list 'setq var nil) + (list resultform)))))) (defmacro dotimes (stepform &rest body) - "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR. + "(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 +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 +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 @@ -596,14 +618,16 @@ (let* ((var (car stepform)) (countform (cadr stepform)) (resultform (caddr stepform)) - (newsym (gentemp))) + (testsym (if (consp countform) (gentemp) countform))) + (nconc (list - 'let* (list (list newsym countform)) - (list* - 'do* - (list (list var 0 (list '+ var 1))) - (list (list '>= var newsym) resultform) - body)))) + 'let (cons (list var -1) + (and (not (eq countform testsym)) + (list (list testsym countform)))) + (nconc + (list 'while (list '< (list 'setq var (list '1+ var)) testsym)) + body)) + (and resultform (list resultform))))) (defmacro do-symbols (stepform &rest body) "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY) @@ -671,11 +695,6 @@ ;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986 ;;;; (quiroz@cs.rochester.edu) - - -;;; To make these faster, we define them using defsubst. This directs the -;;; compiler to open-code these functions. - ;;; Synonyms for list functions (defsubst first (x) "Synonym for `car'" @@ -721,7 +740,7 @@ "Synonym for `cdr'" (cdr x)) -(defun endp (x) +(defsubst endp (x) "t if X is nil, nil if X is a cons; error otherwise." (if (listp x) (null x) @@ -758,18 +777,20 @@ "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)))) + (nreverse (nthcdr n (reverse list)))) ;optim. due to macrakis@osf.org +;;; This version due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) (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))) + (let* ((others (cons arg (copy-sequence others))) + (a others)) + (while (cdr (cdr a)) + (setq a (cdr a))) + (setcdr a (car (cdr a))) + others))) (defun adjoin (item list) "Return a list which contains ITEM but is otherwise like LIST. @@ -790,8 +811,8 @@ ;;; The popular c[ad]*r functions and other list accessors. -;;; To implement this efficiently, we define them using defsubst, -;;; which directs the compiler to open-code these functions. +;;; To implement this efficiently, a new byte compile handler is used to +;;; generate the minimal code, saving one function call. (defsubst caar (X) "Return the car of the car of X." @@ -907,25 +928,26 @@ ;;; some inverses of the accessors are needed for setf purposes -(defun setnth (n list newval) +(defsubst 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)))) + (when (< n 0) + (error "N must be 0 or greater, not %d" n)) + (while (> n 0) + (setq list (cdr list) + n (- n 1))) + ;; here only if (zerop n) + (rplaca list (car newval)) + (rplacd list (cdr newval)) + newval) ;;; A-lists machinery -(defun acons (key item alist) +(defsubst 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)) @@ -945,6 +967,7 @@ ((endp kptr) result) (setq result (acons key item result)))) +;;;; end of cl-lists.el ;;;; SEQUENCES ;;;; Emacs Lisp provides many of the 'sequences' functionality of @@ -952,18 +975,19 @@ ;;;; -(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.") +(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.") +(defkeyword :initial-value "For the syntax of #'reduce") (defun some (pred seq &rest moreseqs) "Test PREDICATE on each element of SEQUENCE; is it ever non-nil? @@ -1195,7 +1219,7 @@ predicate under :predicate in KLIST." (let ((predicate (extract-from-klist klist :predicate)) (keyfn (extract-from-klist klist :key 'identity))) - (funcall predicate item (funcall keyfn elt)))) + (funcall predicate (funcall keyfn item)))) (defun elt-satisfies-if-not-p (item klist) "(elt-satisfies-if-not-p ITEM KLIST) => t or nil @@ -1204,7 +1228,7 @@ the predicate under :predicate in KLIST." (let ((predicate (extract-from-klist klist :predicate)) (keyfn (extract-from-klist klist :key 'identity))) - (not (funcall predicate item (funcall keyfn elt))))) + (not (funcall predicate (funcall keyfn item))))) (defun elts-match-under-klist-p (e1 e2 klist) "(elts-match-under-klist-p E1 E2 KLIST) => t or nil @@ -1313,7 +1337,7 @@ allow-other-keys))) (nreverse forms))) body)))) -(put 'with-keyword-args 'lisp-indent-function 1) +(put 'with-keyword-args 'lisp-indent-hook 1) ;;; REDUCE @@ -1394,14 +1418,15 @@ (defun member (item list &rest kargs) "Look for ITEM in LIST; return first tail of LIST the car of whose first -cons cell tests the same as ITEM. Admits arguments :key, :test, and :test-not." +cons cell tests the same as ITEM. Admits arguments :key, :test, and +:test-not." (if (null kargs) ;treat this fast for efficiency (memq item list) (let* ((klist (build-klist kargs '(:test :test-not :key))) (test (extract-from-klist klist :test)) (testnot (extract-from-klist klist :test-not)) (key (extract-from-klist klist :key 'identity))) - ;; another workaround allegledly for speed + ;; another workaround allegedly for speed, BLAH (if (and (or (eq test 'eq) (eq test 'eql) (eq test (symbol-function 'eq)) (eq test (symbol-function 'eql))) @@ -1448,11 +1473,11 @@ ;;;; (quiroz@cs.rochester.edu) ;;; Lisp indentation information -(put 'multiple-value-bind 'lisp-indent-function 2) -(put 'multiple-value-setq 'lisp-indent-function 2) -(put 'multiple-value-list 'lisp-indent-function nil) -(put 'multiple-value-call 'lisp-indent-function 1) -(put 'multiple-value-prog1 'lisp-indent-function 1) +(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 @@ -1478,7 +1503,7 @@ (car *mvalues-values*)) (defun values-list (&optional val-forms) - "Produce multiple values (zero or mode). Each element of LIST is one value. + "Produce multiple values (zero or more). 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'" @@ -1589,29 +1614,29 @@ ;;;; (quiroz@cs.rochester.edu) -(defun plusp (number) +(defsubst plusp (number) "True if NUMBER is strictly greater than zero." (> number 0)) -(defun minusp (number) +(defsubst minusp (number) "True if NUMBER is strictly less than zero." (< number 0)) -(defun oddp (number) +(defsubst oddp (number) "True if INTEGER is not divisible by 2." (/= (% number 2) 0)) -(defun evenp (number) +(defsubst evenp (number) "True if INTEGER is divisible by 2." (= (% number 2) 0)) -(defun abs (number) +(defsubst abs (number) "Return the absolute value of NUMBER." (if (< number 0) (- number) number)) -(defun signum (number) +(defsubst signum (number) "Return -1, 0 or 1 according to the sign of NUMBER." (cond ((< number 0) -1) @@ -1701,59 +1726,56 @@ (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 ;opposite-signs case - (if (zerop r) - (values (- q) 0) - (let ((q (- (+ q 1)))) - (values q (- number (* q divisor))))))))))) + (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 ;opposite-signs case + (if (zerop r) + (values (- q) 0) + (let ((q (- (+ q 1)))) + (values q (- number (* q divisor))))))))))) (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)) - ((plusp s) - (values (+ q 1) (- r divisor))) - (t - (values (- q) (+ number (* q divisor))))))))) + (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 1) (- r divisor))) + (t + (values (- q) (+ number (* q divisor))))))))) (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) ;same as floor - (values q r)) - (t ;same as ceiling - (values (- q) (+ number (* q divisor))))))))) + (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) ;same as floor + (values q r)) + (t ;same as ceiling + (values (- q) (+ number (* q divisor))))))))) (defun round (number &optional divisor) "Divide DIVIDEND by DIVISOR, rounding to nearest integer. @@ -1778,18 +1800,25 @@ (setq r (- number (* q divisor))) (values q r)))))) +;;; These two functions access the implementation-dependent representation of +;;; the multiple value returns. + (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)) +That is, the remainder goes with the quotient produced by `floor'. +Emacs Lisp hint: +If you know that both arguments are positive, use `%' instead for speed." + (floor number divisor) + (cadr *mvalues-values*)) (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)) - +That is, the remainder goes with the quotient produced by `truncate'. +Emacs Lisp hint: +If you know that both arguments are positive, use `%' instead for speed." + (truncate number divisor) + (cadr *mvalues-values*)) + ;;; internal utilities ;;; ;;; safe-idiv performs an integer division with positive numbers only. @@ -1801,16 +1830,14 @@ (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)))) +Q=|A|/|B|, S is the sign of A/B, R is the rest A - S*Q*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* ((q (/ (abs a) (abs b))) + (s (* (signum a) (signum b))) + (r (- a (* s q b)))) (values q r s))) ;;;; end of cl-arith.el @@ -1871,22 +1898,29 @@ (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))))) + ;; dispatch on the type of update function + (cond ((and (consp updatefn) (eq (car updatefn) 'lambda)) + (cons 'funcall + (cons (list 'function updatefn) + (append (cdr place) (list value))))) + ((and (symbolp updatefn) + (fboundp updatefn) + (let ((defn (symbol-function updatefn))) + (or (subrp defn) + (and (consp defn) + (or (eq (car defn) 'lambda) + (eq (car defn) 'macro)))))) + (cons updatefn (append (cdr place) (list value)))) + (t + (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))))))))) @@ -2242,6 +2276,70 @@ (append (cdr newsyms) (list (car newsyms))))) nil)))) +;;; GETF, REMF, and REMPROP +;;; + +(defun getf (place indicator &optional default) + "Return PLACE's PROPNAME property, or DEFAULT if not present." + (while (and place (not (eq (car place) indicator))) + (setq place (cdr (cdr place)))) + (if place + (car (cdr place)) + default)) + +(defmacro getf$setf$method (place indicator default &rest newval) + "SETF method for GETF. Not for public use." + (case (length newval) + (0 (setq newval default default nil)) + (1 (setq newval (car newval))) + (t (error "Wrong number of arguments to (setf (getf ...)) form"))) + (let ((psym (gentemp)) (isym (gentemp)) (vsym (gentemp))) + (list 'let (list (list psym place) + (list isym indicator) + (list vsym newval)) + (list 'while + (list 'and psym + (list 'not + (list 'eq (list 'car psym) isym))) + (list 'setq psym (list 'cdr (list 'cdr psym)))) + (list 'if psym + (list 'setcar (list 'cdr psym) vsym) + (list 'setf place + (list 'nconc place (list 'list isym newval)))) + vsym))) + +(defsetf getf + getf$setf$method) + +(defmacro remf (place indicator) + "Remove from the property list at PLACE its PROPNAME property. +Returns non-nil if and only if the property existed." + (let ((psym (gentemp)) (isym (gentemp))) + (list 'let (list (list psym place) (list isym indicator)) + (list 'cond + (list (list 'eq isym (list 'car psym)) + (list 'setf place (list 'cdr (list 'cdr psym))) + t) + (list t + (list 'setq psym (list 'cdr psym)) + (list 'while + (list 'and (list 'cdr psym) + (list 'not + (list 'eq (list 'car (list 'cdr psym)) + isym))) + (list 'setq psym (list 'cdr (list 'cdr psym)))) + (list 'cond + (list (list 'cdr psym) + (list 'setcdr psym + (list 'cdr + (list 'cdr (list 'cdr psym)))) + t))))))) + +(defun remprop (symbol indicator) + "Remove SYMBOL's PROPNAME property, returning non-nil if it was present." + (remf (symbol-plist symbol) indicator)) + + ;;;; STRUCTS ;;;; This file provides the structures mechanism. See the ;;;; documentation for Common-Lisp's defstruct. Mine doesn't @@ -2402,9 +2500,7 @@ (list 'quote name) 'args)))) (list 'fset (list 'quote copier) - (list 'function - (list 'lambda (list 'struct) - (list 'copy-sequence 'struct)))) + (list 'function 'copy-sequence)) (let ((typetag (gensym))) (list 'fset (list 'quote predicate) (list @@ -2441,7 +2537,7 @@ (list (cons 'vector (mapcar - '(lambda (x) (list 'quote x)) + (function (lambda (x) (list 'quote x))) (cons name slots))))) ;; generate code (cons 'progn @@ -2891,7 +2987,7 @@ ;;; Copiers -(defun copy-list (list) +(defsubst copy-list (list) "Build a copy of LIST" (append list '())) @@ -3037,7 +3133,28 @@ No checking is even attempted. This is just for compatibility with Common-Lisp codes." form) + +;;; Due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91) +(put 'progv 'common-lisp-indent-hook '(4 4 &body)) +(defmacro progv (vars vals &rest body) + "progv vars vals &body forms +bind vars to vals then execute forms. +If there are more vars than vals, the extra vars are unbound, if +there are more vals than vars, the extra vals are just ignored." + (` (progv$runtime (, vars) (, vals) (function (lambda () (,@ body)))))) + +;;; To do this efficiently, it really needs to be a special form... +(defun progv$runtime (vars vals body) + (eval (let ((vars-n-vals nil) + (unbind-forms nil)) + (do ((r vars (cdr r)) + (l vals (cdr l))) + ((endp r)) + (push (list (car r) (list 'quote (car l))) vars-n-vals) + (if (null l) + (push (` (makunbound '(, (car r)))) unbind-forms))) + (` (let (, vars-n-vals) (,@ unbind-forms) (funcall '(, body))))))) (provide 'cl) -;;; cl.el ends here +;;;; end of cl.el