Mercurial > hg > xemacs-beta

comparison lisp/cl/cl-macs.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 859a2309aef8
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details. 19 ;; General Public License for more details.
20 20
21 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING. If not, write to the Free 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
23 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
24 24 ;; 02111-1307, USA.
25 ;;; Synched up with: FSF 19.30. 25
26 ;;; Synched up with: FSF 19.34.
26 27
27 ;;; Commentary: 28 ;;; Commentary:
28 29
29 ;; These are extensions to Emacs Lisp that provide a degree of 30 ;; These are extensions to Emacs Lisp that provide a degree of
30 ;; Common Lisp compatibility, beyond what is already built-in 31 ;; Common Lisp compatibility, beyond what is already built-in
416 (list 'fset '(quote byte-compile-file-form) 417 (list 'fset '(quote byte-compile-file-form)
417 (list 'quote 418 (list 'quote
418 (symbol-function 'byte-compile-file-form))) 419 (symbol-function 'byte-compile-file-form)))
419 (list 'byte-compile-file-form (list 'quote set)) 420 (list 'byte-compile-file-form (list 'quote set))
420 '(byte-compile-file-form form))) 421 '(byte-compile-file-form form)))
422 ;; XEmacs change
421 (print set (symbol-value ;;'outbuffer 423 (print set (symbol-value ;;'outbuffer
422 'byte-compile-output-buffer 424 'byte-compile-output-buffer
423 ))) 425 )))
424 (list 'symbol-value (list 'quote temp))) 426 (list 'symbol-value (list 'quote temp)))
425 (list 'quote (eval form)))) 427 (list 'quote (eval form))))
1223 go back to their previous definitions, or lack thereof)." 1225 go back to their previous definitions, or lack thereof)."
1224 (list* 'letf* 1226 (list* 'letf*
1225 (mapcar 1227 (mapcar
1226 (function 1228 (function
1227 (lambda (x) 1229 (lambda (x)
1230 (if (or (and (fboundp (car x))
1231 (eq (car-safe (symbol-function (car x))) 'macro))
1232 (cdr (assq (car x) cl-macro-environment)))
1233 (error "Use `labels', not `flet', to rebind macro names"))
1228 (let ((func (list 'function* 1234 (let ((func (list 'function*
1229 (list 'lambda (cadr x) 1235 (list 'lambda (cadr x)
1230 (list* 'block (car x) (cddr x)))))) 1236 (list* 'block (car x) (cddr x))))))
1231 (if (and (cl-compiling-file) 1237 (if (and (cl-compiling-file)
1232 (boundp 'byte-compile-function-environment)) 1238 (boundp 'byte-compile-function-environment))
1234 byte-compile-function-environment)) 1240 byte-compile-function-environment))
1235 (list (list 'symbol-function (list 'quote (car x))) func)))) 1241 (list (list 'symbol-function (list 'quote (car x))) func))))
1236 bindings) 1242 bindings)
1237 body)) 1243 body))
1238 1244
1239 (defmacro labels (&rest args) (cons 'flet args)) 1245 (defmacro labels (bindings &rest body)
1246 "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings.
1247 This is like `flet', except the bindings are lexical instead of dynamic.
1248 Unlike `flet', this macro is fully complaint with the Common Lisp standard."
1249 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
1250 (while bindings
1251 (let ((var (gensym)))
1252 (cl-push var vars)
1253 (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets)
1254 (cl-push var sets)
1255 (cl-push (list (car (cl-pop bindings)) 'lambda '(&rest cl-labels-args)
1256 (list 'list* '(quote funcall) (list 'quote var)
1257 'cl-labels-args))
1258 cl-macro-environment)))
1259 (cl-macroexpand-all (list* 'lexical-let vars (cons (cons 'setq sets) body))
1260 cl-macro-environment)))
1240 1261
1241 ;; The following ought to have a better definition for use with newer 1262 ;; The following ought to have a better definition for use with newer
1242 ;; byte compilers. 1263 ;; byte compilers.
1243 (defmacro macrolet (bindings &rest body) 1264 (defmacro macrolet (bindings &rest body)
1244 "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns. 1265 "(macrolet ((NAME ARGLIST BODY...) ...) FORM...): make temporary macro defns.
1404 (if safety (setq cl-optimize-safety (car safety) 1425 (if safety (setq cl-optimize-safety (car safety)
1405 byte-compile-delete-errors (nth 1 safety))))) 1426 byte-compile-delete-errors (nth 1 safety)))))
1406 1427
1407 ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) 1428 ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
1408 (if (eq byte-compile-warnings t) 1429 (if (eq byte-compile-warnings t)
1430 ;; XEmacs change
1409 (setq byte-compile-warnings byte-compile-default-warnings)) 1431 (setq byte-compile-warnings byte-compile-default-warnings))
1410 (while (setq spec (cdr spec)) 1432 (while (setq spec (cdr spec))
1411 (if (consp (car spec)) 1433 (if (consp (car spec))
1412 (if (eq (cadar spec) 0) 1434 (if (eq (cadar spec) 0)
1413 (setq byte-compile-warnings 1435 (setq byte-compile-warnings
1576 (defsetf default-value set-default) 1598 (defsetf default-value set-default)
1577 (defsetf documentation-property put) 1599 (defsetf documentation-property put)
1578 (defsetf extent-data set-extent-data) ; obsolete 1600 (defsetf extent-data set-extent-data) ; obsolete
1579 (defsetf extent-face set-extent-face) 1601 (defsetf extent-face set-extent-face)
1580 (defsetf extent-priority set-extent-priority) 1602 (defsetf extent-priority set-extent-priority)
1603 ;; XEmacs change
1581 (defsetf extent-property set-extent-property) 1604 (defsetf extent-property set-extent-property)
1582 (defsetf extent-end-position (ext) (store) 1605 (defsetf extent-end-position (ext) (store)
1583 (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) 1606 (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
1584 store) store)) 1607 store) store))
1585 (defsetf extent-start-position (ext) (store) 1608 (defsetf extent-start-position (ext) (store)
2019 (safety (if (cl-compiling-file) cl-optimize-safety 3)) 2042 (safety (if (cl-compiling-file) cl-optimize-safety 3))
2020 (include nil) 2043 (include nil)
2021 (tag (intern (format "cl-struct-%s" name))) 2044 (tag (intern (format "cl-struct-%s" name)))
2022 (tag-symbol (intern (format "cl-struct-%s-tags" name))) 2045 (tag-symbol (intern (format "cl-struct-%s-tags" name)))
2023 (include-descs nil) 2046 (include-descs nil)
2047 ;; XEmacs change
2024 (include-tag-symbol nil) 2048 (include-tag-symbol nil)
2025 (side-eff nil) 2049 (side-eff nil)
2026 (type nil) 2050 (type nil)
2027 (named nil) 2051 (named nil)
2028 (forms nil) 2052 (forms nil)
2052 (setq include (car args) 2076 (setq include (car args)
2053 include-descs (mapcar (function 2077 include-descs (mapcar (function
2054 (lambda (x) 2078 (lambda (x)
2055 (if (consp x) x (list x)))) 2079 (if (consp x) x (list x))))
2056 (cdr args)) 2080 (cdr args))
2081 ;; XEmacs change
2057 include-tag-symbol (intern (format "cl-struct-%s-tags" 2082 include-tag-symbol (intern (format "cl-struct-%s-tags"
2058 include)))) 2083 include))))
2059 ((eq opt ':print-function) 2084 ((eq opt ':print-function)
2060 (setq print-func (car args))) 2085 (setq print-func (car args)))
2061 ((eq opt ':type) 2086 ((eq opt ':type)
2091 (cl-pop include-descs))) 2116 (cl-pop include-descs)))
2092 (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) 2117 (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs))
2093 type (car inc-type) 2118 type (car inc-type)
2094 named (assq 'cl-tag-slot descs)) 2119 named (assq 'cl-tag-slot descs))
2095 (if (cadr inc-type) (setq tag name named t)) 2120 (if (cadr inc-type) (setq tag name named t))
2096 (cl-push (list 'pushnew (list 'quote tag) include-tag-symbol) 2121 (let ((incl include))
2097 forms)) 2122 (while incl
2123 (cl-push (list 'pushnew (list 'quote tag)
2124 (intern (format "cl-struct-%s-tags" incl)))
2125 forms)
2126 (setq incl (get incl 'cl-struct-include)))))
2098 (if type 2127 (if type
2099 (progn 2128 (progn
2100 (or (memq type '(vector list)) 2129 (or (memq type '(vector list))
2101 (error "Illegal :type specifier: %s" type)) 2130 (error "Illegal :type specifier: %s" type))
2102 (if named (setq tag name))) 2131 (if named (setq tag name)))
2199 (cl-push (list* 'eval-when '(compile load eval) 2228 (cl-push (list* 'eval-when '(compile load eval)
2200 (list 'put (list 'quote name) '(quote cl-struct-slots) 2229 (list 'put (list 'quote name) '(quote cl-struct-slots)
2201 (list 'quote descs)) 2230 (list 'quote descs))
2202 (list 'put (list 'quote name) '(quote cl-struct-type) 2231 (list 'put (list 'quote name) '(quote cl-struct-type)
2203 (list 'quote (list type (eq named t)))) 2232 (list 'quote (list type (eq named t))))
2233 (list 'put (list 'quote name) '(quote cl-struct-include)
2234 (list 'quote include))
2204 (list 'put (list 'quote name) '(quote cl-struct-print) 2235 (list 'put (list 'quote name) '(quote cl-struct-print)
2205 print-auto) 2236 print-auto)
2206 (mapcar (function (lambda (x) 2237 (mapcar (function (lambda (x)
2207 (list 'put (list 'quote (car x)) 2238 (list 'put (list 'quote (car x))
2208 '(quote side-effect-free) 2239 '(quote side-effect-free)
2595 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) 2626 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
2596 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) 2627 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))
2597 2628
2598 ;;; Things that are inline. 2629 ;;; Things that are inline.
2599 (proclaim '(inline floatp-safe acons map concatenate notany notevery 2630 (proclaim '(inline floatp-safe acons map concatenate notany notevery
2631 ;; XEmacs change
2600 cl-set-elt revappend nreconc)) 2632 cl-set-elt revappend nreconc))
2601 2633
2602 ;;; Things that are side-effect-free. 2634 ;;; Things that are side-effect-free.
2603 (mapcar (function (lambda (x) (put x 'side-effect-free t))) 2635 (mapcar (function (lambda (x) (put x 'side-effect-free t)))
2604 '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm 2636 '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm