+;; Add any new entries to info node `(elisp)Declare Form'.
+(eval-and-compile
+ (defvar defun-declarations-alist
+ (list
+ ;; We can only use backquotes inside the lambdas and not for those
+ ;; properties that are used by functions loaded before backquote.el.
+ (list 'advertised-calling-convention
+ #'(lambda (f _args arglist when)
+ (list 'set-advertised-calling-convention
+ (list 'quote f) (list 'quote arglist) (list 'quote when))))
+ (list 'obsolete
+ #'(lambda (f _args new-name when)
+ (list 'make-obsolete
+ (list 'quote f) (list 'quote new-name) (list 'quote when))))
+ (list 'interactive-only
+ #'(lambda (f _args instead)
+ (list 'function-put (list 'quote f)
+ ''interactive-only (list 'quote instead))))
+ ;; FIXME: Merge `pure' and `side-effect-free'.
+ (list 'pure
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''pure (list 'quote val)))
+ "If non-nil, the compiler can replace calls with their return value.
+This may shift errors from run-time to compile-time.")
+ (list 'side-effect-free
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''side-effect-free (list 'quote val)))
+ "If non-nil, calls can be ignored if their value is unused.
+If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
+ (list 'compiler-macro
+ #'(lambda (f args compiler-function)
+ `(eval-and-compile
+ (function-put ',f 'compiler-macro
+ ,(if (eq (car-safe compiler-function) 'lambda)
+ `(lambda ,(append (cadr compiler-function) args)
+ ,@(cddr compiler-function))
+ `#',compiler-function)))))
+ (list 'doc-string
+ #'(lambda (f _args pos)
+ (list 'function-put (list 'quote f)
+ ''doc-string-elt (list 'quote pos))))
+ (list 'indent
+ #'(lambda (f _args val)
+ (list 'function-put (list 'quote f)
+ ''lisp-indent-function (list 'quote val)))))
+ "List associating function properties to their macro expansion.
+Each element of the list takes the form (PROP FUN) where FUN is
+a function. For each (PROP . VALUES) in a function's declaration,
+the FUN corresponding to PROP is called with the function name,
+the function's arglist, and the VALUES and should return the code to use
+to set this property.
+
+This is used by `declare'.")
+
+ (defvar macro-declarations-alist
+ (cons
+ (list 'debug
+ #'(lambda (name _args spec)
+ (list 'progn :autoload-end
+ (list 'put (list 'quote name)
+ ''edebug-form-spec (list 'quote spec)))))
+ defun-declarations-alist)
+ "List associating properties of macros to their macro expansion.
+Each element of the list takes the form (PROP FUN) where FUN is a function.
+For each (PROP . VALUES) in a macro's declaration, the FUN corresponding
+to PROP is called with the macro name, the macro's arglist, and the VALUES
+and should return the code to use to set this property.
+
+This is used by `declare'."))
+
+(defalias 'defmacro
+ (cons
+ 'macro
+ #'(lambda (name arglist &optional docstring &rest body)
+ "Define NAME as a macro.
+When the macro is called, as in (NAME ARGS...),
+the function (lambda ARGLIST BODY...) is applied to
+the list ARGS... as it appears in the expression,
+and the result should be a form to be evaluated instead of the original.
+DECL is a declaration, optional, of the form (declare DECLS...) where
+DECLS is a list of elements of the form (PROP . VALUES). These are
+interpreted according to `macro-declarations-alist'.
+The return value is undefined.
+
+\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
+ ;; We can't just have `decl' as an &optional argument, because we need
+ ;; to distinguish
+ ;; (defmacro foo (arg) (bar) nil)
+ ;; from
+ ;; (defmacro foo (arg) (bar)).
+ (let ((decls (cond
+ ((eq (car-safe docstring) 'declare)
+ (prog1 (cdr docstring) (setq docstring nil)))
+ ((and (stringp docstring)
+ (eq (car-safe (car body)) 'declare))
+ (prog1 (cdr (car body)) (setq body (cdr body)))))))
+ (if docstring (setq body (cons docstring body))
+ (if (null body) (setq body '(nil))))
+ ;; Can't use backquote because it's not defined yet!
+ (let* ((fun (list 'function (cons 'lambda (cons arglist body))))
+ (def (list 'defalias
+ (list 'quote name)
+ (list 'cons ''macro fun)))
+ (declarations
+ (mapcar
+ #'(lambda (x)
+ (let ((f (cdr (assq (car x) macro-declarations-alist))))
+ (if f (apply (car f) name arglist (cdr x))
+ (message "Warning: Unknown macro property %S in %S"
+ (car x) name))))
+ decls)))
+ (if declarations
+ (cons 'prog1 (cons def declarations))
+ def))))))
+
+;; Now that we defined defmacro we can use it!
+(defmacro defun (name arglist &optional docstring &rest body)
+ "Define NAME as a function.
+The definition is (lambda ARGLIST [DOCSTRING] BODY...).
+See also the function `interactive'.
+DECL is a declaration, optional, of the form (declare DECLS...) where
+DECLS is a list of elements of the form (PROP . VALUES). These are
+interpreted according to `defun-declarations-alist'.
+The return value is undefined.
+
+\(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)"
+ ;; We can't just have `decl' as an &optional argument, because we need
+ ;; to distinguish
+ ;; (defun foo (arg) (toto) nil)
+ ;; from
+ ;; (defun foo (arg) (toto)).
+ (declare (doc-string 3) (indent 2))
+ (let ((decls (cond
+ ((eq (car-safe docstring) 'declare)
+ (prog1 (cdr docstring) (setq docstring nil)))
+ ((and (stringp docstring)
+ (eq (car-safe (car body)) 'declare))
+ (prog1 (cdr (car body)) (setq body (cdr body)))))))
+ (if docstring (setq body (cons docstring body))
+ (if (null body) (setq body '(nil))))
+ (let ((declarations
+ (mapcar
+ #'(lambda (x)
+ (let ((f (cdr (assq (car x) defun-declarations-alist))))
+ (cond
+ (f (apply (car f) name arglist (cdr x)))
+ ;; Yuck!!
+ ((and (featurep 'cl)
+ (memq (car x) ;C.f. cl-do-proclaim.
+ '(special inline notinline optimize warn)))
+ (setq body (cons (list 'declare x) body))
+ nil)
+ (t (message "Warning: Unknown defun property `%S' in %S"
+ (car x) name)))))
+ decls))
+ (def (list 'defalias
+ (list 'quote name)
+ (list 'function
+ (cons 'lambda
+ (cons arglist body))))))
+ (list 'prog1
+ (if declarations
+ (cons 'prog1 (cons def declarations))
+ def)
+ (list 'funcall
+ (list '@ '(guile) 'set-procedure-property!)
+ (list 'symbol-function (list 'quote name))
+ (list 'quote 'name)
+ (list 'quote name))))))
HCoop / bpt / emacs.git / blobdiff