From 0375891c22a651bc822c4f64d3b865d6510bc3ad Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Fri, 5 Jul 2013 18:47:27 +0200 Subject: [PATCH] Store intermediate variables as symbols instead of strings --- src/compiler.lisp | 73 ++++++++++++++++++++++++++--------------------------- 1 file changed, 36 insertions(+), 37 deletions(-) diff --git a/src/compiler.lisp b/src/compiler.lisp index 2c8269c..7f63074 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -94,7 +94,7 @@ (defun gvarname (symbol) (declare (ignore symbol)) (incf *variable-counter*) - (concat "v" (integer-to-string *variable-counter*))) + (make-symbol (concat "v" (integer-to-string *variable-counter*)))) (defun translate-variable (symbol) (awhen (lookup-in-lexenv symbol *environment* 'variable) @@ -257,10 +257,10 @@ (dotimes (idx n-optional-arguments) (let ((arg (nth idx optional-arguments))) (collect `(case ,(+ idx n-required-arguments))) - (collect `(= ,(make-symbol (translate-variable (car arg))) + (collect `(= ,(translate-variable (car arg)) ,(convert (cadr arg)))) (collect (when (third arg) - `(= ,(make-symbol (translate-variable (third arg))) + `(= ,(translate-variable (third arg)) ,(convert nil)))))) (collect 'default) (collect '(break))))))) @@ -270,7 +270,7 @@ (n-optional-arguments (length (ll-optional-arguments ll))) (rest-argument (ll-rest-argument ll))) (when rest-argument - (let ((js!rest (make-symbol (translate-variable rest-argument)))) + (let ((js!rest (translate-variable rest-argument))) `(progn (var (,js!rest ,(convert nil))) (var i) @@ -294,10 +294,10 @@ (destructuring-bind ((keyword-name var) &optional initform svar) keyword-argument (declare (ignore keyword-name initform)) - (collect `(var ,(make-symbol (translate-variable var)))) + (collect `(var ,(translate-variable var))) (when svar (collect - `(var (,(make-symbol (translate-variable svar)) + `(var (,(translate-variable svar) ,(convert nil)))))))) ;; Parse keywords @@ -312,14 +312,13 @@ (if (=== (property |arguments| (+ i 2)) ,(convert keyword-name)) (progn - (= ,(make-symbol (translate-variable var)) + (= ,(translate-variable var) (property |arguments| (+ i 3))) - ,(when svar `(= ,(make-symbol (translate-variable svar)) + ,(when svar `(= ,(translate-variable svar) ,(convert t))) (break)))) (if (== i |nargs|) - (= ,(make-symbol (translate-variable var)) - ,(convert initform))))))) + (= ,(translate-variable var) ,(convert initform))))))) (when keyword-arguments `(progn (var i) @@ -395,7 +394,7 @@ (ll-svars ll))))) (lambda-name/docstring-wrapper name documentation `(function (|values| |nargs| ,@(mapcar (lambda (x) - (make-symbol (translate-variable x))) + (translate-variable x)) (append required-arguments optional-arguments))) ;; Check number of arguments ,(lambda-check-argument-count n-required-arguments @@ -420,7 +419,7 @@ (not (member 'constant (binding-declarations b)))) ;; TODO: Unnecesary make-symbol when codegen migration is ;; finished. - `(= ,(make-symbol (binding-value b)) ,(convert val))) + `(= ,(binding-value b) ,(convert val))) ((and b (eq (binding-type b) 'macro)) (convert `(setf ,var ,val))) (t @@ -470,7 +469,7 @@ (defun genlit () (incf *literal-counter*) - (concat "l" (integer-to-string *literal-counter*))) + (make-symbol (concat "l" (integer-to-string *literal-counter*)))) (defun dump-symbol (symbol) #-jscl @@ -523,11 +522,11 @@ (if (and recursive (not (symbolp sexp))) dumped (let ((jsvar (genlit))) - (push (cons sexp (make-symbol jsvar)) *literal-table*) - (toplevel-compilation `(var (,(make-symbol jsvar) ,dumped))) + (push (cons sexp jsvar) *literal-table*) + (toplevel-compilation `(var (,jsvar ,dumped))) (when (keywordp sexp) - (toplevel-compilation `(= ,(get (make-symbol jsvar) "value") ,(make-symbol jsvar)))) - (make-symbol jsvar)))))))) + (toplevel-compilation `(= ,(get jsvar "value") ,jsvar))) + jsvar))))))) (define-compilation quote (sexp) @@ -554,7 +553,7 @@ ((symbolp x) (let ((b (lookup-in-lexenv x *environment* 'function))) (if b - (make-symbol (binding-value b)) + (binding-value b) (convert `(symbol-function ',x))))))) (defun make-function-binding (fname) @@ -578,7 +577,7 @@ (extend-lexenv (mapcar #'make-function-binding fnames) *environment* 'function))) - `(call (function ,(mapcar #'make-symbol (mapcar #'translate-function fnames)) + `(call (function ,(mapcar #'translate-function fnames) ,(convert-block body t)) ,@cfuncs))) @@ -590,7 +589,7 @@ 'function))) `(selfcall ,@(mapcar (lambda (func) - `(var (,(make-symbol (translate-function (car func))) + `(var (,(translate-function (car func)) ,(compile-lambda (cadr func) `((block ,(car func) ,@(cddr func))))))) definitions) @@ -664,9 +663,9 @@ `(call (function ,(mapcar (lambda (x) (if (special-variable-p x) (let ((v (gvarname x))) - (push (cons x (make-symbol v)) dynamic-bindings) - (make-symbol v)) - (make-symbol (translate-variable x)))) + (push (cons x v) dynamic-bindings) + v) + (translate-variable x))) variables) ,(let ((body (convert-block body t t))) `,(let-binding-wrapper dynamic-bindings body))) @@ -682,7 +681,7 @@ (convert `(setq ,var ,value)) (let* ((v (gvarname var)) (b (make-binding :name var :type 'variable :value v))) - (prog1 `(var (,(make-symbol v) ,(convert value))) + (prog1 `(var (,v ,(convert value))) (push-to-lexenv b *environment* 'variable)))))) ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It @@ -697,13 +696,13 @@ (try ,@(mapcar (lambda (b) (let ((s (convert `(quote ,(car b))))) - `(var (,(make-symbol (cdr b)) (get ,s "value"))))) + `(var (,(cdr b) (get ,s "value"))))) store) ,body) (finally ,@(mapcar (lambda (b) (let ((s (convert `(quote ,(car b))))) - `(= (get ,s "value") ,(make-symbol (cdr b))))) + `(= (get ,s "value") ,(cdr b)))) store))))) (define-compilation let* (bindings &rest body) @@ -732,11 +731,11 @@ (if (member 'used (binding-declarations b)) `(selfcall (try - (var (,(make-symbol idvar) #())) + (var (,idvar #())) ,cbody) (catch (cf) (if (and (== (get cf "type") "block") - (== (get cf "id") ,(make-symbol idvar))) + (== (get cf "id") ,idvar)) ,(if *multiple-value-p* `(return (call (get |values| "apply") this (call |forcemv| (get cf "values")))) `(return (get cf "values"))) @@ -759,7 +758,7 @@ (throw (object "type" "block" - "id" ,(make-symbol (binding-value b)) + "id" ,(binding-value b) "values" ,(convert value multiple-value-p) "message" ,(concat "Return from unknown block '" (symbol-name name) "'.")))))) @@ -819,12 +818,12 @@ (setq initag (second (binding-value b)))) `(selfcall ;; TAGBODY branch to take - (var (,(make-symbol branch) ,initag)) - (var (,(make-symbol tbidx) #())) + (var (,branch ,initag)) + (var (,tbidx #())) (label tbloop (while true (try - (switch ,(make-symbol branch) + (switch ,branch ,@(with-collect (collect `(case ,initag)) (dolist (form (cdr body)) @@ -836,8 +835,8 @@ (break tbloop))) (catch (jump) (if (and (== (get jump "type") "tagbody") - (== (get jump "id") ,(make-symbol tbidx))) - (= ,(make-symbol branch) (get jump "label")) + (== (get jump "id") ,tbidx)) + (= ,branch (get jump "label")) (throw jump))))) (return ,(convert nil)))))) @@ -852,7 +851,7 @@ (throw (object "type" "tagbody" - "id" ,(make-symbol (first (binding-value b))) + "id" ,(first (binding-value b)) "label" ,(second (binding-value b)) "message" ,(concat "Attempt to GO to non-existing tag " n)))))) @@ -1345,7 +1344,7 @@ (error "Bad function designator `~S'" function)) (cond ((translate-function function) - `(call ,(make-symbol (translate-function function)) ,@arglist)) + `(call ,(translate-function function) ,@arglist)) ((and (symbolp function) #+jscl (eq (symbol-package function) (find-package "COMMON-LISP")) #-jscl t) @@ -1380,7 +1379,7 @@ (let ((b (lookup-in-lexenv sexp *environment* 'variable))) (cond ((and b (not (member 'special (binding-declarations b)))) - (make-symbol (binding-value b))) + (binding-value b)) ((or (keywordp sexp) (and b (member 'constant (binding-declarations b)))) `(get ,(convert `',sexp) "value")) -- 1.7.10.4