X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fcl-macs.el;h=fc2c48a72401c996ac46240c22be52e2ff66d4fa;hb=89dd1955617972a104d64b0343cf81a54331656b;hp=db305754ae630ca7af2c065454527dc09d046603;hpb=f3ec20f455f3f1212d2c5ee4cadc984330da9c38;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/cl-macs.el b/lisp/cl-macs.el index db30575..fc2c48a 100644 --- a/lisp/cl-macs.el +++ b/lisp/cl-macs.el @@ -81,7 +81,7 @@ #'(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)))))) + 'xemacs)) ;;; Initialization. @@ -106,31 +106,6 @@ (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 @@ -174,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))) @@ -1438,10 +1465,10 @@ values. For compatibility, (values A B C) is a synonym for (list A B C)." (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)) @@ -1459,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) @@ -1647,12 +1676,12 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." (defsetf extent-priority set-extent-priority) (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)) @@ -1794,6 +1823,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." (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 @@ -2458,24 +2488,32 @@ The type name can then be used in `typecase', `check-type', etc." (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) @@ -2744,10 +2782,11 @@ surrounded by (block NAME ...)." (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) @@ -2773,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) @@ -2787,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 @@ -2795,7 +2835,7 @@ surrounded by (block NAME ...)." ; abs expt signum last butlast ldiff ; pairlis gcd lcm ; isqrt floor* ceiling* truncate* round* mod* rem* subseq -; list-length get* getf)) +; list-length getf)) ; (put fun 'side-effect-free t)) ;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el