Commit ca105506 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

Remove bytecomp- prefix, plus misc changes.

* lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Make it work to
inline lexbind interpreted functions into lexbind code.
(bytedecomp-bytes): Not a dynamic var any more.
(disassemble-offset): Get the bytes via an argument instead.
(byte-decompile-bytecode-1): Use push.
* lisp/emacs-lisp/bytecomp.el: Remove the bytecomp- prefix now that we use
lexical-binding.
(byte-compile-outbuffer): Rename from bytecomp-outbuffer.
* lisp/emacs-lisp/cl-macs.el (load-time-value):
* lisp/emacs-lisp/cl.el (cl-compiling-file): Adjust to new name.
* lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates):
Add byte-code-function-p.
(pcase--u1): Remove left-over code from early development.
Fix case of variable shadowing in guards and predicates.
(pcase--u1): Add a new `let' pattern.
* src/image.c (parse_image_spec): Use Ffunctionp.
* src/lisp.h: Declare Ffunctionp.
parent 2663659f
2011-03-16 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates):
Add byte-code-function-p.
(pcase--u1): Remove left-over code from early development.
Fix case of variable shadowing in guards and predicates.
(pcase--u1): Add a new `let' pattern.
* emacs-lisp/bytecomp.el: Remove the bytecomp- prefix now that we use
lexical-binding.
(byte-compile-outbuffer): Rename from bytecomp-outbuffer.
* emacs-lisp/cl-macs.el (load-time-value):
* emacs-lisp/cl.el (cl-compiling-file): Adjust to new name.
* emacs-lisp/byte-opt.el (byte-compile-inline-expand): Make it work to
inline lexbind interpreted functions into lexbind code.
(bytedecomp-bytes): Not a dynamic var any more.
(disassemble-offset): Get the bytes via an argument instead.
(byte-decompile-bytecode-1): Use push.
2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca> 2011-03-15 Stefan Monnier <monnier@iro.umontreal.ca>
* makefile.w32-in (COMPILE_FIRST): Fix up last change. * makefile.w32-in (COMPILE_FIRST): Fix up last change.
......
...@@ -265,45 +265,72 @@ ...@@ -265,45 +265,72 @@
(defun byte-compile-inline-expand (form) (defun byte-compile-inline-expand (form)
(let* ((name (car form)) (let* ((name (car form))
(fn (or (cdr (assq name byte-compile-function-environment)) (localfn (cdr (assq name byte-compile-function-environment)))
(and (fboundp name) (symbol-function name))))) (fn (or localfn (and (fboundp name) (symbol-function name)))))
(if (null fn) (when (and (consp fn) (eq (car fn) 'autoload))
(progn (load (nth 1 fn))
(byte-compile-warn "attempt to inline `%s' before it was defined" (setq fn (or (and (fboundp name) (symbol-function name))
name) (cdr (assq name byte-compile-function-environment)))))
form) (pcase fn
;; else (`nil
(when (and (consp fn) (eq (car fn) 'autoload)) (byte-compile-warn "attempt to inline `%s' before it was defined"
(load (nth 1 fn)) name)
(setq fn (or (and (fboundp name) (symbol-function name)) form)
(cdr (assq name byte-compile-function-environment))))) (`(autoload . ,_)
(if (and (consp fn) (eq (car fn) 'autoload)) (error "File `%s' didn't define `%s'" (nth 1 fn) name))
(error "File `%s' didn't define `%s'" (nth 1 fn) name)) ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
(cond (byte-compile-inline-expand (cons fn (cdr form))))
((and (symbolp fn) (not (eq fn t))) ;A function alias. ((and (pred byte-code-function-p)
(byte-compile-inline-expand (cons fn (cdr form)))) ;; FIXME: This only works to inline old-style-byte-codes into
((and (byte-code-function-p fn) ;; old-style-byte-codes.
;; FIXME: This works to inline old-style-byte-codes into (guard (not (or lexical-binding
;; old-style-byte-codes, but not mixed cases (not sure (integerp (aref fn 0))))))
;; about new-style into new-style). ;; (message "Inlining %S byte-code" name)
(not lexical-binding) (fetch-bytecode fn)
(not (integerp (aref fn 0)))) ;New lexical byte-code. (let ((string (aref fn 1)))
;; (message "Inlining %S byte-code" name) (assert (not (multibyte-string-p string)))
(fetch-bytecode fn) ;; `byte-compile-splice-in-already-compiled-code'
(let ((string (aref fn 1))) ;; takes care of inlining the body.
;; Isn't it an error for `string' not to be unibyte?? --stef (cons `(lambda ,(aref fn 0)
(if (fboundp 'string-as-unibyte) (byte-code ,string ,(aref fn 2) ,(aref fn 3)))
(setq string (string-as-unibyte string))) (cdr form))))
;; `byte-compile-splice-in-already-compiled-code' ((and `(lambda . ,_)
;; takes care of inlining the body. ;; With lexical-binding we have several problems:
(cons `(lambda ,(aref fn 0) ;; - if `fn' comes from byte-compile-function-environment, we
(byte-code ,string ,(aref fn 2) ,(aref fn 3))) ;; need to preprocess `fn', so we handle it below.
(cdr form)))) ;; - else, it means that `fn' is dyn-bound (otherwise it would
((eq (car-safe fn) 'lambda) ;; start with `closure') so copying the code here would cause
(macroexpand-all (cons fn (cdr form)) ;; it to be mis-interpreted.
byte-compile-macro-environment)) (guard (not lexical-binding)))
(t ;; Give up on inlining. (macroexpand-all (cons fn (cdr form))
form))))) byte-compile-macro-environment))
((and (or (and `(lambda ,args . ,body)
(let env nil)
(guard (eq fn localfn)))
`(closure ,env ,args . ,body))
(guard lexical-binding))
(let ((renv ()))
(dolist (binding env)
(cond
((consp binding)
;; We check shadowing by the args, so that the `let' can be
;; moved within the lambda, which can then be unfolded.
;; FIXME: Some of those bindings might be unused in `body'.
(unless (memq (car binding) args) ;Shadowed.
(push `(,(car binding) ',(cdr binding)) renv)))
((eq binding t))
(t (push `(defvar ,binding) body))))
;; (message "Inlining closure %S" (car form))
(let ((newfn (byte-compile-preprocess
`(lambda ,args (let ,(nreverse renv) ,@body)))))
(if (eq (car-safe newfn) 'function)
(byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
(byte-compile-log-warning
(format "Inlining closure %S failed" name))
form))))
(t ;; Give up on inlining.
form))))
;; ((lambda ...) ...) ;; ((lambda ...) ...)
(defun byte-compile-unfold-lambda (form &optional name) (defun byte-compile-unfold-lambda (form &optional name)
...@@ -1095,7 +1122,7 @@ ...@@ -1095,7 +1122,7 @@
(let ((fn (nth 1 form))) (let ((fn (nth 1 form)))
(if (memq (car-safe fn) '(quote function)) (if (memq (car-safe fn) '(quote function))
(cons (nth 1 fn) (cdr (cdr form))) (cons (nth 1 fn) (cdr (cdr form)))
form))) form)))
(defun byte-optimize-apply (form) (defun byte-optimize-apply (form)
;; If the last arg is a literal constant, turn this into a funcall. ;; If the last arg is a literal constant, turn this into a funcall.
...@@ -1318,43 +1345,42 @@ ...@@ -1318,43 +1345,42 @@
;; Used and set dynamically in byte-decompile-bytecode-1. ;; Used and set dynamically in byte-decompile-bytecode-1.
(defvar bytedecomp-op) (defvar bytedecomp-op)
(defvar bytedecomp-ptr) (defvar bytedecomp-ptr)
(defvar bytedecomp-bytes)
;; This function extracts the bitfields from variable-length opcodes. ;; This function extracts the bitfields from variable-length opcodes.
;; Originally defined in disass.el (which no longer uses it.) ;; Originally defined in disass.el (which no longer uses it.)
(defun disassemble-offset () (defun disassemble-offset (bytes)
"Don't call this!" "Don't call this!"
;; fetch and return the offset for the current opcode. ;; Fetch and return the offset for the current opcode.
;; return nil if this opcode has no offset ;; Return nil if this opcode has no offset.
(cond ((< bytedecomp-op byte-nth) (cond ((< bytedecomp-op byte-nth)
(let ((tem (logand bytedecomp-op 7))) (let ((tem (logand bytedecomp-op 7)))
(setq bytedecomp-op (logand bytedecomp-op 248)) (setq bytedecomp-op (logand bytedecomp-op 248))
(cond ((eq tem 6) (cond ((eq tem 6)
;; Offset in next byte. ;; Offset in next byte.
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(aref bytedecomp-bytes bytedecomp-ptr)) (aref bytes bytedecomp-ptr))
((eq tem 7) ((eq tem 7)
;; Offset in next 2 bytes. ;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytedecomp-bytes bytedecomp-ptr) (+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) (lsh (aref bytes bytedecomp-ptr) 8))))
(t tem)))) ;offset was in opcode (t tem)))) ;Offset was in opcode.
((>= bytedecomp-op byte-constant) ((>= bytedecomp-op byte-constant)
(prog1 (- bytedecomp-op byte-constant) ;offset in opcode (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
(setq bytedecomp-op byte-constant))) (setq bytedecomp-op byte-constant)))
((or (and (>= bytedecomp-op byte-constant2) ((or (and (>= bytedecomp-op byte-constant2)
(<= bytedecomp-op byte-goto-if-not-nil-else-pop)) (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
(= bytedecomp-op byte-stack-set2)) (= bytedecomp-op byte-stack-set2))
;; Offset in next 2 bytes. ;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytedecomp-bytes bytedecomp-ptr) (+ (aref bytes bytedecomp-ptr)
(progn (setq bytedecomp-ptr (1+ bytedecomp-ptr)) (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(lsh (aref bytedecomp-bytes bytedecomp-ptr) 8)))) (lsh (aref bytes bytedecomp-ptr) 8))))
((and (>= bytedecomp-op byte-listN) ((and (>= bytedecomp-op byte-listN)
(<= bytedecomp-op byte-discardN)) (<= bytedecomp-op byte-discardN))
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
(aref bytedecomp-bytes bytedecomp-ptr)))) (aref bytes bytedecomp-ptr))))
(defvar byte-compile-tag-number) (defvar byte-compile-tag-number)
...@@ -1381,24 +1407,24 @@ ...@@ -1381,24 +1407,24 @@
(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
(let ((bytedecomp-bytes bytes) (let ((bytedecomp-bytes bytes)
(length (length bytes)) (length (length bytes))
(bytedecomp-ptr 0) optr tags bytedecomp-op offset (bytedecomp-ptr 0) optr tags bytedecomp-op offset
lap tmp lap tmp
endtag) endtag)
(while (not (= bytedecomp-ptr length)) (while (not (= bytedecomp-ptr length))
(or make-spliceable (or make-spliceable
(setq lap (cons bytedecomp-ptr lap))) (push bytedecomp-ptr lap))
(setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr) (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr)
optr bytedecomp-ptr optr bytedecomp-ptr
offset (disassemble-offset)) ; this does dynamic-scope magic ;; This uses dynamic-scope magic.
offset (disassemble-offset bytedecomp-bytes))
(setq bytedecomp-op (aref byte-code-vector bytedecomp-op)) (setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
(cond ((memq bytedecomp-op byte-goto-ops) (cond ((memq bytedecomp-op byte-goto-ops)
;; it's a pc ;; It's a pc.
(setq offset (setq offset
(cdr (or (assq offset tags) (cdr (or (assq offset tags)
(car (setq tags (let ((new (cons offset (byte-compile-make-tag))))
(cons (cons offset (push new tags)
(byte-compile-make-tag)) new)))))
tags)))))))
((cond ((eq bytedecomp-op 'byte-constant2) ((cond ((eq bytedecomp-op 'byte-constant2)
(setq bytedecomp-op 'byte-constant) t) (setq bytedecomp-op 'byte-constant) t)
((memq bytedecomp-op byte-constref-ops))) ((memq bytedecomp-op byte-constref-ops)))
...@@ -1408,9 +1434,9 @@ ...@@ -1408,9 +1434,9 @@
offset (if (eq bytedecomp-op 'byte-constant) offset (if (eq bytedecomp-op 'byte-constant)
(byte-compile-get-constant tmp) (byte-compile-get-constant tmp)
(or (assq tmp byte-compile-variables) (or (assq tmp byte-compile-variables)
(car (setq byte-compile-variables (let ((new (list tmp)))
(cons (list tmp) (push new byte-compile-variables)
byte-compile-variables))))))) new)))))
((and make-spliceable ((and make-spliceable
(eq bytedecomp-op 'byte-return)) (eq bytedecomp-op 'byte-return))
(if (= bytedecomp-ptr (1- length)) (if (= bytedecomp-ptr (1- length))
...@@ -1427,26 +1453,26 @@ ...@@ -1427,26 +1453,26 @@
(setq bytedecomp-op 'byte-discardN-preserve-tos) (setq bytedecomp-op 'byte-discardN-preserve-tos)
(setq offset (- offset #x80)))) (setq offset (- offset #x80))))
;; lap = ( [ (pc . (op . arg)) ]* ) ;; lap = ( [ (pc . (op . arg)) ]* )
(setq lap (cons (cons optr (cons bytedecomp-op (or offset 0))) (push (cons optr (cons bytedecomp-op (or offset 0)))
lap)) lap)
(setq bytedecomp-ptr (1+ bytedecomp-ptr))) (setq bytedecomp-ptr (1+ bytedecomp-ptr)))
;; take off the dummy nil op that we replaced a trailing "return" with.
(let ((rest lap)) (let ((rest lap))
(while rest (while rest
(cond ((numberp (car rest))) (cond ((numberp (car rest)))
((setq tmp (assq (car (car rest)) tags)) ((setq tmp (assq (car (car rest)) tags))
;; this addr is jumped to ;; This addr is jumped to.
(setcdr rest (cons (cons nil (cdr tmp)) (setcdr rest (cons (cons nil (cdr tmp))
(cdr rest))) (cdr rest)))
(setq tags (delq tmp tags)) (setq tags (delq tmp tags))
(setq rest (cdr rest)))) (setq rest (cdr rest))))
(setq rest (cdr rest)))) (setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags)) (if tags (error "optimizer error: missed tags %s" tags))
;; Take off the dummy nil op that we replaced a trailing "return" with.
(if (null (car (cdr (car lap)))) (if (null (car (cdr (car lap))))
(setq lap (cdr lap))) (setq lap (cdr lap)))
(if endtag (if endtag
(setq lap (cons (cons nil endtag) lap))) (setq lap (cons (cons nil endtag) lap)))
;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
(mapcar (function (lambda (elt) (mapcar (function (lambda (elt)
(if (numberp elt) (if (numberp elt)
elt elt
......
This diff is collapsed.
...@@ -65,8 +65,16 @@ ...@@ -65,8 +65,16 @@
;; ;;
;;; Code: ;;; Code:
;; TODO: ;; TODO: (not just for cconv but also for the lexbind changes in general)
;; - inline lexical byte-code functions.
;; - investigate some old v18 stuff in bytecomp.el.
;; - optimize away unused cl-block-wrapper.
;; - let (e)debug find the value of lexical variables from the stack.
;; - byte-optimize-form should be applied before cconv. ;; - byte-optimize-form should be applied before cconv.
;; OTOH, the warnings emitted by cconv-analyze need to come before optimize
;; since afterwards they can because obnoxious (warnings about an "unused
;; variable" should not be emitted when the variable use has simply been
;; optimized away).
;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; - canonize code in macro-expand so we don't have to handle (let (var) body)
;; and other oddities. ;; and other oddities.
;; - new byte codes for unwind-protect, catch, and condition-case so that ;; - new byte codes for unwind-protect, catch, and condition-case so that
...@@ -213,7 +221,7 @@ Returns a form where all lambdas don't have any free variables." ...@@ -213,7 +221,7 @@ Returns a form where all lambdas don't have any free variables."
(if (assq arg new-env) (push `(,arg) new-env)) (if (assq arg new-env) (push `(,arg) new-env))
(push `(,arg . (car ,arg)) new-env) (push `(,arg . (car ,arg)) new-env)
(push `(,arg (list ,arg)) letbind))) (push `(,arg (list ,arg)) letbind)))
(setq body-new (mapcar (lambda (form) (setq body-new (mapcar (lambda (form)
(cconv-convert form new-env nil)) (cconv-convert form new-env nil))
body)) body))
...@@ -255,7 +263,7 @@ places where they originally did not directly appear." ...@@ -255,7 +263,7 @@ places where they originally did not directly appear."
(cconv--set-diff (cdr (cddr mapping)) (cconv--set-diff (cdr (cddr mapping))
extend))) extend)))
env)))) env))))
;; What's the difference between fvrs and envs? ;; What's the difference between fvrs and envs?
;; Suppose that we have the code ;; Suppose that we have the code
;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
...@@ -377,6 +385,7 @@ places where they originally did not directly appear." ...@@ -377,6 +385,7 @@ places where they originally did not directly appear."
; first element is lambda expression ; first element is lambda expression
(`(,(and `(lambda . ,_) fun) . ,args) (`(,(and `(lambda . ,_) fun) . ,args)
;; FIXME: it's silly to create a closure just to call it. ;; FIXME: it's silly to create a closure just to call it.
;; Running byte-optimize-form earlier will resolve this.
`(funcall `(funcall
,(cconv-convert `(function ,fun) env extend) ,(cconv-convert `(function ,fun) env extend)
,@(mapcar (lambda (form) ,@(mapcar (lambda (form)
...@@ -486,9 +495,9 @@ places where they originally did not directly appear." ...@@ -486,9 +495,9 @@ places where they originally did not directly appear."
`(interactive . ,(mapcar (lambda (form) `(interactive . ,(mapcar (lambda (form)
(cconv-convert form nil nil)) (cconv-convert form nil nil))
forms))) forms)))
(`(declare . ,_) form) ;The args don't contain code. (`(declare . ,_) form) ;The args don't contain code.
(`(,func . ,forms) (`(,func . ,forms)
;; First element is function or whatever function-like forms are: or, and, ;; First element is function or whatever function-like forms are: or, and,
;; if, progn, prog1, prog2, while, until ;; if, progn, prog1, prog2, while, until
...@@ -623,7 +632,7 @@ and updates the data stored in ENV." ...@@ -623,7 +632,7 @@ and updates the data stored in ENV."
(`(function (lambda ,vrs . ,body-forms)) (`(function (lambda ,vrs . ,body-forms))
(cconv--analyse-function vrs body-forms env form)) (cconv--analyse-function vrs body-forms env form))
(`(setq . ,forms) (`(setq . ,forms)
;; If a local variable (member of env) is modified by setq then ;; If a local variable (member of env) is modified by setq then
;; it is a mutated variable. ;; it is a mutated variable.
...@@ -646,8 +655,8 @@ and updates the data stored in ENV." ...@@ -646,8 +655,8 @@ and updates the data stored in ENV."
(`(condition-case ,var ,protected-form . ,handlers) (`(condition-case ,var ,protected-form . ,handlers)
;; FIXME: The bytecode for condition-case forces us to wrap the ;; FIXME: The bytecode for condition-case forces us to wrap the
;; form and handlers in closures (for handlers, it's probably ;; form and handlers in closures (for handlers, it's understandable
;; unavoidable, but not for the protected form). ;; but not for the protected form).
(cconv--analyse-function () (list protected-form) env form) (cconv--analyse-function () (list protected-form) env form)
(dolist (handler handlers) (dolist (handler handlers)
(cconv--analyse-function (if var (list var)) (cdr handler) env form))) (cconv--analyse-function (if var (list var)) (cdr handler) env form)))
...@@ -657,8 +666,8 @@ and updates the data stored in ENV." ...@@ -657,8 +666,8 @@ and updates the data stored in ENV."
(cconv-analyse-form form env) (cconv-analyse-form form env)
(cconv--analyse-function () body env form)) (cconv--analyse-function () body env form))
;; FIXME: The bytecode for save-window-excursion and the lack of ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body.
;; bytecode for track-mouse forces us to wrap the body. ;; `track-mouse' really should be made into a macro.
(`(track-mouse . ,body) (`(track-mouse . ,body)
(cconv--analyse-function () body env form)) (cconv--analyse-function () body env form))
...@@ -686,7 +695,7 @@ and updates the data stored in ENV." ...@@ -686,7 +695,7 @@ and updates the data stored in ENV."
(dolist (form forms) (cconv-analyse-form form nil))) (dolist (form forms) (cconv-analyse-form form nil)))
(`(declare . ,_) nil) ;The args don't contain code. (`(declare . ,_) nil) ;The args don't contain code.
(`(,_ . ,body-forms) ; First element is a function or whatever. (`(,_ . ,body-forms) ; First element is a function or whatever.
(dolist (form body-forms) (cconv-analyse-form form env))) (dolist (form body-forms) (cconv-analyse-form form env)))
......
...@@ -282,7 +282,7 @@ Not documented ...@@ -282,7 +282,7 @@ Not documented
;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist
;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; do* do loop return-from return block etypecase typecase ecase
;;;;;; case load-time-value eval-when destructuring-bind function* ;;;;;; case load-time-value eval-when destructuring-bind function*
;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "864a28dc0495ad87d39637a965387526") ;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "80cb83265399ce021c8c0c7d1a8562f2")
;;; Generated autoloads from cl-macs.el ;;; Generated autoloads from cl-macs.el
(autoload 'gensym "cl-macs" "\ (autoload 'gensym "cl-macs" "\
......
...@@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant." ...@@ -497,7 +497,7 @@ The result of the body appears to the compiler as a quoted constant."
(symbol-function 'byte-compile-file-form))) (symbol-function 'byte-compile-file-form)))
(list 'byte-compile-file-form (list 'quote set)) (list 'byte-compile-file-form (list 'quote set))
'(byte-compile-file-form form))) '(byte-compile-file-form form)))
(print set (symbol-value 'bytecomp-outbuffer))) (print set (symbol-value 'byte-compile-outbuffer)))
(list 'symbol-value (list 'quote temp))) (list 'symbol-value (list 'quote temp)))
(list 'quote (eval form)))) (list 'quote (eval form))))
......
...@@ -278,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation. ...@@ -278,9 +278,9 @@ definitions to shadow the loaded ones for use in file byte-compilation.
(defvar cl-compiling-file nil) (defvar cl-compiling-file nil)
(defun cl-compiling-file () (defun cl-compiling-file ()
(or cl-compiling-file (or cl-compiling-file
(and (boundp 'bytecomp-outbuffer) (and (boundp 'byte-compile-outbuffer)
(bufferp (symbol-value 'bytecomp-outbuffer)) (bufferp (symbol-value 'byte-compile-outbuffer))
(equal (buffer-name (symbol-value 'bytecomp-outbuffer)) (equal (buffer-name (symbol-value 'byte-compile-outbuffer))
" *Compiler Output*")))) " *Compiler Output*"))))
(defvar cl-proclaims-deferred nil) (defvar cl-proclaims-deferred nil)
......
...@@ -27,16 +27,21 @@ ...@@ -27,16 +27,21 @@
;; Todo: ;; Todo:
;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't
;; use x, because x is bound separately for the equality constraint
;; (as well as any pred/guard) and for the body, so uses at one place don't
;; count for the other.
;; - provide ways to extend the set of primitives, with some kind of ;; - provide ways to extend the set of primitives, with some kind of
;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
;; But better would be if we could define new ways to match by having the ;; But better would be if we could define new ways to match by having the
;; extension provide its own `pcase--split-<foo>' thingy. ;; extension provide its own `pcase--split-<foo>' thingy.
;; - along these lines, provide patterns to match CL structs.
;; - provide something like (setq VAR) so a var can be set rather than ;; - provide something like (setq VAR) so a var can be set rather than
;; let-bound. ;; let-bound.
;; - provide a way to fallthrough to other cases. ;; - provide a way to fallthrough to subsequent cases.
;; - try and be more clever to reduce the size of the decision tree, and ;; - try and be more clever to reduce the size of the decision tree, and
;; to reduce the number of leafs that need to be turned into function: ;; to reduce the number of leaves that need to be turned into function:
;; - first, do the tests shared by all remaining branches (it will have ;; - first, do the tests shared by all remaining branches (it will have
;; to be performed anyway, so better so it first so it's shared). ;; to be performed anyway, so better so it first so it's shared).
;; - then choose the test that discriminates more (?). ;; - then choose the test that discriminates more (?).
...@@ -67,6 +72,7 @@ UPatterns can take the following forms: ...@@ -67,6 +72,7 @@ UPatterns can take the following forms:
`QPAT matches if the QPattern QPAT matches. `QPAT matches if the QPattern QPAT matches.
(pred PRED) matches if PRED applied to the object returns non-nil. (pred PRED) matches if PRED applied to the object returns non-nil.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
(let UPAT EXP) matches if EXP matches UPAT.
If a SYMBOL is used twice in the same pattern (i.e. the pattern is If a SYMBOL is used twice in the same pattern (i.e. the pattern is
\"non-linear\"), then the second occurrence is turned into an `eq'uality test. \"non-linear\"), then the second occurrence is turned into an `eq'uality test.
...@@ -297,15 +303,21 @@ MATCH is the pattern that needs to be matched, of the form: ...@@ -297,15 +303,21 @@ MATCH is the pattern that needs to be matched, of the form:
(symbolp . consp) (symbolp . consp)
(symbolp . arrayp) (symbolp . arrayp)
(symbolp . stringp) (symbolp . stringp)
(symbolp . byte-code-function-p)
(integerp . consp) (integerp . consp)
(integerp . arrayp) (integerp . arrayp)
(integerp . stringp) (integerp . stringp)
(integerp . byte-code-function-p)
(numberp . consp) (numberp . consp)
(numberp . arrayp) (numberp . arrayp)
(numberp . stringp) (numberp . stringp)
(numberp . byte-code-function-p)
(consp . arrayp) (consp . arrayp)
(consp . stringp) (consp . stringp)
(arrayp . stringp))) (consp . byte-code-function-p)
(arrayp . stringp)
(arrayp . byte-code-function-p)
(stringp . byte-code-function-p)))
(defun pcase--split-match (sym splitter match)