(if (wisent-automaton-p grammar)
grammar ;; Grammar already compiled just return it
(wisent-with-context compile-grammar
- (let* ((gc-cons-threshold 1000000)
- automaton)
+ (let* ((gc-cons-threshold 1000000))
(garbage-collect)
(setq wisent-new-log-flag t)
;; Parse input grammar
(wisent-parse-grammar grammar start-list)
;; Generate the LALR(1) automaton
- (setq automaton (wisent-parser-automaton))
- automaton))))
+ (wisent-parser-automaton)))))
\f
;;;; --------------------------
;;;; Byte compile input grammar
;; automaton internal data structure. Then, because the internal
;; data structure contains an obarray, convert it to a lisp form so
;; it can be byte-compiled.
- (byte-compile-form (wisent-automaton-lisp-form (eval form))))
+ (byte-compile-form
+ ;; FIXME: we macroexpand here since `byte-compile-form' expects
+ ;; macroexpanded code, but that's just a workaround: for lexical-binding
+ ;; the lisp form should have to pass through closure-conversion and
+ ;; `wisent-byte-compile-grammar' is called much too late for that.
+ ;; Why isn't this `wisent-automaton-lisp-form' performed at
+ ;; macroexpansion time? --Stef
+ (macroexpand-all
+ (wisent-automaton-lisp-form (eval form)))))
(put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar)
"Output byte codes to store the top-of-stack value at position STACK-POS in the stack."
(byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos))))
+(byte-defop-compiler-1 internal-make-closure byte-compile-make-closure)
+(byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var)
+
+(defconst byte-compile--env-var (make-symbol "env"))
+
+(defun byte-compile-make-closure (form)
+ ;; FIXME: don't use `curry'!
+ (byte-compile-form
+ (unless for-effect
+ `(curry (function (lambda (,byte-compile--env-var . ,(nth 1 form))
+ . ,(nthcdr 3 form)))
+ (vector . ,(nth 2 form))))
+ for-effect))
+
+(defun byte-compile-get-closed-var (form)
+ (byte-compile-form (unless for-effect
+ `(aref ,byte-compile--env-var ,(nth 1 form)))
+ for-effect))
;; Compile a function that accepts one or more args and is right-associative.
;; We do it by left-associativity so that the operations
;;; Code:
;;; TODO:
+;; - canonize code in macro-expand so we don't have to handle (let (var) body)
+;; and other oddities.
;; - Change new byte-code representation, so it directly gives the
;; number of mandatory and optional arguments as well as whether or
;; not there's a &rest arg.
res))
(defconst cconv--dummy-var (make-symbol "ignored"))
-(defconst cconv--env-var (make-symbol "env"))
(defun cconv--set-diff (s1 s2)
"Return elements of set S1 that are not in set S2."
(envector nil))
(when fv
;; Here we form our environment vector.
- ;; If outer closure contains all
- ;; free variables of this function(and nothing else)
- ;; then we use the same environment vector as for outer closure,
- ;; i.e. we leave the environment vector unchanged,
- ;; otherwise we build a new environment vector.
- (if (eq (length envs) (length fv))
- (let ((fv-temp fv))
- (while (and fv-temp leave)
- (when (not (memq (car fv-temp) fvrs-new)) (setq leave nil))
- (setq fv-temp (cdr fv-temp))))
- (setq leave nil))
-
- (if (not leave)
- (progn
- (dolist (elm fv)
- (push
- (cconv-closure-convert-rec
- ;; Remove `elm' from `emvrs' for this call because in case
- ;; `elm' is a variable that's wrapped in a cons-cell, we
- ;; want to put the cons-cell itself in the closure, rather
- ;; than just a copy of its current content.
- elm (remq elm emvrs) fvrs envs lmenvs)
- envector)) ; Process vars for closure vector.
- (setq envector (reverse envector))
- (setq envs fv))
- (setq envector `(,cconv--env-var))) ; Leave unchanged.
+
+ (dolist (elm fv)
+ (push
+ (cconv-closure-convert-rec
+ ;; Remove `elm' from `emvrs' for this call because in case
+ ;; `elm' is a variable that's wrapped in a cons-cell, we
+ ;; want to put the cons-cell itself in the closure, rather
+ ;; than just a copy of its current content.
+ elm (remq elm emvrs) fvrs envs lmenvs)
+ envector)) ; Process vars for closure vector.
+ (setq envector (reverse envector))
+ (setq envs fv)
(setq fvrs-new fv)) ; Update substitution list.
(setq emvrs (cconv--set-diff emvrs vars))
((null envector)
`(function (lambda ,vars . ,body-forms-new)))
; 1 free variable - do not build vector
- ((null (cdr envector))
- `(curry
- (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new))
- ,(car envector)))
- ; >=2 free variables - build vector
(t
- `(curry
- (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new))
- (vector . ,envector))))))
+ `(internal-make-closure
+ ,vars ,envector . ,body-forms-new)))))
(`(function . ,_) form) ; Same as quote.
(let ((free (memq form fvrs)))
(if free ;form is a free variable
(let* ((numero (- (length fvrs) (length free)))
- (var (if (null (cdr envs))
- cconv--env-var
- ;; Replace form => (aref env #)
- `(aref ,cconv--env-var ,numero))))
+ ;; Replace form => (aref env #)
+ (var `(internal-get-closed-var ,numero)))
(if (memq form emvrs) ; form => (car (aref env #)) if mutable
`(car ,var)
var))
projects / emacs.git / commitdiff