;;; cl-macs.el --- Common Lisp macros
-;; Copyright (C) 1993, 2001-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2001-2012 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 2.02
(declare-function help-add-fundoc-usage "help-fns" (docstring arglist))
+(defun cl--make-usage-var (x)
+ "X can be a var or a (destructuring) lambda-list."
+ (cond
+ ((symbolp x) (make-symbol (upcase (symbol-name x))))
+ ((consp x) (cl--make-usage-args x))
+ (t x)))
+
+(defun cl--make-usage-args (arglist)
+ ;; `orig-args' can contain &cl-defs (an internal
+ ;; CL thingy I don't understand), so remove it.
+ (let ((x (memq '&cl-defs arglist)))
+ (when x (setq arglist (delq (car x) (remq (cadr x) arglist)))))
+ (let ((state nil))
+ (mapcar (lambda (x)
+ (cond
+ ((symbolp x)
+ (if (eq ?\& (aref (symbol-name x) 0))
+ (setq state x)
+ (make-symbol (upcase (symbol-name x)))))
+ ((not (consp x)) x)
+ ((memq state '(nil &rest)) (cl--make-usage-args x))
+ (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR).
+ (list*
+ (if (and (consp (car x)) (eq state '&key))
+ (list (caar x) (cl--make-usage-var (nth 1 (car x))))
+ (cl--make-usage-var (car x)))
+ (nth 1 x) ;INITFORM.
+ (cl--make-usage-args (nthcdr 2 x)) ;SVAR.
+ ))))
+ arglist)))
+
(defun cl-transform-lambda (form bind-block)
(let* ((args (car form)) (body (cdr form)) (orig-args args)
(bind-defs nil) (bind-enquote nil)
(require 'help-fns)
(cons (help-add-fundoc-usage
(if (stringp (car hdr)) (pop hdr))
- ;; orig-args can contain &cl-defs (an internal
- ;; CL thingy I don't understand), so remove it.
- (let ((x (memq '&cl-defs orig-args)))
- (if (null x) orig-args
- (delq (car x) (remq (cadr x) orig-args)))))
+ (format "(fn %S)"
+ (cl--make-usage-args orig-args)))
hdr)))
(list (nconc (list 'let* bind-lets)
(nreverse bind-forms) body)))))))
(symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form)))
- (print set (symbol-value 'bytecomp-outbuffer)))
+ (print set (symbol-value 'byte-compile--outbuffer)))
(list 'symbol-value (list 'quote temp)))
(list 'quote (eval form))))
(list* 'catch (list 'quote (intern (format "--cl-block-%s--" name)))
body))))
-(defvar cl-active-block-names nil)
-
-(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block)
-(defun cl-byte-compile-block (cl-form)
- ;; Here we try to determine if a catch tag is used or not, so as to get rid
- ;; of the catch when it's not used.
- (if (and (fboundp 'byte-compile-form-do-effect) ; Optimizing compiler?
- ;; FIXME: byte-compile-top-level can only be used for code that is
- ;; closed (as the name implies), so for lexical scoping we should
- ;; implement this optimization differently.
- (not lexical-binding))
- (progn
- (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil))
- (cl-active-block-names (cons cl-entry cl-active-block-names))
- (cl-body (byte-compile-top-level
- (cons 'progn (cddr (nth 1 cl-form))))))
- (if (cdr cl-entry)
- (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body))
- (byte-compile-form cl-body))))
- (byte-compile-form (nth 1 cl-form))))
-
-(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw)
-(defun cl-byte-compile-throw (cl-form)
- (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names)))
- (if cl-found (setcdr cl-found t)))
- (byte-compile-normal-call (cons 'throw (cdr cl-form))))
-
;;;###autoload
(defmacro return (&optional result)
"Return from the block named nil.
"Loop over a list.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
Then evaluate RESULT to get return value, default nil.
+An implicit nil block is established around the loop.
\(fn (VAR LIST [RESULT]) BODY...)"
(let ((temp (make-symbol "--cl-dolist-temp--")))
- (list 'block nil
- (list* 'let (list (list temp (nth 1 spec)) (car spec))
- (list* 'while temp (list 'setq (car spec) (list 'car temp))
- (append body (list (list 'setq temp
- (list 'cdr temp)))))
- (if (cdr (cdr spec))
- (cons (list 'setq (car spec) nil) (cdr (cdr spec)))
- '(nil))))))
+ ;; FIXME: Copy&pasted from subr.el.
+ `(block nil
+ ;; This is not a reliable test, but it does not matter because both
+ ;; semantics are acceptable, tho one is slightly faster with dynamic
+ ;; scoping and the other is slightly faster (and has cleaner semantics)
+ ;; with lexical scoping.
+ ,(if lexical-binding
+ `(let ((,temp ,(nth 1 spec)))
+ (while ,temp
+ (let ((,(car spec) (car ,temp)))
+ ,@body
+ (setq ,temp (cdr ,temp))))
+ ,@(if (cdr (cdr spec))
+ ;; FIXME: This let often leads to "unused var" warnings.
+ `((let ((,(car spec) nil)) ,@(cdr (cdr spec))))))
+ `(let ((,temp ,(nth 1 spec))
+ ,(car spec))
+ (while ,temp
+ (setq ,(car spec) (car ,temp))
+ ,@body
+ (setq ,temp (cdr ,temp)))
+ ,@(if (cdr (cdr spec))
+ `((setq ,(car spec) nil) ,@(cddr spec))))))))
;;;###autoload
(defmacro dotimes (spec &rest body)
nil.
\(fn (VAR COUNT [RESULT]) BODY...)"
- (let ((temp (make-symbol "--cl-dotimes-temp--")))
- (list 'block nil
- (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
- (list* 'while (list '< (car spec) temp)
- (append body (list (list 'incf (car spec)))))
- (or (cdr (cdr spec)) '(nil))))))
+ (let ((temp (make-symbol "--cl-dotimes-temp--"))
+ (end (nth 1 spec)))
+ ;; FIXME: Copy&pasted from subr.el.
+ `(block nil
+ ;; This is not a reliable test, but it does not matter because both
+ ;; semantics are acceptable, tho one is slightly faster with dynamic
+ ;; scoping and the other has cleaner semantics.
+ ,(if lexical-binding
+ (let ((counter '--dotimes-counter--))
+ `(let ((,temp ,end)
+ (,counter 0))
+ (while (< ,counter ,temp)
+ (let ((,(car spec) ,counter))
+ ,@body)
+ (setq ,counter (1+ ,counter)))
+ ,@(if (cddr spec)
+ ;; FIXME: This let often leads to "unused var" warnings.
+ `((let ((,(car spec) ,counter)) ,@(cddr spec))))))
+ `(let ((,temp ,end)
+ (,(car spec) 0))
+ (while (< ,(car spec) ,temp)
+ ,@body
+ (incf ,(car spec)))
+ ,@(cdr (cdr spec)))))))
;;;###autoload
(defmacro do-symbols (spec &rest body)
"Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
lexical closures as in Common Lisp.
-\n(fn VARLIST BODY)"
+\n(fn BINDINGS BODY)"
(let* ((cl-closure-vars cl-closure-vars)
(vars (mapcar (function
(lambda (x)
(defmacro lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY, and in
-successive bindings within VARLIST, will create lexical closures
+successive bindings within BINDINGS, will create lexical closures
as in Common Lisp. This is similar to the behavior of `let*' in
Common Lisp.
-\n(fn VARLIST BODY)"
+\n(fn BINDINGS BODY)"
(if (null bindings) (cons 'progn body)
(setq bindings (reverse bindings))
(while bindings
;;;###autoload
(defmacro declare (&rest specs)
+ "Declare SPECS about the current function while compiling.
+For instance
+
+ \(declare (warn 0))
+
+will turn off byte-compile warnings in the function.
+See Info node `(cl)Declarations' for details."
(if (cl-compiling-file)
(while specs
(if (listp cl-declare-stack) (push (car specs) cl-declare-stack))
(append
(and pred-check
(list (list 'or pred-check
- (list 'error
- (format "%s accessing a non-%s"
- accessor name)))))
+ `(error "%s accessing a non-%s"
+ ',accessor ',name))))
(list (if (eq type 'vector) (list 'aref 'cl-x pos)
(if (= pos 0) '(car cl-x)
(list 'nth pos 'cl-x)))))) forms)
(push (cons accessor t) side-eff)
(push (list 'define-setf-method accessor '(cl-x)
(if (cadr (memq :read-only (cddr desc)))
- (list 'error (format "%s is a read-only slot"
- accessor))
+ (list 'progn '(ignore cl-x)
+ `(error "%s is a read-only slot"
+ ',accessor))
;; If cl is loaded only for compilation,
;; the call to cl-struct-setf-expander would
;; cause a warning because it may not be
(byte-compile-normal-call form)
(byte-compile-form form)))
+;; Optimize away unused block-wrappers.
+
+(defvar cl-active-block-names nil)
+
+(define-compiler-macro cl-block-wrapper (cl-form)
+ (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
+ (cl-active-block-names (cons cl-entry cl-active-block-names))
+ (cl-body (macroexpand-all ;Performs compiler-macro expansions.
+ (cons 'progn (cddr cl-form))
+ macroexpand-all-environment)))
+ ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
+ ;; to indicate that this return value is already fully expanded.
+ (if (cdr cl-entry)
+ `(catch ,(nth 1 cl-form) ,@(cdr cl-body))
+ cl-body)))
+
+(define-compiler-macro cl-block-throw (cl-tag cl-value)
+ (let ((cl-found (assq (nth 1 cl-tag) cl-active-block-names)))
+ (if cl-found (setcdr cl-found t)))
+ `(throw ,cl-tag ,cl-value))
+
;;;###autoload
(defmacro defsubst* (name args &rest body)
"Define NAME as a function.