Mercurial > emacs
comparison lisp/emacs-lisp/cl-macs.el @ 26940:f1998d661bc2
Remove conditional definition of eval-when-compile. Don't specify abs,
expt, gethash, hash-table-count, hash-table-p as side-effect-free here.
(cl-emacs-type): Don't declare.
(cl-compile-time-init): Remove Emacs 18 compiler patch.
(cl-parse-loop-clause): Remove compatibility code.
author | Dave Love <fx@gnu.org> |
---|---|
date | Sat, 18 Dec 1999 17:10:56 +0000 |
parents | f7ee88b7618a |
children | deeb1c237778 |
comparison
equal
deleted
inserted
replaced
26939:672e75118c0f | 26940:f1998d661bc2 |
---|---|
29 ;; Common Lisp compatibility, beyond what is already built-in | 29 ;; Common Lisp compatibility, beyond what is already built-in |
30 ;; in Emacs Lisp. | 30 ;; in Emacs Lisp. |
31 ;; | 31 ;; |
32 ;; This package was written by Dave Gillespie; it is a complete | 32 ;; This package was written by Dave Gillespie; it is a complete |
33 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | 33 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. |
34 ;; | |
35 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. | |
36 ;; | 34 ;; |
37 ;; Bug reports, comments, and suggestions are welcome! | 35 ;; Bug reports, comments, and suggestions are welcome! |
38 | 36 |
39 ;; This file contains the portions of the Common Lisp extensions | 37 ;; This file contains the portions of the Common Lisp extensions |
40 ;; package which should be autoloaded, but need only be present | 38 ;; package which should be autoloaded, but need only be present |
61 (list 'setq place (list 'cdr (list 'cdr place))))) | 59 (list 'setq place (list 'cdr (list 'cdr place))))) |
62 (put 'cl-push 'edebug-form-spec 'edebug-sexps) | 60 (put 'cl-push 'edebug-form-spec 'edebug-sexps) |
63 (put 'cl-pop 'edebug-form-spec 'edebug-sexps) | 61 (put 'cl-pop 'edebug-form-spec 'edebug-sexps) |
64 (put 'cl-pop2 'edebug-form-spec 'edebug-sexps) | 62 (put 'cl-pop2 'edebug-form-spec 'edebug-sexps) |
65 | 63 |
66 (defvar cl-emacs-type) | |
67 (defvar cl-optimize-safety) | 64 (defvar cl-optimize-safety) |
68 (defvar cl-optimize-speed) | 65 (defvar cl-optimize-speed) |
69 | 66 |
70 | 67 |
71 ;;; This kludge allows macros which use cl-transform-function-property | 68 ;;; This kludge allows macros which use cl-transform-function-property |
84 | 81 |
85 ;;; Initialization. | 82 ;;; Initialization. |
86 | 83 |
87 (defvar cl-old-bc-file-form nil) | 84 (defvar cl-old-bc-file-form nil) |
88 | 85 |
89 ;; Patch broken Emacs 18 compiler (re top-level macros). | |
90 ;; Emacs 19 compiler doesn't need this patch. | |
91 ;; Also, undo broken definition of `eql' that uses same bytecode as `eq'. | |
92 (defun cl-compile-time-init () | 86 (defun cl-compile-time-init () |
93 (setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form)) | |
94 (or (fboundp 'byte-compile-flush-pending) ; Emacs 19 compiler? | |
95 (defalias 'byte-compile-file-form | |
96 (function | |
97 (lambda (form) | |
98 (setq form (macroexpand form byte-compile-macro-environment)) | |
99 (if (eq (car-safe form) 'progn) | |
100 (cons 'progn (mapcar 'byte-compile-file-form (cdr form))) | |
101 (funcall cl-old-bc-file-form form)))))) | |
102 (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro) | |
103 (run-hooks 'cl-hack-bytecomp-hook)) | 87 (run-hooks 'cl-hack-bytecomp-hook)) |
104 | 88 |
105 | 89 |
106 ;;; Symbols. | 90 ;;; Symbols. |
107 | 91 |
396 (if (or (memq 'eval when) (memq ':execute when)) | 380 (if (or (memq 'eval when) (memq ':execute when)) |
397 (list* 'eval-when (cons 'compile when) (cddr form)) | 381 (list* 'eval-when (cons 'compile when) (cddr form)) |
398 form))) | 382 form))) |
399 (t (eval form) form))) | 383 (t (eval form) form))) |
400 | 384 |
401 (or (and (fboundp 'eval-when-compile) | |
402 (not (eq (car-safe (symbol-function 'eval-when-compile)) 'autoload))) | |
403 (eval '(defmacro eval-when-compile (&rest body) | |
404 "Like `progn', but evaluates the body at compile time. | |
405 The result of the body appears to the compiler as a quoted constant." | |
406 (list 'quote (eval (cons 'progn body)))))) | |
407 | |
408 (defmacro load-time-value (form &optional read-only) | 385 (defmacro load-time-value (form &optional read-only) |
409 "Like `progn', but evaluates the body at load time. | 386 "Like `progn', but evaluates the body at load time. |
410 The result of the body appears to the compiler as a quoted constant." | 387 The result of the body appears to the compiler as a quoted constant." |
411 (if (cl-compiling-file) | 388 (if (cl-compiling-file) |
412 (let* ((temp (gentemp "--cl-load-time--")) | 389 (let* ((temp (gentemp "--cl-load-time--")) |
860 (list 'function (list* 'lambda (list var other) | 837 (list 'function (list* 'lambda (list var other) |
861 '--cl-map)) map)))) | 838 '--cl-map)) map)))) |
862 | 839 |
863 ((memq word '(frame frames screen screens)) | 840 ((memq word '(frame frames screen screens)) |
864 (let ((temp (gensym))) | 841 (let ((temp (gensym))) |
865 (cl-push (list var (if (eq cl-emacs-type 'lucid) | 842 (cl-push (list var '(selected-frame)) |
866 '(selected-screen) '(selected-frame))) | |
867 loop-for-bindings) | 843 loop-for-bindings) |
868 (cl-push (list temp nil) loop-for-bindings) | 844 (cl-push (list temp nil) loop-for-bindings) |
869 (cl-push (list 'prog1 (list 'not (list 'eq var temp)) | 845 (cl-push (list 'prog1 (list 'not (list 'eq var temp)) |
870 (list 'or temp (list 'setq temp var))) | 846 (list 'or temp (list 'setq temp var))) |
871 loop-body) | 847 loop-body) |
872 (cl-push (list var (list (if (eq cl-emacs-type 'lucid) | 848 (cl-push (list var (list 'next-frame var)) |
873 'next-screen 'next-frame) var)) | |
874 loop-for-steps))) | 849 loop-for-steps))) |
875 | 850 |
876 ((memq word '(window windows)) | 851 ((memq word '(window windows)) |
877 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) | 852 (let ((scr (and (memq (car args) '(in of)) (cl-pop2 args))) |
878 (temp (gensym))) | 853 (temp (gensym))) |
879 (cl-push (list var (if scr | 854 (cl-push (list var (if scr |
880 (list (if (eq cl-emacs-type 'lucid) | 855 (list 'frame-selected-window scr) |
881 'screen-selected-window | |
882 'frame-selected-window) scr) | |
883 '(selected-window))) | 856 '(selected-window))) |
884 loop-for-bindings) | 857 loop-for-bindings) |
885 (cl-push (list temp nil) loop-for-bindings) | 858 (cl-push (list temp nil) loop-for-bindings) |
886 (cl-push (list 'prog1 (list 'not (list 'eq var temp)) | 859 (cl-push (list 'prog1 (list 'not (list 'eq var temp)) |
887 (list 'or temp (list 'setq temp var))) | 860 (list 'or temp (list 'setq temp var))) |
2623 (proclaim '(inline floatp-safe acons map concatenate notany notevery | 2596 (proclaim '(inline floatp-safe acons map concatenate notany notevery |
2624 cl-set-elt revappend nreconc gethash)) | 2597 cl-set-elt revappend nreconc gethash)) |
2625 | 2598 |
2626 ;;; Things that are side-effect-free. | 2599 ;;; Things that are side-effect-free. |
2627 (mapcar (function (lambda (x) (put x 'side-effect-free t))) | 2600 (mapcar (function (lambda (x) (put x 'side-effect-free t))) |
2628 '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm | 2601 '(oddp evenp signum last butlast ldiff pairlis gcd lcm |
2629 isqrt floor* ceiling* truncate* round* mod* rem* subseq | 2602 isqrt floor* ceiling* truncate* round* mod* rem* subseq |
2630 list-length get* getf gethash hash-table-count)) | 2603 list-length get* getf)) |
2631 | 2604 |
2632 ;;; Things that are side-effect-and-error-free. | 2605 ;;; Things that are side-effect-and-error-free. |
2633 (mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) | 2606 (mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) |
2634 '(eql floatp-safe list* subst acons equalp random-state-p | 2607 '(eql floatp-safe list* subst acons equalp random-state-p |
2635 copy-tree sublis hash-table-p)) | 2608 copy-tree sublis)) |
2636 | 2609 |
2637 | 2610 |
2638 (run-hooks 'cl-macs-load-hook) | 2611 (run-hooks 'cl-macs-load-hook) |
2639 | 2612 |
2640 ;;; cl-macs.el ends here | 2613 ;;; cl-macs.el ends here |