(or (fboundp 'defalias) (fset 'defalias 'fset))
(or (fboundp 'cl-transform-function-property)
(defalias 'cl-transform-function-property
- (function (lambda (n p f)
- (list 'put (list 'quote n) (list 'quote p)
- (list 'function (cons 'lambda f)))))))
- (car (or features (setq features (list 'cl-kludge))))))
+ #'(lambda (n p f)
+ (list 'put (list 'quote n) (list 'quote p)
+ (list 'function (cons 'lambda f))))))
+ 'xemacs))
;;; Initialization.
(setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form))
(or (fboundp 'byte-compile-flush-pending) ; Emacs 19 compiler?
(defalias 'byte-compile-file-form
- (function
- (lambda (form)
- (setq form (macroexpand form byte-compile-macro-environment))
- (if (eq (car-safe form) 'progn)
- (cons 'progn (mapcar 'byte-compile-file-form (cdr form)))
- (funcall cl-old-bc-file-form form))))))
+ #'(lambda (form)
+ (setq form (macroexpand form byte-compile-macro-environment))
+ (if (eq (car-safe form) 'progn)
+ (cons 'progn (mapcar 'byte-compile-file-form (cdr form)))
+ (funcall cl-old-bc-file-form form)))))
(put 'eql 'byte-compile 'cl-byte-compile-compiler-macro)
(run-hooks 'cl-hack-bytecomp-hook))
-;;; Symbols.
-
-(defvar *gensym-counter*)
-
-;;;###autoload
-(defun gensym (&optional arg)
- "Generate a new uninterned symbol.
-The name is made by appending a number to PREFIX, default \"G\"."
- (let ((prefix (if (stringp arg) arg "G"))
- (num (if (integerp arg) arg
- (prog1 *gensym-counter*
- (setq *gensym-counter* (1+ *gensym-counter*))))))
- (make-symbol (format "%s%d" prefix num))))
-
-;;;###autoload
-(defun gentemp (&optional arg)
- "Generate a new interned symbol with a unique name.
-The name is made by appending a number to PREFIX, default \"G\"."
- (let ((prefix (if (stringp arg) arg "G"))
- name)
- (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*)))
- (setq *gensym-counter* (1+ *gensym-counter*)))
- (intern name)))
-
-
;;; Program structure.
;;;###autoload
(defvar cl-macro-environment nil)
(defvar bind-block) (defvar bind-defs) (defvar bind-enquote)
(defvar bind-inits) (defvar bind-lets) (defvar bind-forms)
+(defvar arglist-visited)
+
+;; npak@ispras.ru
+(defun cl-upcase-arg (arg)
+ ;; Changes all non-keyword symbols in `ARG' to symbols
+ ;; with name in upper case.
+ ;; ARG is either symbol or list of symbols or lists
+ (cond ;;((null arg) 'NIL)
+ ((symbolp arg)
+ ;; Do not upcase &optional, &key etc.
+ (if (memq arg lambda-list-keywords) arg
+ (intern (upcase (symbol-name arg)))))
+ ((listp arg)
+ (if (memq arg arglist-visited) (error 'circular-list '(arg)))
+ (cl-push arg arglist-visited)
+ (let ((arg (copy-list arg)) junk)
+ ;; Clean the list
+ (let ((p (last arg))) (if (cdr p) (setcdr p (list '&rest (cdr p)))))
+ (if (setq junk (cadr (memq '&cl-defs arg)))
+ (setq arg (delq '&cl-defs (delq junk arg))))
+ (if (memq '&cl-quote arg)
+ (setq arg (delq '&cl-quote arg)))
+ (mapcar 'cl-upcase-arg arg)))
+ (t arg) ; May be we are in initializer
+ ))
+
+;; npak@ispras.ru
+(defun cl-function-arglist (name arglist)
+ "Returns string with printed representation of arguments list.
+Supports Common Lisp lambda lists."
+ (if (not (or (listp arglist) (symbolp arglist))) "Not available"
+ (setq arglist-visited nil)
+ (condition-case nil
+ (prin1-to-string
+ (cons (if (eq name 'cl-none) 'lambda name)
+ (cond ((null arglist) nil)
+ ((listp arglist) (cl-upcase-arg arglist))
+ ((symbolp arglist)
+ (cl-upcase-arg (list '&rest arglist)))
+ (t (wrong-type-argument 'listp arglist)))))
+ (t "Not available"))))
(defun cl-transform-lambda (form bind-block)
(let* ((args (car form)) (body (cdr form))
(bind-defs nil) (bind-enquote nil)
(bind-inits nil) (bind-lets nil) (bind-forms nil)
- (header nil) (simple-args nil))
+ (header nil) (simple-args nil)
+ (doc ""))
+ ;; Add CL lambda list to documentation. npak@ispras.ru
+ (if (and (stringp (car body))
+ (cdr body))
+ (setq doc (cl-pop body)))
+ (cl-push (concat doc
+ "\nCommon Lisp lambda list:\n"
+ " " (cl-function-arglist bind-block args)
+ "\n\n")
+ header)
+
(while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
(cl-push (cl-pop body) header))
(setq args (if (listp args) (copy-list args) (list '&rest args)))
(body (cons
'cond
(mapcar
- (function
- (lambda (c)
- (cons (cond ((memq (car c) '(t otherwise))
- (or (eq c last-clause)
- (error
- "`%s' is allowed only as the last case clause"
- (car c)))
- t)
- ((eq (car c) 'ecase-error-flag)
- (list 'error "ecase failed: %s, %s"
- temp (list 'quote (reverse head-list))))
- ((listp (car c))
- (setq head-list (append (car c) head-list))
- (list 'member* temp (list 'quote (car c))))
- (t
- (if (memq (car c) head-list)
- (error "Duplicate key in case: %s"
- (car c)))
- (cl-push (car c) head-list)
- (list 'eql temp (list 'quote (car c)))))
- (or (cdr c) '(nil)))))
+ #'(lambda (c)
+ (cons (cond ((memq (car c) '(t otherwise))
+ (or (eq c last-clause)
+ (error
+ "`%s' is allowed only as the last case clause"
+ (car c)))
+ t)
+ ((eq (car c) 'ecase-error-flag)
+ (list 'error "ecase failed: %s, %s"
+ temp (list 'quote (reverse head-list))))
+ ((listp (car c))
+ (setq head-list (append (car c) head-list))
+ (list 'member* temp (list 'quote (car c))))
+ (t
+ (if (memq (car c) head-list)
+ (error "Duplicate key in case: %s"
+ (car c)))
+ (cl-push (car c) head-list)
+ (list 'eql temp (list 'quote (car c)))))
+ (or (cdr c) '(nil))))
clauses))))
(if (eq temp expr) body
(list 'let (list (list temp expr)) body))))
(body (cons
'cond
(mapcar
- (function
- (lambda (c)
- (cons (cond ((eq (car c) 'otherwise) t)
- ((eq (car c) 'ecase-error-flag)
- (list 'error "etypecase failed: %s, %s"
- temp (list 'quote (reverse type-list))))
- (t
- (cl-push (car c) type-list)
- (cl-make-type-test temp (car c))))
- (or (cdr c) '(nil)))))
+ #'(lambda (c)
+ (cons (cond ((eq (car c) 'otherwise) t)
+ ((eq (car c) 'ecase-error-flag)
+ (list 'error "etypecase failed: %s, %s"
+ temp (list 'quote (reverse type-list))))
+ (t
+ (cl-push (car c) type-list)
+ (cl-make-type-test temp (car c))))
+ (or (cdr c) '(nil))))
clauses))))
(if (eq temp expr) body
(list 'let (list (list temp expr)) body))))
;;;###autoload
(defmacro return-from (name &optional res)
"(return-from NAME [RESULT]): return from the block named NAME.
-This jump out to the innermost enclosing `(block NAME ...)' form,
+This jumps out to the innermost enclosing `(block NAME ...)' form,
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
(defun cl-expand-do-loop (steps endtest body star)
(list 'block nil
(list* (if star 'let* 'let)
- (mapcar (function (lambda (c)
- (if (consp c) (list (car c) (nth 1 c)) c)))
+ (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c))
steps)
(list* 'while (list 'not (car endtest))
(append body
(let ((sets (mapcar
- (function
- (lambda (c)
- (and (consp c) (cdr (cdr c))
- (list (car c) (nth 2 c)))))
+ #'(lambda (c)
+ (and (consp c) (cdr (cdr c))
+ (list (car c) (nth 2 c))))
steps)))
(setq sets (delq nil sets))
(and sets
go back to their previous definitions, or lack thereof)."
(list* 'letf*
(mapcar
- (function
- (lambda (x)
- (if (or (and (fboundp (car x))
- (eq (car-safe (symbol-function (car x))) 'macro))
- (cdr (assq (car x) cl-macro-environment)))
- (error "Use `labels', not `flet', to rebind macro names"))
- (let ((func (list 'function*
- (list 'lambda (cadr x)
- (list* 'block (car x) (cddr x))))))
- (if (and (cl-compiling-file)
- (boundp 'byte-compile-function-environment))
- (cl-push (cons (car x) (eval func))
- byte-compile-function-environment))
- (list (list 'symbol-function (list 'quote (car x))) func))))
+ #'(lambda (x)
+ (if (or (and (fboundp (car x))
+ (eq (car-safe (symbol-function (car x))) 'macro))
+ (cdr (assq (car x) cl-macro-environment)))
+ (error "Use `labels', not `flet', to rebind macro names"))
+ (let ((func (list 'function*
+ (list 'lambda (cadr x)
+ (list* 'block (car x) (cddr x))))))
+ (if (and (cl-compiling-file)
+ (boundp 'byte-compile-function-environment))
+ (cl-push (cons (car x) (eval func))
+ byte-compile-function-environment))
+ (list (list 'symbol-function (list 'quote (car x))) func)))
bindings)
body))
(defmacro labels (bindings &rest body)
"(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings.
This is like `flet', except the bindings are lexical instead of dynamic.
-Unlike `flet', this macro is fully complaint with the Common Lisp standard."
+Unlike `flet', this macro is fully compliant with the Common Lisp standard."
(let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment))
(while bindings
(let ((var (gensym)))
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp."
(let* ((cl-closure-vars cl-closure-vars)
- (vars (mapcar (function
- (lambda (x)
- (or (consp x) (setq x (list x)))
- (cl-push (gensym (format "--%s--" (car x)))
- cl-closure-vars)
- (list (car x) (cadr x) (car cl-closure-vars))))
+ (vars (mapcar #'(lambda (x)
+ (or (consp x) (setq x (list x)))
+ (cl-push (gensym (format "--%s--" (car x)))
+ cl-closure-vars)
+ (list (car x) (cadr x) (car cl-closure-vars)))
bindings))
- (ebody
+ (ebody
(cl-macroexpand-all
(cons 'progn body)
- (nconc (mapcar (function (lambda (x)
- (list (symbol-name (car x))
- (list 'symbol-value (caddr x))
- t))) vars)
+ (nconc (mapcar #'(lambda (x)
+ (list (symbol-name (car x))
+ (list 'symbol-value (caddr x))
+ t))
+ vars)
(list '(defun . cl-defun-expander))
cl-macro-environment))))
(if (not (get (car (last cl-closure-vars)) 'used))
- (list 'let (mapcar (function (lambda (x)
- (list (caddr x) (cadr x)))) vars)
- (sublis (mapcar (function (lambda (x)
- (cons (caddr x)
- (list 'quote (caddr x)))))
+ (list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars)
+ (sublis (mapcar #'(lambda (x)
+ (cons (caddr x) (list 'quote (caddr x))))
vars)
ebody))
- (list 'let (mapcar (function (lambda (x)
- (list (caddr x)
- (list 'make-symbol
- (format "--%s--" (car x))))))
+ (list 'let (mapcar #'(lambda (x)
+ (list (caddr x)
+ (list 'make-symbol
+ (format "--%s--" (car x)))))
vars)
(apply 'append '(setf)
- (mapcar (function
- (lambda (x)
- (list (list 'symbol-value (caddr x)) (cadr x))))
+ (mapcar #'(lambda (x)
+ (list (list 'symbol-value (caddr x)) (cadr x)))
vars))
ebody))))
a synonym for (list A B C)."
(let ((temp (gensym)) (n -1))
(list* 'let* (cons (list temp form)
- (mapcar (function
- (lambda (v)
- (list v (list 'nth (setq n (1+ n)) temp))))
+ (mapcar #'(lambda (v)
+ (list v (list 'nth (setq n (1+ n)) temp)))
vars))
body)))
(let* ((temp (gensym)) (n 0))
(list 'let (list (list temp form))
(list 'prog1 (list 'setq (cl-pop vars) (list 'car temp))
- (cons 'setq (apply 'nconc
- (mapcar (function
- (lambda (v)
- (list v (list
- 'nth
- (setq n (1+ n))
- temp))))
- vars)))))))))
+ (cons 'setq
+ (apply 'nconc
+ (mapcar
+ #'(lambda (v)
+ (list v (list
+ 'nth
+ (setq n (1+ n))
+ temp)))
+ vars)))))))))
;;; Declarations.
(cond ((eq (car-safe spec) 'special)
(if (boundp 'byte-compile-bound-variables)
(setq byte-compile-bound-variables
- ;; todo: this should compute correct binding bits vs. 0
- (append (mapcar #'(lambda (v) (cons v 0))
- (cdr spec))
- byte-compile-bound-variables))))
+ (append
+ (mapcar #'(lambda (v) (cons v byte-compile-global-bit))
+ (cdr spec))
+ byte-compile-bound-variables))))
((eq (car-safe spec) 'inline)
(while (setq spec (cdr spec))
((eq (car-safe spec) 'optimize)
(let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
- '((0 nil) (1 t) (2 t) (3 t))))
+ '((0 . nil) (1 . t) (2 . t) (3 . t))))
(safety (assq (nth 1 (assq 'safety (cdr spec)))
- '((0 t) (1 t) (2 t) (3 nil)))))
- (if speed (setq cl-optimize-speed (car speed)
- byte-optimize (nth 1 speed)))
- (if safety (setq cl-optimize-safety (car safety)
- byte-compile-delete-errors (nth 1 safety)))))
+ '((0 . t) (1 . t) (2 . t) (3 . nil)))))
+ (when speed
+ (setq cl-optimize-speed (car speed)
+ byte-optimize (cdr speed)))
+ (when safety
+ (setq cl-optimize-safety (car safety)
+ byte-compile-delete-errors (cdr safety)))))
((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
(if (eq byte-compile-warnings t)
call)))))
;;; Some standard place types from Common Lisp.
+(eval-when-compile (defvar ignored-arg)) ; Warning suppression
(defsetf aref aset)
(defsetf car setcar)
(defsetf cdr setcdr)
(defsetf elt (seq n) (store)
(list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store)
(list 'aset seq n store)))
-(defsetf get (x y &optional d) (store) (list 'put x y store))
-(defsetf get* (x y &optional d) (store) (list 'put x y store))
-(defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h))
+(defsetf get (x y &optional ignored-arg) (store) (list 'put x y store))
+(defsetf get* (x y &optional ignored-arg) (store) (list 'put x y store))
+(defsetf gethash (x h &optional ignored-arg) (store) (list 'cl-puthash x store h))
(defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store))
(defsetf subseq (seq start &optional end) (new)
(list 'progn (list 'replace seq new ':start1 start ':end1 end) new))
(defsetf documentation-property put)
(defsetf extent-face set-extent-face)
(defsetf extent-priority set-extent-priority)
-(defsetf extent-property (x y &optional d) (arg)
+(defsetf extent-property (x y &optional ignored-arg) (arg)
(list 'set-extent-property x y arg))
-(defsetf extent-end-position (ext) (store)
- (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext)
- store) store))
(defsetf extent-start-position (ext) (store)
- (list 'progn (list 'set-extent-endpoints store
- (list 'extent-end-position ext)) store))
+ `(progn (set-extent-endpoints ,ext ,store (extent-end-position ,ext))
+ ,store))
+(defsetf extent-end-position (ext) (store)
+ `(progn (set-extent-endpoints ,ext (extent-start-position ,ext) ,store)
+ ,store))
(defsetf face-background (f &optional s) (x) (list 'set-face-background f x s))
(defsetf face-background-pixmap (f &optional s) (x)
(list 'set-face-background-pixmap f x s))
(defsetf frame-visible-p cl-set-frame-visible-p)
(defsetf frame-properties (&optional f) (p)
`(progn (set-frame-properties ,f ,p) ,p))
-(defsetf frame-property (f p &optional d) (v)
+(defsetf frame-property (f p &optional ignored-arg) (v)
`(progn (set-frame-property ,f ,v) ,p))
(defsetf frame-width (&optional f) (v)
`(progn (set-frame-width ,f ,v) ,v))
;; Misc
(defsetf recent-keys-ring-size set-recent-keys-ring-size)
-(defsetf symbol-value-in-buffer (s b &optional u) (store)
+(defsetf symbol-value-in-buffer (s b &optional ignored-arg) (store)
`(with-current-buffer ,b (set ,s ,store)))
-(defsetf symbol-value-in-console (s c &optional u) (store)
+(defsetf symbol-value-in-console (s c &optional ignored-arg) (store)
`(letf (((selected-console) ,c))
(set ,s ,store)))
;; Avoid adding various face and glyph functions.
(defsetf frame-selected-window (&optional f) (v)
`(set-frame-selected-window ,f ,v))
+(defsetf glyph-image (glyph &optional domain) (i)
+ (list 'set-glyph-image glyph i domain))
(defsetf itimer-function set-itimer-function)
(defsetf itimer-function-arguments set-itimer-function-arguments)
(defsetf itimer-is-idle set-itimer-is-idle)
(defsetf marker-insertion-type set-marker-insertion-type)
(defsetf mouse-pixel-position (&optional d) (v)
`(progn
- set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v))
+ (set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v)))
,v))
(defsetf trunc-stack-length set-trunc-stack-length)
(defsetf trunc-stack-stack set-trunc-stack-stack)
(defsetf window-buffer set-window-buffer t)
(defsetf window-display-table set-window-display-table t)
(defsetf window-dedicated-p set-window-dedicated-p t)
-(defsetf window-height () (store)
- (list 'progn (list 'enlarge-window (list '- store '(window-height))) store))
+(defsetf window-height (&optional window) (store)
+ `(progn (enlarge-window (- ,store (window-height)) nil ,window) ,store))
(defsetf window-hscroll set-window-hscroll)
(defsetf window-point set-window-point)
(defsetf window-start set-window-start)
-(defsetf window-width () (store)
- (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store))
+(defsetf window-width (&optional window) (store)
+ `(progn (enlarge-window (- ,store (window-width)) t ,window) ,store))
(defsetf x-get-cutbuffer x-store-cutbuffer t)
(defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan.
(defsetf x-get-secondary-selection x-own-secondary-selection t)
(defsetf x-get-selection x-own-selection t)
+(defsetf get-selection own-selection t)
;;; More complex setf-methods.
;;; These should take &environment arguments, but since full arglists aren't
the PLACE is not modified before executing BODY."
(if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)))
(list* 'let bindings body)
- (let ((lets nil) (sets nil)
- (unsets nil) (rev (reverse bindings)))
+ (let ((lets nil)
+ (rev (reverse bindings)))
(while rev
(let* ((place (if (symbolp (caar rev))
(list 'symbol-value (list 'quote (caar rev)))
(tag (intern (format "cl-struct-%s" name)))
(tag-symbol (intern (format "cl-struct-%s-tags" name)))
(include-descs nil)
- ;; XEmacs change
- (include-tag-symbol nil)
(side-eff nil)
(type nil)
(named nil)
(cl-push (list 'put (list 'quote name) '(quote structure-documentation)
(cl-pop descs)) forms))
(setq descs (cons '(cl-tag-slot)
- (mapcar (function (lambda (x) (if (consp x) x (list x))))
+ (mapcar #'(lambda (x) (if (consp x) x (list x)))
descs)))
(while opts
(let ((opt (if (consp (car opts)) (caar opts) (car opts)))
(if args (setq predicate (car args))))
((eq opt ':include)
(setq include (car args)
- include-descs (mapcar (function
- (lambda (x)
- (if (consp x) x (list x))))
- (cdr args))
- ;; XEmacs change
- include-tag-symbol (intern (format "cl-struct-%s-tags"
- include))))
+ include-descs (mapcar #'(lambda (x)
+ (if (consp x) x (list x)))
+ (cdr args))))
((eq opt ':print-function)
(setq print-func (car args)))
((eq opt ':type)
(let* ((name (caar constrs))
(args (cadr (cl-pop constrs)))
(anames (cl-arglist-args args))
- (make (mapcar* (function (lambda (s d) (if (memq s anames) s d)))
+ (make (mapcar* #'(lambda (s d) (if (memq s anames) s d))
slots defaults)))
(cl-push (list 'defsubst* name
(list* '&cl-defs (list 'quote (cons nil descs)) args)
(list 'quote include))
(list 'put (list 'quote name) '(quote cl-struct-print)
print-auto)
- (mapcar (function (lambda (x)
- (list 'put (list 'quote (car x))
- '(quote side-effect-free)
- (list 'quote (cdr x)))))
+ (mapcar #'(lambda (x)
+ (list 'put (list 'quote (car x))
+ '(quote side-effect-free)
+ (list 'quote (cdr x))))
side-eff))
forms)
(cons 'progn (nreverse (cons (list 'quote name) forms)))))
(list '<= val (caddr type)))))))
((memq (car-safe type) '(and or not))
(cons (car type)
- (mapcar (function (lambda (x) (cl-make-type-test val x)))
+ (mapcar #'(lambda (x) (cl-make-type-test val x))
(cdr type))))
((memq (car-safe type) '(member member*))
(list 'and (list 'member* val (list 'quote (cdr type))) t))
(t (error "Bad type spec: %s" type)))))
;;;###autoload
-(defun typep (val type) ; See compiler macro below.
+(defun typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
- (eval (cl-make-type-test 'val type)))
+ (eval (cl-make-type-test 'object type)))
;;;###autoload
-(defmacro check-type (form type &optional string)
- "Verify that FORM is of type TYPE; signal an error if not.
+(defmacro check-type (place type &optional string)
+ "Verify that PLACE is of type TYPE; signal a continuable error if not.
STRING is an optional description of the desired type."
- (and (or (not (cl-compiling-file))
- (< cl-optimize-speed 3) (= cl-optimize-safety 3))
- (let* ((temp (if (cl-simple-expr-p form 3) form (gensym)))
- (body (list 'or (cl-make-type-test temp type)
- (list 'signal '(quote wrong-type-argument)
- (list 'list (or string (list 'quote type))
- temp (list 'quote form))))))
- (if (eq temp form) (list 'progn body nil)
- (list 'let (list (list temp form)) body nil)))))
+ (when (or (not (cl-compiling-file))
+ (< cl-optimize-speed 3)
+ (= cl-optimize-safety 3))
+ (let* ((temp (if (cl-simple-expr-p place 3) place (gensym)))
+ (test (cl-make-type-test temp type))
+ (signal-error `(signal 'wrong-type-argument
+ ,(list 'list (or string (list 'quote type))
+ temp (list 'quote place))))
+ (body
+ (condition-case nil
+ `(while (not ,test)
+ ,(macroexpand `(setf ,place ,signal-error)))
+ (error
+ `(if ,test (progn ,signal-error nil))))))
+ (if (eq temp place)
+ body
+ `(let ((,temp ,place)) ,body)))))
;;;###autoload
(defmacro assert (form &optional show-args string &rest args)
(and (or (not (cl-compiling-file))
(< cl-optimize-speed 3) (= cl-optimize-safety 3))
(let ((sargs (and show-args (delq nil (mapcar
- (function
- (lambda (x)
- (and (not (cl-const-expr-p x))
- x))) (cdr form))))))
+ #'(lambda (x)
+ (and (not (cl-const-expr-p x))
+ x))
+ (cdr form))))))
(list 'progn
(list 'or form
(if string
(defmacro ignore-errors (&rest body)
"Execute FORMS; if an error occurs, return nil.
Otherwise, return result of last FORM."
- (list 'condition-case nil (cons 'progn body) '(error nil)))
+ `(condition-case nil (progn ,@body) (error nil)))
+;;;###autoload
+(defmacro ignore-file-errors (&rest body)
+ "Execute FORMS; if an error of type `file-error' occurs, return nil.
+Otherwise, return result of last FORM."
+ `(condition-case nil (progn ,@body) (file-error nil)))
;;; Some predicates for analyzing Lisp forms. These are used by various
;;; macro expanders to optimize the results in certain common cases.
(if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole
(if (cl-simple-exprs-p argvs) (setq simple t))
(let ((lets (delq nil
- (mapcar* (function
- (lambda (argn argv)
- (if (or simple (cl-const-expr-p argv))
- (progn (setq body (subst argv argn body))
- (and unsafe (list argn argv)))
- (list argn argv))))
+ (mapcar* #'(lambda (argn argv)
+ (if (or simple (cl-const-expr-p argv))
+ (progn (setq body (subst argv argn body))
+ (and unsafe (list argn argv)))
+ (list argn argv)))
argns argvs))))
(if lets (list 'let lets body) body))))
(setq form (list 'cons (car args) form)))
form))
-(define-compiler-macro get* (sym prop &optional def)
- (if def
- (list 'getf (list 'symbol-plist sym) prop def)
- (list 'get sym prop)))
+(define-compiler-macro get* (sym prop &optional default)
+ (list 'get sym prop default))
+
+(define-compiler-macro getf (sym prop &optional default)
+ (list 'plist-get sym prop default))
(define-compiler-macro typep (&whole form val type)
(if (cl-const-expr-p type)
form))
-(mapcar (function
- (lambda (y)
- (put (car y) 'side-effect-free t)
- (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
- (put (car y) 'cl-compiler-macro
- (list 'lambda '(w x)
- (if (symbolp (cadr y))
- (list 'list (list 'quote (cadr y))
- (list 'list (list 'quote (caddr y)) 'x))
- (cons 'list (cdr y)))))))
- '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
- (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
- (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
- (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
- (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
- (caaar car caar) (caadr car cadr) (cadar car cdar)
- (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
- (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
- (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
- (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
- (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
- (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
- (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) ))
+(mapc
+ #'(lambda (y)
+ (put (car y) 'side-effect-free t)
+ (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro)
+ (put (car y) 'cl-compiler-macro
+ (list 'lambda '(w x)
+ (if (symbolp (cadr y))
+ (list 'list (list 'quote (cadr y))
+ (list 'list (list 'quote (caddr y)) 'x))
+ (cons 'list (cdr y))))))
+ '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
+ (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
+ (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
+ (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
+ (oddp 'eq (list 'logand x 1) 1)
+ (evenp 'eq (list 'logand x 1) 0)
+ (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
+ (caaar car caar) (caadr car cadr) (cadar car cdar)
+ (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
+ (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
+ (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
+ (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar)
+ (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr)
+ (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar)
+ (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr)))
;;; Things that are inline.
(proclaim '(inline floatp-safe acons map concatenate notany notevery
;; XEmacs change
- cl-set-elt revappend nreconc))
-
-;;; Things that are side-effect-free.
-(mapcar (function (lambda (x) (put x 'side-effect-free t)))
- '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm
- isqrt floor* ceiling* truncate* round* mod* rem* subseq
- list-length get* getf gethash hash-table-count))
-
-;;; Things that are side-effect-and-error-free.
-(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free)))
- '(eql floatp-safe list* subst acons equalp random-state-p
- copy-tree sublis hash-table-p))
+ cl-set-elt revappend nreconc
+ ))
+
+;;; Things that are side-effect-free. Moved to byte-optimize.el
+;(dolist (fun '(oddp evenp plusp minusp
+; abs expt signum last butlast ldiff
+; pairlis gcd lcm
+; isqrt floor* ceiling* truncate* round* mod* rem* subseq
+; list-length getf))
+; (put fun 'side-effect-free t))
+
+;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el
+;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p
+; copy-tree sublis))
+; (put fun 'side-effect-free 'error-free))
(run-hooks 'cl-macs-load-hook)
projects / chise / xemacs-chise.git.1 / blobdiff