X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Fcl-macs.el;h=fc2c48a72401c996ac46240c22be52e2ff66d4fa;hp=6eddb949eac5ca4006cd5b779bf64fae29037bbf;hb=b0360c4503dfc01c7b7e75e6170c32aa7d267291;hpb=98a6e4055a1fa624c592ac06f79287d55196ca37 diff --git a/lisp/cl-macs.el b/lisp/cl-macs.el index 6eddb94..fc2c48a 100644 --- a/lisp/cl-macs.el +++ b/lisp/cl-macs.el @@ -149,12 +149,64 @@ ARGLIST allows full Common Lisp conventions." (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))) @@ -1434,13 +1486,15 @@ values. For compatibility, (values A B C) is a synonym for (list A B C)." ((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) @@ -2440,18 +2494,26 @@ TYPE is a Common Lisp-style type specifier." (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) @@ -2750,6 +2812,8 @@ surrounded by (block NAME ...)." (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) @@ -2764,7 +2828,6 @@ surrounded by (block NAME ...)." (proclaim '(inline floatp-safe acons map concatenate notany notevery ;; XEmacs change cl-set-elt revappend nreconc - plusp minusp oddp evenp )) ;;; Things that are side-effect-free. Moved to byte-optimize.el