X-Git-Url: http://git.hcoop.net/clinton/parenscript.git/blobdiff_plain/58c4ef4f70ba26bcdbced5fa32c80fbae5909541..5ffb1ebaaff5e8f899fd4b1bd91b015f2c52d656:/src/compiler.lisp diff --git a/src/compiler.lisp b/src/compiler.lisp index 53cf18e..0cc8dc7 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -1,46 +1,61 @@ -(in-package :parenscript) +(in-package "PARENSCRIPT") -(defvar *ps-literals* ()) +;;; reserved symbols/literals + +(defvar *ps-reserved-symbol-names* ()) ;; symbol names reserved for PS/JS literals + +(defun add-ps-literal (name) + (push (symbol-name name) *ps-reserved-symbol-names*)) (defun ps-literal-p (symbol) - (member symbol *ps-literals*)) + (find (symbol-name symbol) *ps-reserved-symbol-names* :test #'equalp)) -(defun undefine-ps-special-form (name) - "Undefines the special form with the given name (name is a symbol)." - (unintern (lisp-symbol-to-ps-identifier name :special-form) :parenscript-special-forms)) +;;; special forms -(defmacro define-ps-special-form (name lambda-list &rest body) - "Define a special form NAME. The first argument given to the special -form is a keyword indicating whether the form is expected to produce -an :expression or a :statement. The resulting Parenscript language -types are appended to the ongoing javascript compilation." - (let ((arglist (gensym "ps-arglist-"))) - `(defun ,(lisp-symbol-to-ps-identifier name :special-form) (&rest ,arglist) - (destructuring-bind ,lambda-list - ,arglist - ,@body)))) +(defvar *ps-special-forms* (make-hash-table :test 'eq)) (defun get-ps-special-form (name) - "Returns the special form function corresponding to the given name." - (lisp-symbol-to-ps-identifier name :special-form)) + (gethash name *ps-special-forms*)) + +(defmacro define-ps-special-form (name lambda-list &rest body) + "Define a special form NAME. The first argument (an anaphor called +'expecting' automatically added to the arglist) to the special form is +a keyword indicating whether the form is expected to produce +an :expression or a :statement." + (let ((args (gensym "ps-arglist-"))) + `(setf (gethash ',name *ps-special-forms*) + (lambda (&rest ,args) + (destructuring-bind ,(cons 'expecting lambda-list) + ,args + (declare (ignorable expecting)) + ,@body))))) + +(defun undefine-ps-special-form (name) + (remhash name *ps-special-forms*)) + +(defun ps-special-form-p (form) + (and (consp form) + (symbolp (car form)) + (gethash (car form) *ps-special-forms*))) + +;;; scoping (defvar *enclosing-lexical-block-declarations* () "This special variable is expected to be bound to a fresh list by special forms that introduce a new JavaScript lexical block (currently function definitions and lambdas). Enclosed special forms are expected to push variable declarations onto the list when the variables -declaration cannot be made by the enclosed form (for example, a -(x,y,z) expression progn). It is then the responsibility of the +declaration cannot be made by the enclosed form \(for example, a +\(x,y,z\) expression progn\). It is then the responsibility of the enclosing special form to introduce the variable bindings in its lexical block.") (defvar *ps-special-variables* ()) -;;; ParenScript form predicates -(defun ps-special-form-p (form) - (and (consp form) - (symbolp (car form)) - (find-symbol (symbol-name (car form)) :parenscript-special-forms))) +(defun ps-special-variable-p (sym) + (member sym *ps-special-variables*)) + +;;; form predicates (defun op-form-p (form) (and (listp form) @@ -52,37 +67,38 @@ lexical block.") (not (op-form-p form)) (not (ps-special-form-p form)))) -(defun method-call-p (form) - (and (funcall-form-p form) - (symbolp (first form)) - (eql (char (symbol-name (first form)) 0) #\.))) - ;;; macro expansion (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-macro-env-dictionary () - "Creates a standard macro dictionary." - (make-hash-table :test #'equal)) - (defvar *script-macro-toplevel* (make-macro-env-dictionary) - "Toplevel macro environment dictionary. Key is the symbol of the -macro, value is (symbol-macro-p . expansion-function).") - (defvar *script-macro-env* (list *script-macro-toplevel*) + (make-hash-table :test 'eq)) + (defvar *ps-macro-toplevel* (make-macro-env-dictionary) + "Toplevel macro environment dictionary. Key is the symbol name of + the macro, value is (symbol-macro-p . expansion-function).") + + (defvar *ps-macro-env* (list *ps-macro-toplevel*) "Current macro environment.") - (defvar *script-setf-expanders* (make-macro-env-dictionary) + (defvar *ps-setf-expanders* (make-macro-env-dictionary) "Setf expander dictionary. Key is the symbol of the access function of the place, value is an expansion function that takes the arguments of the access functions as a first value and the form to be stored as the second value.") + + (defparameter *toplevel-compilation-level* :toplevel + "This value takes on the following values: +:toplevel indicates that we are traversing toplevel forms. +:inside-toplevel-form indicates that we are inside a call to compile-parenscript-form +nil indicates we are no longer toplevel-related.") (defun get-macro-spec (name env-dict) "Retrieves the macro spec of the given name with the given environment dictionary. SPEC is of the form (symbol-macro-p . expansion-function)." - (gethash (lisp-symbol-to-ps-identifier name :macro) env-dict)) + (gethash name env-dict)) (defsetf get-macro-spec (name env-dict) (spec) - `(setf (gethash (lisp-symbol-to-ps-identifier ,name :macro) ,env-dict) ,spec))) + `(setf (gethash ,name ,env-dict) ,spec))) -(defun lookup-macro-spec (name &optional (environment *script-macro-env*)) +(defun lookup-macro-spec (name &optional (environment *ps-macro-env*)) "Looks up the macro spec associated with NAME in the given environment. A macro spec is of the form (symbol-macro-p . function). Returns two values: the SPEC and the parent macro environment. @@ -95,19 +111,19 @@ NAME must be a symbol." (when val (return-from lookup-macro-spec (values val (or (cdr env) - (list *script-macro-toplevel*))))))))) + (list *ps-macro-toplevel*))))))))) -(defun script-symbol-macro-p (name &optional (environment *script-macro-env*)) +(defun ps-symbol-macro-p (name &optional (environment *ps-macro-env*)) "True if there is a Parenscript symbol macro named by the symbol NAME." (and (symbolp name) (car (lookup-macro-spec name environment)))) -(defun script-macro-p (name &optional (environment *script-macro-env*)) +(defun ps-macro-p (name &optional (environment *ps-macro-env*)) "True if there is a Parenscript macro named by the symbol NAME." (and (symbolp name) (let ((macro-spec (lookup-macro-spec name environment))) - (and macro-spec (not (car macro-spec)))))) + (and macro-spec (not (car macro-spec)))))) -(defun lookup-macro-expansion-function (name &optional (environment *script-macro-env*)) +(defun lookup-macro-expansion-function (name &optional (environment *ps-macro-env*)) "Lookup NAME in the given macro expansion environment (which defaults to the current macro environment). Returns the expansion function and the parent macro environment of the macro." @@ -115,32 +131,26 @@ function and the parent macro environment of the macro." (lookup-macro-spec name environment) (values (cdr macro-spec) parent-env))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun make-ps-macro-function (args body) - (let* ((whole-var (when (eql '&whole (first args)) (second args))) - (effective-lambda-list (if whole-var (cddr args) args)) - (form-arg (or whole-var (gensym "ps-macro-form-arg-"))) - (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring - (compile nil `(lambda (,form-arg) - (destructuring-bind ,effective-lambda-list - (cdr ,form-arg) - ,@body))))) - - (defun define-script-macro% (name args body &key symbol-macro-p) - (undefine-ps-special-form name) - (setf (get-macro-spec name *script-macro-toplevel*) - (cons symbol-macro-p (make-ps-macro-function args body))) - nil)) +(defun make-ps-macro-function (args body) + (let* ((whole-var (when (eql '&whole (first args)) (second args))) + (effective-lambda-list (if whole-var (cddr args) args)) + (whole-arg (or whole-var (gensym "ps-macro-form-arg-")))) + `(lambda (,whole-arg) + (destructuring-bind ,effective-lambda-list + (cdr ,whole-arg) + ,@body)))) (defmacro defpsmacro (name args &body body) - "Define a ParenScript macro, and store it in the toplevel ParenScript -macro environment." - `(define-script-macro% ',name ',args ',body :symbol-macro-p nil)) + `(progn (undefine-ps-special-form ',name) + (setf (get-macro-spec ',name *ps-macro-toplevel*) + (cons nil ,(make-ps-macro-function args body))) + ',name)) -(defmacro define-script-symbol-macro (name &body body) - "Define a ParenScript symbol macro, and store it in the toplevel ParenScript -macro environment. BODY is a Lisp form that should return a ParenScript form." - `(define-script-macro% ',name () ',body :symbol-macro-p t)) +(defmacro define-ps-symbol-macro (symbol expansion) + (let ((x (gensym))) + `(progn (undefine-ps-special-form ',symbol) + (setf (get-macro-spec ',symbol *ps-macro-toplevel*) (cons t (lambda (,x) (declare (ignore ,x)) ',expansion))) + ',symbol))) (defun import-macros-from-lisp (&rest names) "Import the named Lisp macros into the ParenScript macro @@ -148,21 +158,20 @@ environment. When the imported macro is macroexpanded by ParenScript, it is first fully macroexpanded in the Lisp macro environment, and then that expansion is further expanded by ParenScript." (dolist (name names) - (define-script-macro% name '(&rest args) - (list `(common-lisp:macroexpand `(,',name ,@args))) - :symbol-macro-p nil))) + (eval `(defpsmacro ,name (&rest args) + (macroexpand `(,',name ,@args)))))) (defmacro defmacro/ps (name args &body body) "Define a Lisp macro and import it into the ParenScript macro environment." `(progn (defmacro ,name ,args ,@body) - (ps:import-macros-from-lisp ',name))) + (import-macros-from-lisp ',name))) (defmacro defmacro+ps (name args &body body) - "Define a Lisp macro and a ParenScript macro in their respective -macro environments. This function should be used when you want to use -the same macro in both Lisp and ParenScript, but the 'macroexpand' of -that macro in Lisp makes the Lisp macro unsuitable to be imported into -the ParenScript macro environment." + "Define a Lisp macro and a ParenScript macro with the same macro +function (ie - the same result from macroexpand-1), for cases when the +two have different full macroexpansions (for example if the CL macro +contains implementation-specific code when macroexpanded fully in the +CL environment)." `(progn (defmacro ,name ,args ,@body) (defpsmacro ,name ,args ,@body))) @@ -170,15 +179,11 @@ the ParenScript macro environment." "Recursively macroexpands ParenScript macros and symbol-macros in the given ParenScript form. Returns two values: the expanded form, and whether any expansion was performed on the form or not." - (if (consp form) - (let ((op (car form)) - (args (cdr form))) - (cond ((equal op 'quote) (values (if (equalp '(nil) args) nil form) ;; leave quotes alone, unless it's a quoted nil - nil)) - ((script-macro-p op) (values (ps-macroexpand (funcall (lookup-macro-expansion-function op) form)) t)) - (t (values form nil)))) - (cond ((script-symbol-macro-p form) (values (ps-macroexpand (funcall (lookup-macro-expansion-function form) (list form))) t)) - (t (values form nil))))) + (let ((macro-function (cond ((ps-symbol-macro-p form) form) + ((and (consp form) (ps-macro-p (car form))) (car form))))) + (if macro-function + (values (ps-macroexpand (funcall (lookup-macro-expansion-function macro-function) form)) t) + (values form nil)))) ;;;; compiler interface (defgeneric compile-parenscript-form (form &key expecting) @@ -187,6 +192,16 @@ ParenScript representation. :expecting determines whether the form is compiled to an :expression (the default), a :statement, or a :symbol.")) +(defun adjust-toplevel-compilation-level (form level) + (let ((default-level (if (eql :toplevel level) + :inside-toplevel-form + nil))) + (if (consp form) + (case (car form) + ('progn level) + (t default-level)) + default-level))) + (defmethod compile-parenscript-form :around (form &key expecting) (assert (if expecting (member expecting '(:expression :statement :symbol)) t)) (if (eql expecting :symbol) @@ -195,15 +210,17 @@ compiled to an :expression (the default), a :statement, or a (ps-macroexpand form) (if expanded-p (compile-parenscript-form expanded-form :expecting expecting) - (call-next-method))))) + (let ((*toplevel-compilation-level* + (progn + (adjust-toplevel-compilation-level form *toplevel-compilation-level*)))) + (call-next-method)))))) (defun compile-to-symbol (form) "Compiles the given Parenscript form and guarantees that the resultant symbol has an associated script-package. Raises an error if the form cannot be compiled to a symbol." (let ((exp (compile-parenscript-form form))) - (when (or (eql (first exp) 'js-variable) - (eql (first exp) 'script-quote)) + (when (eq (first exp) 'js:variable) (setf exp (second exp))) (assert (symbolp exp) () "~a is expected to be a symbol, but compiles to ~a (the ParenScript output for ~a alone is \"~a\"). This could be due to ~a being a special form." form exp form (ps* form) form) @@ -227,62 +244,42 @@ the form cannot be compiled to a symbol." (defmethod compile-parenscript-form ((symbol symbol) &key expecting) (declare (ignore expecting)) - (cond ((ps-special-form-p (list symbol)) + (cond ((keywordp symbol) symbol) + ((ps-special-form-p (list symbol)) (if (ps-literal-p symbol) (funcall (get-ps-special-form symbol) :symbol) (error "Attempting to use Parenscript special form ~a as variable" symbol))) - (t (list 'js-variable symbol)))) - -(defun compile-function-argument-forms (arg-forms) - "Compiles a bunch of Parenscript forms from a funcall form to an effective set of -Javascript arguments. The only extra processing this does is makes :keyword arguments -into a single options argument via CREATE." - (flet ((keyword-arg (arg) - "If the given compiled expression is supposed to be a keyword argument, returns -the keyword for it." - (when (and (listp arg) (eql (first arg) 'script-quote)) (second arg)))) - (let ((compiled-args (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression)) - arg-forms))) - (do ((effective-expressions nil) - (expressions-subl compiled-args)) - ((not expressions-subl) (reverse effective-expressions)) - (let ((arg-expr (first expressions-subl))) - (if (keyword-arg arg-expr) - (progn (when (oddp (length expressions-subl)) - (error "Odd number of keyword arguments: ~A." arg-forms)) - (push (list 'js-object (loop for (name val) on expressions-subl by #'cddr - collect (list name val))) - effective-expressions) - (setf expressions-subl nil)) - (progn (push arg-expr effective-expressions) - (setf expressions-subl (rest expressions-subl))))))))) + (t `(js:variable ,symbol)))) + +(defun ps-convert-op-name (op) + (case op + (and '\&\&) + (or '\|\|) + (not '!) + (eql '\=\=) + (= '\=\=) + (t op))) (defmethod compile-parenscript-form ((form cons) &key (expecting :statement)) (let* ((name (car form)) - (args (cdr form))) - (cond ((eql name 'quote) - (assert (= 1 (length args)) () "Wrong number of arguments to quote: ~s" args) - (list 'script-quote (first args))) - ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args))) + (args (cdr form))) + (cond ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args))) ((op-form-p form) - (list 'operator - (script-convert-op-name (compile-parenscript-form (first form) :expecting :symbol)) - (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form)))) - ((method-call-p form) - (list 'js-method-call - (compile-parenscript-form name :expecting :symbol) - (compile-parenscript-form (first args) :expecting :expression) - (compile-function-argument-forms (rest args)))) + `(js:operator + ,(ps-convert-op-name (compile-parenscript-form (first form) :expecting :symbol)) + ,@(mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form)))) ((funcall-form-p form) - (list 'js-funcall - (compile-parenscript-form name :expecting :expression) - (compile-function-argument-forms args))) + `(js:funcall ,(compile-parenscript-form name :expecting :expression) + ,@(mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression)) args))) (t (error "Cannot compile ~S to a ParenScript form." form))))) (defvar *ps-gensym-counter* 0) (defun ps-gensym (&optional (prefix "_js")) - (make-symbol (format nil "~A~A" prefix (incf *ps-gensym-counter*)))) + (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil)))) + (make-symbol (format nil "~A~:[~;_~]~A" prefix + (digit-char-p (char prefix (1- (length prefix)))) + (incf *ps-gensym-counter*))))) (defmacro with-ps-gensyms (symbols &body body) "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers. @@ -296,6 +293,50 @@ gensym-prefix-string)." (list symbol)) (if prefix `(,symbol (ps-gensym ,prefix)) - `(,symbol (ps-gensym ,(symbol-to-js symbol)))))) + `(,symbol (ps-gensym ,(symbol-to-js-string symbol)))))) symbols) ,@body)) + +(defun %check-once-only-vars (vars) + (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars))) + (when bad-var + (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var)))) + +(defmacro ps-once-only ((&rest vars) &body body) + (%check-once-only-vars vars) + (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars))) + `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars) + `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars)) + ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars) + ,@body))))) + +(defvar *read-function* #'read + "This should be a function that takes the same inputs and returns the same +outputs as the common lisp read function. We declare it as a variable to allow +a user-supplied reader instead of the default lisp reader.") + +(defun ps-compile-stream (stream) + "Compiles a source stream as if it were a file. Outputs a Javascript string." + + (let ((*toplevel-compilation-level* :toplevel) + (*package* *package*) + (end-read-form '#:unique)) + (flet ((read-form () (funcall *read-function* stream nil end-read-form))) + (let* ((js-string + ;; cons up the forms, compiling as we go, and print the result + (do ((form (read-form) (read-form)) + (compiled-forms nil)) + ((eql form end-read-form) + (format nil "~{~A~^;~%~}" + (remove-if + #'(lambda (x) (or (null x) (= 0 (length x)))) + (mapcar 'compiled-form-to-string (nreverse compiled-forms))))) + (push (compile-parenscript-form form :expecting :statement) compiled-forms)))) + js-string)))) + + +(defun ps-compile-file (source-file) + "Compiles the given Parenscript source file and returns a Javascript string." + (with-open-file (stream source-file :direction :input) + (ps-compile-stream stream))) +