#'(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.
(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
;;;###autoload
(defmacro return-from (name &optional res)
"(return-from NAME [RESULT]): return from the block named NAME.
-This jump out to the innermost enclosing `(block NAME ...)' form,
+This jumps out to the innermost enclosing `(block NAME ...)' form,
returning RESULT from that form (or nil if RESULT is omitted).
This is compatible with Common Lisp, but note that `defun' and
`defmacro' do not create implicit blocks as they do in Common Lisp."
(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))
((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)
(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))
(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
(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)
(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)
(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)
(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
; 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