Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents 6240c7796c7a
children aabb7f5b1c81
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
76 (require 76 (require
77 (progn 77 (progn
78 (or (fboundp 'defalias) (fset 'defalias 'fset)) 78 (or (fboundp 'defalias) (fset 'defalias 'fset))
79 (or (fboundp 'cl-transform-function-property) 79 (or (fboundp 'cl-transform-function-property)
80 (defalias 'cl-transform-function-property 80 (defalias 'cl-transform-function-property
81 (function (lambda (n p f) 81 #'(lambda (n p f)
82 (list 'put (list 'quote n) (list 'quote p) 82 (list 'put (list 'quote n) (list 'quote p)
83 (list 'function (cons 'lambda f))))))) 83 (list 'function (cons 'lambda f))))))
84 (car (or features (setq features (list 'cl-kludge)))))) 84 (car (or features (setq features (list 'cl-kludge))))))
85 85
86 86
87 ;;; Initialization. 87 ;;; Initialization.
88 88
95 ;;;###autoload 95 ;;;###autoload
96 (defun cl-compile-time-init () 96 (defun cl-compile-time-init ()
97 (setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form)) 97 (setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form))
98 (or (fboundp 'byte-compile-flush-pending) ; Emacs 19 compiler? 98 (or (fboundp 'byte-compile-flush-pending) ; Emacs 19 compiler?
99 (defalias 'byte-compile-file-form 99 (defalias 'byte-compile-file-form
100 (function 100 #'(lambda (form)
101 (lambda (form) 101 (setq form (macroexpand form byte-compile-macro-environment))
102 (setq form (macroexpand form byte-compile-macro-environment)) 102 (if (eq (car-safe form) 'progn)
103 (if (eq (car-safe form) 'progn) 103 (cons 'progn (mapcar 'byte-compile-file-form (cdr form)))
104 (cons 'progn (mapcar 'byte-compile-file-form (cdr form))) 104 (funcall cl-old-bc-file-form form)))))
105 (funcall cl-old-bc-file-form form))))))
106 (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro) 105 (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro)
107 (run-hooks 'cl-hack-bytecomp-hook)) 106 (run-hooks 'cl-hack-bytecomp-hook))
108 107
109 108
110 ;;; Symbols. 109 ;;; Symbols.
453 (head-list nil) 452 (head-list nil)
454 (last-clause (car (last clauses))) 453 (last-clause (car (last clauses)))
455 (body (cons 454 (body (cons
456 'cond 455 'cond
457 (mapcar 456 (mapcar
458 (function 457 #'(lambda (c)
459 (lambda (c) 458 (cons (cond ((memq (car c) '(t otherwise))
460 (cons (cond ((memq (car c) '(t otherwise)) 459 (or (eq c last-clause)
461 (or (eq c last-clause) 460 (error
462 (error 461 "`%s' is allowed only as the last case clause"
463 "`%s' is allowed only as the last case clause" 462 (car c)))
464 (car c))) 463 t)
465 t) 464 ((eq (car c) 'ecase-error-flag)
466 ((eq (car c) 'ecase-error-flag) 465 (list 'error "ecase failed: %s, %s"
467 (list 'error "ecase failed: %s, %s" 466 temp (list 'quote (reverse head-list))))
468 temp (list 'quote (reverse head-list)))) 467 ((listp (car c))
469 ((listp (car c)) 468 (setq head-list (append (car c) head-list))
470 (setq head-list (append (car c) head-list)) 469 (list 'member* temp (list 'quote (car c))))
471 (list 'member* temp (list 'quote (car c)))) 470 (t
472 (t 471 (if (memq (car c) head-list)
473 (if (memq (car c) head-list) 472 (error "Duplicate key in case: %s"
474 (error "Duplicate key in case: %s" 473 (car c)))
475 (car c))) 474 (cl-push (car c) head-list)
476 (cl-push (car c) head-list) 475 (list 'eql temp (list 'quote (car c)))))
477 (list 'eql temp (list 'quote (car c))))) 476 (or (cdr c) '(nil))))
478 (or (cdr c) '(nil)))))
479 clauses)))) 477 clauses))))
480 (if (eq temp expr) body 478 (if (eq temp expr) body
481 (list 'let (list (list temp expr)) body)))) 479 (list 'let (list (list temp expr)) body))))
482 480
483 ;; #### CL standard also requires `ccase', which signals a continuable 481 ;; #### CL standard also requires `ccase', which signals a continuable
505 (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym))) 503 (let* ((temp (if (cl-simple-expr-p expr 3) expr (gensym)))
506 (type-list nil) 504 (type-list nil)
507 (body (cons 505 (body (cons
508 'cond 506 'cond
509 (mapcar 507 (mapcar
510 (function 508 #'(lambda (c)
511 (lambda (c) 509 (cons (cond ((eq (car c) 'otherwise) t)
512 (cons (cond ((eq (car c) 'otherwise) t) 510 ((eq (car c) 'ecase-error-flag)
513 ((eq (car c) 'ecase-error-flag) 511 (list 'error "etypecase failed: %s, %s"
514 (list 'error "etypecase failed: %s, %s" 512 temp (list 'quote (reverse type-list))))
515 temp (list 'quote (reverse type-list)))) 513 (t
516 (t 514 (cl-push (car c) type-list)
517 (cl-push (car c) type-list) 515 (cl-make-type-test temp (car c))))
518 (cl-make-type-test temp (car c)))) 516 (or (cdr c) '(nil))))
519 (or (cdr c) '(nil)))))
520 clauses)))) 517 clauses))))
521 (if (eq temp expr) body 518 (if (eq temp expr) body
522 (list 'let (list (list temp expr)) body)))) 519 (list 'let (list (list temp expr)) body))))
523 520
524 ;;;###autoload 521 ;;;###autoload
1163 (cl-expand-do-loop steps endtest body t)) 1160 (cl-expand-do-loop steps endtest body t))
1164 1161
1165 (defun cl-expand-do-loop (steps endtest body star) 1162 (defun cl-expand-do-loop (steps endtest body star)
1166 (list 'block nil 1163 (list 'block nil
1167 (list* (if star 'let* 'let) 1164 (list* (if star 'let* 'let)
1168 (mapcar (function (lambda (c) 1165 (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c))
1169 (if (consp c) (list (car c) (nth 1 c)) c)))
1170 steps) 1166 steps)
1171 (list* 'while (list 'not (car endtest)) 1167 (list* 'while (list 'not (car endtest))
1172 (append body 1168 (append body
1173 (let ((sets (mapcar 1169 (let ((sets (mapcar
1174 (function 1170 #'(lambda (c)
1175 (lambda (c) 1171 (and (consp c) (cdr (cdr c))
1176 (and (consp c) (cdr (cdr c)) 1172 (list (car c) (nth 2 c))))
1177 (list (car c) (nth 2 c)))))
1178 steps))) 1173 steps)))
1179 (setq sets (delq nil sets)) 1174 (setq sets (delq nil sets))
1180 (and sets 1175 (and sets
1181 (list (cons (if (or star (not (cdr sets))) 1176 (list (cons (if (or star (not (cdr sets)))
1182 'setq 'psetq) 1177 'setq 'psetq)
1262 rather than its value cell. The FORMs are evaluated with the specified 1257 rather than its value cell. The FORMs are evaluated with the specified
1263 function definitions in place, then the definitions are undone (the FUNCs 1258 function definitions in place, then the definitions are undone (the FUNCs
1264 go back to their previous definitions, or lack thereof)." 1259 go back to their previous definitions, or lack thereof)."
1265 (list* 'letf* 1260 (list* 'letf*
1266 (mapcar 1261 (mapcar
1267 (function 1262 #'(lambda (x)
1268 (lambda (x) 1263 (if (or (and (fboundp (car x))
1269 (if (or (and (fboundp (car x)) 1264 (eq (car-safe (symbol-function (car x))) 'macro))
1270 (eq (car-safe (symbol-function (car x))) 'macro)) 1265 (cdr (assq (car x) cl-macro-environment)))
1271 (cdr (assq (car x) cl-macro-environment))) 1266 (error "Use `labels', not `flet', to rebind macro names"))
1272 (error "Use `labels', not `flet', to rebind macro names")) 1267 (let ((func (list 'function*
1273 (let ((func (list 'function* 1268 (list 'lambda (cadr x)
1274 (list 'lambda (cadr x) 1269 (list* 'block (car x) (cddr x))))))
1275 (list* 'block (car x) (cddr x)))))) 1270 (if (and (cl-compiling-file)
1276 (if (and (cl-compiling-file) 1271 (boundp 'byte-compile-function-environment))
1277 (boundp 'byte-compile-function-environment)) 1272 (cl-push (cons (car x) (eval func))
1278 (cl-push (cons (car x) (eval func)) 1273 byte-compile-function-environment))
1279 byte-compile-function-environment)) 1274 (list (list 'symbol-function (list 'quote (car x))) func)))
1280 (list (list 'symbol-function (list 'quote (car x))) func))))
1281 bindings) 1275 bindings)
1282 body)) 1276 body))
1283 1277
1284 ;;;###autoload 1278 ;;;###autoload
1285 (defmacro labels (bindings &rest body) 1279 (defmacro labels (bindings &rest body)
1286 "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings. 1280 "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings.
1287 This is like `flet', except the bindings are lexical instead of dynamic. 1281 This is like `flet', except the bindings are lexical instead of dynamic.
1288 Unlike `flet', this macro is fully complaint with the Common Lisp standard." 1282 Unlike `flet', this macro is fully compliant with the Common Lisp standard."
1289 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) 1283 (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
1290 (while bindings 1284 (while bindings
1291 (let ((var (gensym))) 1285 (let ((var (gensym)))
1292 (cl-push var vars) 1286 (cl-push var vars)
1293 (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets) 1287 (cl-push (list 'function* (cons 'lambda (cdar bindings))) sets)
1335 (defmacro lexical-let (bindings &rest body) 1329 (defmacro lexical-let (bindings &rest body)
1336 "(lexical-let BINDINGS BODY...): like `let', but lexically scoped. 1330 "(lexical-let BINDINGS BODY...): like `let', but lexically scoped.
1337 The main visible difference is that lambdas inside BODY will create 1331 The main visible difference is that lambdas inside BODY will create
1338 lexical closures as in Common Lisp." 1332 lexical closures as in Common Lisp."
1339 (let* ((cl-closure-vars cl-closure-vars) 1333 (let* ((cl-closure-vars cl-closure-vars)
1340 (vars (mapcar (function 1334 (vars (mapcar #'(lambda (x)
1341 (lambda (x) 1335 (or (consp x) (setq x (list x)))
1342 (or (consp x) (setq x (list x))) 1336 (cl-push (gensym (format "--%s--" (car x)))
1343 (cl-push (gensym (format "--%s--" (car x))) 1337 cl-closure-vars)
1344 cl-closure-vars) 1338 (list (car x) (cadr x) (car cl-closure-vars)))
1345 (list (car x) (cadr x) (car cl-closure-vars))))
1346 bindings)) 1339 bindings))
1347 (ebody 1340 (ebody
1348 (cl-macroexpand-all 1341 (cl-macroexpand-all
1349 (cons 'progn body) 1342 (cons 'progn body)
1350 (nconc (mapcar (function (lambda (x) 1343 (nconc (mapcar #'(lambda (x)
1351 (list (symbol-name (car x)) 1344 (list (symbol-name (car x))
1352 (list 'symbol-value (caddr x)) 1345 (list 'symbol-value (caddr x))
1353 t))) vars) 1346 t))
1347 vars)
1354 (list '(defun . cl-defun-expander)) 1348 (list '(defun . cl-defun-expander))
1355 cl-macro-environment)))) 1349 cl-macro-environment))))
1356 (if (not (get (car (last cl-closure-vars)) 'used)) 1350 (if (not (get (car (last cl-closure-vars)) 'used))
1357 (list 'let (mapcar (function (lambda (x) 1351 (list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars)
1358 (list (caddr x) (cadr x)))) vars) 1352 (sublis (mapcar #'(lambda (x)
1359 (sublis (mapcar (function (lambda (x) 1353 (cons (caddr x) (list 'quote (caddr x))))
1360 (cons (caddr x)
1361 (list 'quote (caddr x)))))
1362 vars) 1354 vars)
1363 ebody)) 1355 ebody))
1364 (list 'let (mapcar (function (lambda (x) 1356 (list 'let (mapcar #'(lambda (x)
1365 (list (caddr x) 1357 (list (caddr x)
1366 (list 'make-symbol 1358 (list 'make-symbol
1367 (format "--%s--" (car x)))))) 1359 (format "--%s--" (car x)))))
1368 vars) 1360 vars)
1369 (apply 'append '(setf) 1361 (apply 'append '(setf)
1370 (mapcar (function 1362 (mapcar #'(lambda (x)
1371 (lambda (x) 1363 (list (list 'symbol-value (caddr x)) (cadr x)))
1372 (list (list 'symbol-value (caddr x)) (cadr x))))
1373 vars)) 1364 vars))
1374 ebody)))) 1365 ebody))))
1375 1366
1376 ;;;###autoload 1367 ;;;###autoload
1377 (defmacro lexical-let* (bindings &rest body) 1368 (defmacro lexical-let* (bindings &rest body)
1401 is analogous to the Common Lisp `multiple-value-bind' macro, using lists to 1392 is analogous to the Common Lisp `multiple-value-bind' macro, using lists to
1402 simulate true multiple return values. For compatibility, (values A B C) is 1393 simulate true multiple return values. For compatibility, (values A B C) is
1403 a synonym for (list A B C)." 1394 a synonym for (list A B C)."
1404 (let ((temp (gensym)) (n -1)) 1395 (let ((temp (gensym)) (n -1))
1405 (list* 'let* (cons (list temp form) 1396 (list* 'let* (cons (list temp form)
1406 (mapcar (function 1397 (mapcar #'(lambda (v)
1407 (lambda (v) 1398 (list v (list 'nth (setq n (1+ n)) temp)))
1408 (list v (list 'nth (setq n (1+ n)) temp))))
1409 vars)) 1399 vars))
1410 body))) 1400 body)))
1411 1401
1412 ;;;###autoload 1402 ;;;###autoload
1413 (defmacro multiple-value-setq (vars form) 1403 (defmacro multiple-value-setq (vars form)
1420 ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) 1410 ((null (cdr vars)) (list 'setq (car vars) (list 'car form)))
1421 (t 1411 (t
1422 (let* ((temp (gensym)) (n 0)) 1412 (let* ((temp (gensym)) (n 0))
1423 (list 'let (list (list temp form)) 1413 (list 'let (list (list temp form))
1424 (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp)) 1414 (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp))
1425 (cons 'setq (apply 'nconc 1415 (cons 'setq
1426 (mapcar (function 1416 (apply 'nconc
1427 (lambda (v) 1417 (mapcar
1428 (list v (list 1418 #'(lambda (v)
1429 'nth 1419 (list v (list
1430 (setq n (1+ n)) 1420 'nth
1431 temp)))) 1421 (setq n (1+ n))
1432 vars))))))))) 1422 temp)))
1423 vars)))))))))
1433 1424
1434 1425
1435 ;;; Declarations. 1426 ;;; Declarations.
1436 1427
1437 ;;;###autoload 1428 ;;;###autoload
1446 (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history)) 1437 (and hist (listp cl-proclaim-history) (cl-push spec cl-proclaim-history))
1447 (cond ((eq (car-safe spec) 'special) 1438 (cond ((eq (car-safe spec) 'special)
1448 (if (boundp 'byte-compile-bound-variables) 1439 (if (boundp 'byte-compile-bound-variables)
1449 (setq byte-compile-bound-variables 1440 (setq byte-compile-bound-variables
1450 ;; todo: this should compute correct binding bits vs. 0 1441 ;; todo: this should compute correct binding bits vs. 0
1451 (append (mapcar #'(lambda (v) (cons v 0)) 1442 (append (mapcar #'(lambda (v) (cons v 0))
1452 (cdr spec)) 1443 (cdr spec))
1453 byte-compile-bound-variables)))) 1444 byte-compile-bound-variables))))
1454 1445
1455 ((eq (car-safe spec) 'inline) 1446 ((eq (car-safe spec) 'inline)
1456 (while (setq spec (cdr spec)) 1447 (while (setq spec (cdr spec))
1602 (if (car args) 1593 (if (car args)
1603 (list 'list '(quote progn) call 'store) 1594 (list 'list '(quote progn) call 'store)
1604 call))))) 1595 call)))))
1605 1596
1606 ;;; Some standard place types from Common Lisp. 1597 ;;; Some standard place types from Common Lisp.
1598 (eval-when-compile (defvar ignored-arg)) ; Warning suppression
1607 (defsetf aref aset) 1599 (defsetf aref aset)
1608 (defsetf car setcar) 1600 (defsetf car setcar)
1609 (defsetf cdr setcdr) 1601 (defsetf cdr setcdr)
1610 (defsetf elt (seq n) (store) 1602 (defsetf elt (seq n) (store)
1611 (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store) 1603 (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store)
1612 (list 'aset seq n store))) 1604 (list 'aset seq n store)))
1613 (defsetf get (x y &optional d) (store) (list 'put x y store)) 1605 (defsetf get (x y &optional ignored-arg) (store) (list 'put x y store))
1614 (defsetf get* (x y &optional d) (store) (list 'put x y store)) 1606 (defsetf get* (x y &optional ignored-arg) (store) (list 'put x y store))
1615 (defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h)) 1607 (defsetf gethash (x h &optional ignored-arg) (store) (list 'cl-puthash x store h))
1616 (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) 1608 (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))
1617 (defsetf subseq (seq start &optional end) (new) 1609 (defsetf subseq (seq start &optional end) (new)
1618 (list 'progn (list 'replace seq new ':start1 start ':end1 end) new)) 1610 (list 'progn (list 'replace seq new ':start1 start ':end1 end) new))
1619 (defsetf symbol-function fset) 1611 (defsetf symbol-function fset)
1620 (defsetf symbol-plist setplist) 1612 (defsetf symbol-plist setplist)
1651 (defsetf default-file-modes set-default-file-modes t) 1643 (defsetf default-file-modes set-default-file-modes t)
1652 (defsetf default-value set-default) 1644 (defsetf default-value set-default)
1653 (defsetf documentation-property put) 1645 (defsetf documentation-property put)
1654 (defsetf extent-face set-extent-face) 1646 (defsetf extent-face set-extent-face)
1655 (defsetf extent-priority set-extent-priority) 1647 (defsetf extent-priority set-extent-priority)
1656 (defsetf extent-property (x y &optional d) (arg) 1648 (defsetf extent-property (x y &optional ignored-arg) (arg)
1657 (list 'set-extent-property x y arg)) 1649 (list 'set-extent-property x y arg))
1658 (defsetf extent-end-position (ext) (store) 1650 (defsetf extent-end-position (ext) (store)
1659 (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) 1651 (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
1660 store) store)) 1652 store) store))
1661 (defsetf extent-start-position (ext) (store) 1653 (defsetf extent-start-position (ext) (store)
1671 (defsetf file-modes set-file-modes t) 1663 (defsetf file-modes set-file-modes t)
1672 (defsetf frame-parameters modify-frame-parameters t) 1664 (defsetf frame-parameters modify-frame-parameters t)
1673 (defsetf frame-visible-p cl-set-frame-visible-p) 1665 (defsetf frame-visible-p cl-set-frame-visible-p)
1674 (defsetf frame-properties (&optional f) (p) 1666 (defsetf frame-properties (&optional f) (p)
1675 `(progn (set-frame-properties ,f ,p) ,p)) 1667 `(progn (set-frame-properties ,f ,p) ,p))
1676 (defsetf frame-property (f p &optional d) (v) 1668 (defsetf frame-property (f p &optional ignored-arg) (v)
1677 `(progn (set-frame-property ,f ,v) ,p)) 1669 `(progn (set-frame-property ,f ,v) ,p))
1678 (defsetf frame-width (&optional f) (v) 1670 (defsetf frame-width (&optional f) (v)
1679 `(progn (set-frame-width ,f ,v) ,v)) 1671 `(progn (set-frame-width ,f ,v) ,v))
1680 (defsetf frame-height (&optional f) (v) 1672 (defsetf frame-height (&optional f) (v)
1681 `(progn (set-frame-height ,f ,v) ,v)) 1673 `(progn (set-frame-height ,f ,v) ,v))
1706 (defsetf widget-get widget-put t) 1698 (defsetf widget-get widget-put t)
1707 (defsetf widget-value widget-value-set t) 1699 (defsetf widget-value widget-value-set t)
1708 1700
1709 ;; Misc 1701 ;; Misc
1710 (defsetf recent-keys-ring-size set-recent-keys-ring-size) 1702 (defsetf recent-keys-ring-size set-recent-keys-ring-size)
1711 (defsetf symbol-value-in-buffer (s b &optional u) (store) 1703 (defsetf symbol-value-in-buffer (s b &optional ignored-arg) (store)
1712 `(with-current-buffer ,b (set ,s ,store))) 1704 `(with-current-buffer ,b (set ,s ,store)))
1713 (defsetf symbol-value-in-console (s c &optional u) (store) 1705 (defsetf symbol-value-in-console (s c &optional ignored-arg) (store)
1714 `(letf (((selected-console) ,c)) 1706 `(letf (((selected-console) ,c))
1715 (set ,s ,store))) 1707 (set ,s ,store)))
1716 1708
1717 (defsetf buffer-dedicated-frame (&optional b) (v) 1709 (defsetf buffer-dedicated-frame (&optional b) (v)
1718 `(set-buffer-dedicated-frame ,b ,v)) 1710 `(set-buffer-dedicated-frame ,b ,v))
1742 (defsetf itimer-value set-itimer-value) 1734 (defsetf itimer-value set-itimer-value)
1743 (defsetf keymap-parents set-keymap-parents) 1735 (defsetf keymap-parents set-keymap-parents)
1744 (defsetf marker-insertion-type set-marker-insertion-type) 1736 (defsetf marker-insertion-type set-marker-insertion-type)
1745 (defsetf mouse-pixel-position (&optional d) (v) 1737 (defsetf mouse-pixel-position (&optional d) (v)
1746 `(progn 1738 `(progn
1747 set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v)) 1739 (set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v)))
1748 ,v)) 1740 ,v))
1749 (defsetf trunc-stack-length set-trunc-stack-length) 1741 (defsetf trunc-stack-length set-trunc-stack-length)
1750 (defsetf trunc-stack-stack set-trunc-stack-stack) 1742 (defsetf trunc-stack-stack set-trunc-stack-stack)
1751 (defsetf undoable-stack-max set-undoable-stack-max) 1743 (defsetf undoable-stack-max set-undoable-stack-max)
1752 (defsetf weak-list-list set-weak-list-list) 1744 (defsetf weak-list-list set-weak-list-list)
1789 (defsetf syntax-table set-syntax-table) 1781 (defsetf syntax-table set-syntax-table)
1790 (defsetf visited-file-modtime set-visited-file-modtime t) 1782 (defsetf visited-file-modtime set-visited-file-modtime t)
1791 (defsetf window-buffer set-window-buffer t) 1783 (defsetf window-buffer set-window-buffer t)
1792 (defsetf window-display-table set-window-display-table t) 1784 (defsetf window-display-table set-window-display-table t)
1793 (defsetf window-dedicated-p set-window-dedicated-p t) 1785 (defsetf window-dedicated-p set-window-dedicated-p t)
1794 (defsetf window-height () (store) 1786 (defsetf window-height (&optional window) (store)
1795 (list 'progn (list 'enlarge-window (list '- store '(window-height))) store)) 1787 `(progn (enlarge-window (- ,store (window-height)) nil ,window) ,store))
1796 (defsetf window-hscroll set-window-hscroll) 1788 (defsetf window-hscroll set-window-hscroll)
1797 (defsetf window-point set-window-point) 1789 (defsetf window-point set-window-point)
1798 (defsetf window-start set-window-start) 1790 (defsetf window-start set-window-start)
1799 (defsetf window-width () (store) 1791 (defsetf window-width (&optional window) (store)
1800 (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) 1792 `(progn (enlarge-window (- ,store (window-width)) t ,window) ,store))
1801 (defsetf x-get-cutbuffer x-store-cutbuffer t) 1793 (defsetf x-get-cutbuffer x-store-cutbuffer t)
1802 (defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. 1794 (defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan.
1803 (defsetf x-get-secondary-selection x-own-secondary-selection t) 1795 (defsetf x-get-secondary-selection x-own-secondary-selection t)
1804 (defsetf x-get-selection x-own-selection t) 1796 (defsetf x-get-selection x-own-selection t)
1805 1797
2078 values. Note that this macro is *not* available in Common Lisp. 2070 values. Note that this macro is *not* available in Common Lisp.
2079 As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', 2071 As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)',
2080 the PLACE is not modified before executing BODY." 2072 the PLACE is not modified before executing BODY."
2081 (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) 2073 (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
2082 (list* 'let bindings body) 2074 (list* 'let bindings body)
2083 (let ((lets nil) (sets nil) 2075 (let ((lets nil)
2084 (unsets nil) (rev (reverse bindings))) 2076 (rev (reverse bindings)))
2085 (while rev 2077 (while rev
2086 (let* ((place (if (symbolp (caar rev)) 2078 (let* ((place (if (symbolp (caar rev))
2087 (list 'symbol-value (list 'quote (caar rev))) 2079 (list 'symbol-value (list 'quote (caar rev)))
2088 (caar rev))) 2080 (caar rev)))
2089 (value (cadar rev)) 2081 (value (cadar rev))
2202 (safety (if (cl-compiling-file) cl-optimize-safety 3)) 2194 (safety (if (cl-compiling-file) cl-optimize-safety 3))
2203 (include nil) 2195 (include nil)
2204 (tag (intern (format "cl-struct-%s" name))) 2196 (tag (intern (format "cl-struct-%s" name)))
2205 (tag-symbol (intern (format "cl-struct-%s-tags" name))) 2197 (tag-symbol (intern (format "cl-struct-%s-tags" name)))
2206 (include-descs nil) 2198 (include-descs nil)
2207 ;; XEmacs change
2208 (include-tag-symbol nil)
2209 (side-eff nil) 2199 (side-eff nil)
2210 (type nil) 2200 (type nil)
2211 (named nil) 2201 (named nil)
2212 (forms nil) 2202 (forms nil)
2213 pred-form pred-check) 2203 pred-form pred-check)
2214 (if (stringp (car descs)) 2204 (if (stringp (car descs))
2215 (cl-push (list 'put (list 'quote name) '(quote structure-documentation) 2205 (cl-push (list 'put (list 'quote name) '(quote structure-documentation)
2216 (cl-pop descs)) forms)) 2206 (cl-pop descs)) forms))
2217 (setq descs (cons '(cl-tag-slot) 2207 (setq descs (cons '(cl-tag-slot)
2218 (mapcar (function (lambda (x) (if (consp x) x (list x)))) 2208 (mapcar #'(lambda (x) (if (consp x) x (list x)))
2219 descs))) 2209 descs)))
2220 (while opts 2210 (while opts
2221 (let ((opt (if (consp (car opts)) (caar opts) (car opts))) 2211 (let ((opt (if (consp (car opts)) (caar opts) (car opts)))
2222 (args (cdr-safe (cl-pop opts)))) 2212 (args (cdr-safe (cl-pop opts))))
2223 (cond ((eq opt ':conc-name) 2213 (cond ((eq opt ':conc-name)
2232 (if args (setq copier (car args)))) 2222 (if args (setq copier (car args))))
2233 ((eq opt ':predicate) 2223 ((eq opt ':predicate)
2234 (if args (setq predicate (car args)))) 2224 (if args (setq predicate (car args))))
2235 ((eq opt ':include) 2225 ((eq opt ':include)
2236 (setq include (car args) 2226 (setq include (car args)
2237 include-descs (mapcar (function 2227 include-descs (mapcar #'(lambda (x)
2238 (lambda (x) 2228 (if (consp x) x (list x)))
2239 (if (consp x) x (list x)))) 2229 (cdr args))))
2240 (cdr args))
2241 ;; XEmacs change
2242 include-tag-symbol (intern (format "cl-struct-%s-tags"
2243 include))))
2244 ((eq opt ':print-function) 2230 ((eq opt ':print-function)
2245 (setq print-func (car args))) 2231 (setq print-func (car args)))
2246 ((eq opt ':type) 2232 ((eq opt ':type)
2247 (setq type (car args))) 2233 (setq type (car args)))
2248 ((eq opt ':named) 2234 ((eq opt ':named)
2368 constrs)) 2354 constrs))
2369 (while constrs 2355 (while constrs
2370 (let* ((name (caar constrs)) 2356 (let* ((name (caar constrs))
2371 (args (cadr (cl-pop constrs))) 2357 (args (cadr (cl-pop constrs)))
2372 (anames (cl-arglist-args args)) 2358 (anames (cl-arglist-args args))
2373 (make (mapcar* (function (lambda (s d) (if (memq s anames) s d))) 2359 (make (mapcar* #'(lambda (s d) (if (memq s anames) s d))
2374 slots defaults))) 2360 slots defaults)))
2375 (cl-push (list 'defsubst* name 2361 (cl-push (list 'defsubst* name
2376 (list* '&cl-defs (list 'quote (cons nil descs)) args) 2362 (list* '&cl-defs (list 'quote (cons nil descs)) args)
2377 (cons type make)) forms) 2363 (cons type make)) forms)
2378 (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs))) 2364 (if (cl-safe-expr-p (cons 'progn (mapcar 'second descs)))
2392 (list 'quote (list type (eq named t)))) 2378 (list 'quote (list type (eq named t))))
2393 (list 'put (list 'quote name) '(quote cl-struct-include) 2379 (list 'put (list 'quote name) '(quote cl-struct-include)
2394 (list 'quote include)) 2380 (list 'quote include))
2395 (list 'put (list 'quote name) '(quote cl-struct-print) 2381 (list 'put (list 'quote name) '(quote cl-struct-print)
2396 print-auto) 2382 print-auto)
2397 (mapcar (function (lambda (x) 2383 (mapcar #'(lambda (x)
2398 (list 'put (list 'quote (car x)) 2384 (list 'put (list 'quote (car x))
2399 '(quote side-effect-free) 2385 '(quote side-effect-free)
2400 (list 'quote (cdr x))))) 2386 (list 'quote (cdr x))))
2401 side-eff)) 2387 side-eff))
2402 forms) 2388 forms)
2403 (cons 'progn (nreverse (cons (list 'quote name) forms))))) 2389 (cons 'progn (nreverse (cons (list 'quote name) forms)))))
2404 2390
2405 ;;;###autoload 2391 ;;;###autoload
2462 (if (memq (caddr type) '(* nil)) t 2448 (if (memq (caddr type) '(* nil)) t
2463 (if (consp (caddr type)) (list '< val (caaddr type)) 2449 (if (consp (caddr type)) (list '< val (caaddr type))
2464 (list '<= val (caddr type))))))) 2450 (list '<= val (caddr type)))))))
2465 ((memq (car-safe type) '(and or not)) 2451 ((memq (car-safe type) '(and or not))
2466 (cons (car type) 2452 (cons (car type)
2467 (mapcar (function (lambda (x) (cl-make-type-test val x))) 2453 (mapcar #'(lambda (x) (cl-make-type-test val x))
2468 (cdr type)))) 2454 (cdr type))))
2469 ((memq (car-safe type) '(member member*)) 2455 ((memq (car-safe type) '(member member*))
2470 (list 'and (list 'member* val (list 'quote (cdr type))) t)) 2456 (list 'and (list 'member* val (list 'quote (cdr type))) t))
2471 ((eq (car-safe type) 'satisfies) (list (cadr type) val)) 2457 ((eq (car-safe type) 'satisfies) (list (cadr type) val))
2472 (t (error "Bad type spec: %s" type))))) 2458 (t (error "Bad type spec: %s" type)))))
2499 They are not evaluated unless the assertion fails. If STRING is 2485 They are not evaluated unless the assertion fails. If STRING is
2500 omitted, a default message listing FORM itself is used." 2486 omitted, a default message listing FORM itself is used."
2501 (and (or (not (cl-compiling-file)) 2487 (and (or (not (cl-compiling-file))
2502 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) 2488 (< cl-optimize-speed 3) (= cl-optimize-safety 3))
2503 (let ((sargs (and show-args (delq nil (mapcar 2489 (let ((sargs (and show-args (delq nil (mapcar
2504 (function 2490 #'(lambda (x)
2505 (lambda (x) 2491 (and (not (cl-const-expr-p x))
2506 (and (not (cl-const-expr-p x)) 2492 x))
2507 x))) (cdr form)))))) 2493 (cdr form))))))
2508 (list 'progn 2494 (list 'progn
2509 (list 'or form 2495 (list 'or form
2510 (if string 2496 (if string
2511 (list* 'error string (append sargs args)) 2497 (list* 'error string (append sargs args))
2512 (list 'signal '(quote cl-assertion-failed) 2498 (list 'signal '(quote cl-assertion-failed)
2515 2501
2516 ;;;###autoload 2502 ;;;###autoload
2517 (defmacro ignore-errors (&rest body) 2503 (defmacro ignore-errors (&rest body)
2518 "Execute FORMS; if an error occurs, return nil. 2504 "Execute FORMS; if an error occurs, return nil.
2519 Otherwise, return result of last FORM." 2505 Otherwise, return result of last FORM."
2520 (list 'condition-case nil (cons 'progn body) '(error nil))) 2506 `(condition-case nil (progn ,@body) (error nil)))
2521 2507
2508 ;;;###autoload
2509 (defmacro ignore-file-errors (&rest body)
2510 "Execute FORMS; if an error of type `file-error' occurs, return nil.
2511 Otherwise, return result of last FORM."
2512 `(condition-case nil (progn ,@body) (file-error nil)))
2522 2513
2523 ;;; Some predicates for analyzing Lisp forms. These are used by various 2514 ;;; Some predicates for analyzing Lisp forms. These are used by various
2524 ;;; macro expanders to optimize the results in certain common cases. 2515 ;;; macro expanders to optimize the results in certain common cases.
2525 2516
2526 (defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max 2517 (defconst cl-simple-funcs '(car cdr nth aref elt if and or + - 1+ 1- min max
2670 2661
2671 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs) 2662 (defun cl-defsubst-expand (argns body simple whole unsafe &rest argvs)
2672 (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole 2663 (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
2673 (if (cl-simple-exprs-p argvs) (setq simple t)) 2664 (if (cl-simple-exprs-p argvs) (setq simple t))
2674 (let ((lets (delq nil 2665 (let ((lets (delq nil
2675 (mapcar* (function 2666 (mapcar* #'(lambda (argn argv)
2676 (lambda (argn argv) 2667 (if (or simple (cl-const-expr-p argv))
2677 (if (or simple (cl-const-expr-p argv)) 2668 (progn (setq body (subst argv argn body))
2678 (progn (setq body (subst argv argn body)) 2669 (and unsafe (list argn argv)))
2679 (and unsafe (list argn argv))) 2670 (list argn argv)))
2680 (list argn argv))))
2681 argns argvs)))) 2671 argns argvs))))
2682 (if lets (list 'let lets body) body)))) 2672 (if lets (list 'let lets body) body))))
2683 2673
2684 2674
2685 ;;; Compile-time optimizations for some functions defined in this package. 2675 ;;; Compile-time optimizations for some functions defined in this package.
2767 (let ((temp (gensym))) 2757 (let ((temp (gensym)))
2768 (list 'let (list (list temp val)) (subst temp val res))))) 2758 (list 'let (list (list temp val)) (subst temp val res)))))
2769 form)) 2759 form))
2770 2760
2771 2761
2772 (mapcar (function 2762 (mapc
2773 (lambda (y) 2763 #'(lambda (y)
2774 (put (car y) 'side-effect-free t) 2764 (put (car y) 'side-effect-free t)
2775 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) 2765 (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
2776 (put (car y) 'cl-compiler-macro 2766 (put (car y) 'cl-compiler-macro
2777 (list 'lambda '(w x) 2767 (list 'lambda '(w x)
2778 (if (symbolp (cadr y)) 2768 (if (symbolp (cadr y))
2779 (list 'list (list 'quote (cadr y)) 2769 (list 'list (list 'quote (cadr y))
2780 (list 'list (list 'quote (caddr y)) 'x)) 2770 (list 'list (list 'quote (caddr y)) 'x))
2781 (cons 'list (cdr y))))))) 2771 (cons 'list (cdr y))))))
2782 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) 2772 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
2783 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) 2773 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
2784 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) 2774 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
2785 (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) 2775 (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
2786 (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) 2776 (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
2787 (caaar car caar) (caadr car cadr) (cadar car cdar) 2777 (caaar car caar) (caadr car cadr) (cadar car cdar)
2788 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) 2778 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
2789 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) 2779 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
2790 (caaadr car caadr) (caadar car cadar) (caaddr car caddr) 2780 (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
2791 (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) 2781 (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
2792 (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) 2782 (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
2793 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) 2783 (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
2794 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) 2784 (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr)))
2795 2785
2796 ;;; Things that are inline. 2786 ;;; Things that are inline.
2797 (proclaim '(inline floatp-safe acons map concatenate notany notevery 2787 (proclaim '(inline floatp-safe acons map concatenate notany notevery
2798 ;; XEmacs change 2788 ;; XEmacs change
2799 cl-set-elt revappend nreconc)) 2789 cl-set-elt revappend nreconc
2800 2790 plusp minusp oddp evenp
2801 ;;; Things that are side-effect-free. 2791 ))
2802 (mapcar (function (lambda (x) (put x 'side-effect-free t))) 2792
2803 '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm 2793 ;;; Things that are side-effect-free. Moved to byte-optimize.el
2804 isqrt floor* ceiling* truncate* round* mod* rem* subseq 2794 ;(dolist (fun '(oddp evenp plusp minusp
2805 list-length get* getf gethash hash-table-count)) 2795 ; abs expt signum last butlast ldiff
2806 2796 ; pairlis gcd lcm
2807 ;;; Things that are side-effect-and-error-free. 2797 ; isqrt floor* ceiling* truncate* round* mod* rem* subseq
2808 (mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) 2798 ; list-length get* getf))
2809 '(eql floatp-safe list* subst acons equalp random-state-p 2799 ; (put fun 'side-effect-free t))
2810 copy-tree sublis hash-table-p)) 2800
2801 ;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el
2802 ;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p
2803 ; copy-tree sublis))
2804 ; (put fun 'side-effect-free 'error-free))
2811 2805
2812 2806
2813 (run-hooks 'cl-macs-load-hook) 2807 (run-hooks 'cl-macs-load-hook)
2814 2808
2815 ;;; cl-macs.el ends here 2809 ;;; cl-macs.el ends here