Mercurial > hg > xemacs-beta

comparison lisp/cl-macs.el @ 446:1ccc32a20af4 r21-2-38

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-38
author cvs
date Mon, 13 Aug 2007 11:37:21 +0200
parents 576fb035e263
children 3d3049ae1304
comparison
equal deleted inserted replaced
445:34f3776fcf0e 446:1ccc32a20af4
1432 'byte-compile-inline-expand) 1432 'byte-compile-inline-expand)
1433 (put (car spec) 'byte-optimizer nil)))) 1433 (put (car spec) 'byte-optimizer nil))))
1434 1434
1435 ((eq (car-safe spec) 'optimize) 1435 ((eq (car-safe spec) 'optimize)
1436 (let ((speed (assq (nth 1 (assq 'speed (cdr spec))) 1436 (let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
1437 '((0 nil) (1 t) (2 t) (3 t)))) 1437 '((0 . nil) (1 . t) (2 . t) (3 . t))))
1438 (safety (assq (nth 1 (assq 'safety (cdr spec))) 1438 (safety (assq (nth 1 (assq 'safety (cdr spec)))
1439 '((0 t) (1 t) (2 t) (3 nil))))) 1439 '((0 . t) (1 . t) (2 . t) (3 . nil)))))
1440 (if speed (setq cl-optimize-speed (car speed) 1440 (when speed
1441 byte-optimize (nth 1 speed))) 1441 (setq cl-optimize-speed (car speed)
1442 (if safety (setq cl-optimize-safety (car safety) 1442 byte-optimize (cdr speed)))
1443 byte-compile-delete-errors (nth 1 safety))))) 1443 (when safety
1444 (setq cl-optimize-safety (car safety)
1445 byte-compile-delete-errors (cdr safety)))))
1444 1446
1445 ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) 1447 ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings))
1446 (if (eq byte-compile-warnings t) 1448 (if (eq byte-compile-warnings t)
1447 ;; XEmacs change 1449 ;; XEmacs change
1448 (setq byte-compile-warnings byte-compile-default-warnings)) 1450 (setq byte-compile-warnings byte-compile-default-warnings))
2438 "Check that OBJECT is of type TYPE. 2440 "Check that OBJECT is of type TYPE.
2439 TYPE is a Common Lisp-style type specifier." 2441 TYPE is a Common Lisp-style type specifier."
2440 (eval (cl-make-type-test 'object type))) 2442 (eval (cl-make-type-test 'object type)))
2441 2443
2442 ;;;###autoload 2444 ;;;###autoload
2443 (defmacro check-type (form type &optional string) 2445 (defmacro check-type (place type &optional string)
2444 "Verify that FORM is of type TYPE; signal an error if not. 2446 "Verify that PLACE is of type TYPE; signal a continuable error if not.
2445 STRING is an optional description of the desired type." 2447 STRING is an optional description of the desired type."
2446 (and (or (not (cl-compiling-file)) 2448 (when (or (not (cl-compiling-file))
2447 (< cl-optimize-speed 3) (= cl-optimize-safety 3)) 2449 (< cl-optimize-speed 3)
2448 (let* ((temp (if (cl-simple-expr-p form 3) form (gensym))) 2450 (= cl-optimize-safety 3))
2449 (body (list 'or (cl-make-type-test temp type) 2451 (let* ((temp (if (cl-simple-expr-p place 3) place (gensym)))
2450 (list 'signal '(quote wrong-type-argument) 2452 (test (cl-make-type-test temp type))
2451 (list 'list (or string (list 'quote type)) 2453 (signal-error `(signal 'wrong-type-argument
2452 temp (list 'quote form)))))) 2454 ,(list 'list (or string (list 'quote type))
2453 (if (eq temp form) (list 'progn body nil) 2455 temp (list 'quote place))))
2454 (list 'let (list (list temp form)) body nil))))) 2456 (body
2457 (condition-case nil
2458 `(while (not ,test)
2459 ,(macroexpand `(setf ,place ,signal-error)))
2460 (error
2461 `(if ,test (progn ,signal-error nil))))))
2462 (if (eq temp place)
2463 body
2464 `(let ((,temp ,place)) ,body)))))
2455 2465
2456 ;;;###autoload 2466 ;;;###autoload
2457 (defmacro assert (form &optional show-args string &rest args) 2467 (defmacro assert (form &optional show-args string &rest args)
2458 "Verify that FORM returns non-nil; signal an error if not. 2468 "Verify that FORM returns non-nil; signal an error if not.
2459 Second arg SHOW-ARGS means to include arguments of FORM in message. 2469 Second arg SHOW-ARGS means to include arguments of FORM in message.
2748 (cons 'list (cdr y)))))) 2758 (cons 'list (cdr y))))))
2749 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) 2759 '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x)
2750 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) 2760 (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x)
2751 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) 2761 (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x)
2752 (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) 2762 (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0)
2763 (oddp 'eq (list 'logand x 1) 1)
2764 (evenp 'eq (list 'logand x 1) 0)
2753 (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) 2765 (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr)
2754 (caaar car caar) (caadr car cadr) (cadar car cdar) 2766 (caaar car caar) (caadr car cadr) (cadar car cdar)
2755 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) 2767 (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr)
2756 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) 2768 (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar)
2757 (caaadr car caadr) (caadar car cadar) (caaddr car caddr) 2769 (caaadr car caadr) (caadar car cadar) (caaddr car caddr)
2762 2774
2763 ;;; Things that are inline. 2775 ;;; Things that are inline.
2764 (proclaim '(inline floatp-safe acons map concatenate notany notevery 2776 (proclaim '(inline floatp-safe acons map concatenate notany notevery
2765 ;; XEmacs change 2777 ;; XEmacs change
2766 cl-set-elt revappend nreconc 2778 cl-set-elt revappend nreconc
2767 plusp minusp oddp evenp
2768 )) 2779 ))
2769 2780
2770 ;;; Things that are side-effect-free. Moved to byte-optimize.el 2781 ;;; Things that are side-effect-free. Moved to byte-optimize.el
2771 ;(dolist (fun '(oddp evenp plusp minusp 2782 ;(dolist (fun '(oddp evenp plusp minusp
2772 ; abs expt signum last butlast ldiff 2783 ; abs expt signum last butlast ldiff