(in-package :parenscript) ;;;; The mechanisms for defining macros & parsing Parenscript. (defclass identifier () ((symbol :accessor id-symbol :initform nil :type symbol)) (:documentation "")) (defclass script-package () ;; configuration slots ((name :accessor script-package-name :initform nil :initarg :name :type string :documentation "Canonical name of the package (a String).") (nicknames :accessor script-package-nicknames :initform nil :initarg :nicknames :documentation "List of nicknames for the package (as strings).") (lisp-package :accessor script-package-lisp-package :initform nil :initarg :lisp-package) (secondary-lisp-packages :accessor script-package-secondary-lisp-packages :initform nil :initarg :secondary-lisp-packages) (exports :accessor script-package-exports :initform nil :initarg :exports :documentation "List of exported identifiers.") (used-packages :accessor script-package-used-packages :initform nil :initarg :used-packages :documentation "") (documentation :accessor script-package-documentation :initform nil :initarg :documentation) (compilation-env :accessor script-package-comp-env :initform nil :initarg :comp-env) (locked? :accessor script-package-locked? :initform nil :initarg :locked? :documentation "t if redefinition of top-level symbols is disallowed.") ;; internal use slots (exclusive-lisp-package-p :initform nil :initarg :exclusive-lisp-package? :accessor script-package-exclusive-lisp-package-p :documentation "t if the lisp package is an anonymous package created exclusively for the script package.") ; (toplevel-identifiers :accessor script-package-toplevel-ids :initarg :toplevel-ids ; :initform nil) ; (macro-table :accessor script-package-macro-table ; :initform (make-hash-table :test #'eql) ; :documentation "This package's macro environment, set up as a hash table ; from symbols to macro functions") ; (special-form-table :accessor script-package-special-form-table ; :initform (make-hash-table :test #'equal) ; :documentation "Holds special form macros for the package. ; Probably not used except for built-in packages.")) ) (:documentation "A Parenscript package is a lisp object that holds information about a set of Suavescript code.")) (defclass compilation-environment () ((script-packages :accessor comp-env-script-packages :initform nil :initarg :packages :documentation "List of packages defined in this environment.") (current-package :accessor comp-env-current-package :initform nil :initarg :current-package :documentation "Current in-package.") (lisp-to-script-package-table :accessor comp-env-lisp-to-script-package-table :initform (make-hash-table) :documentation "Maps a lisp package to a script package.") (compiling-toplevel-p :accessor comp-env-compiling-toplevel-p :initform nil :initarg :processing-toplevel-p :documentation "T if the environment is currently processing toplevel forms.")) (:documentation "")) (defgeneric compiler-in-situation-p (comp-env situation) (:documentation "Returns true when the compiler is considered 'in' the situation given by SITUATION, which is one of :compile-toplevel.") (:method ((comp-env compilation-environment) situation) (cond ((eql situation :compile-toplevel) (processing-toplevel-p comp-env)) ((eql situation :execute) (not (processing-toplevel-p comp-env))) (t nil)))) (defgeneric processing-toplevel-p (comp-env) (:documentation "T if we are compiling TOPLEVEL forms, as in http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm") (:method ((comp-env compilation-environment)) (comp-env-compiling-toplevel-p comp-env) )) (defvar *compilation-environment* nil "The active compilation environment. Right now all code assumes that *compilation-environment* is accurately bound to the current compilation environment--even some functions that take the compilation environment as arguments.") ;;; parenscript packages (defun lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*)) "Gets a script package corresponding to the given Lisp package." (gethash lisp-package (comp-env-lisp-to-script-package-table comp-env))) (defsetf lisp-to-script-package (lisp-package &optional (comp-env *compilation-environment*)) (script-package) "Sets the script package corresponding to the given Lisp package." `(setf (gethash ,lisp-package (comp-env-lisp-to-script-package-table ,comp-env)) ,script-package)) (defun symbol-script-package (symbol &optional (comp-env *compilation-environment*)) "Gets the Parenscript package associated with a Lisp symbol." (lisp-to-script-package (symbol-package symbol) comp-env)) (defun find-script-package (name &optional (comp-env *compilation-environment*)) "Find the script package with the name NAME in the given compilation environment." (find (string name) (comp-env-script-packages comp-env) :test #'equal)) (defun destroy-script-package (script-package) "Disposes of relevant resources when the script package is no longer relevant." (when (script-package-exclusive-lisp-package-p script-package) (delete-package (script-package-lisp-package script-package)))) ;; environmental considerations (defun make-basic-compilation-environment () "Creates a compilation environment object from scratch. Fills it in with the default script packages (parenscript, global, and parenscript-user)." (let ((comp-env (make-instance 'compilation-environment))) comp-env)) (defun create-script-package (comp-env &key name nicknames secondary-lisp-packages used-packages lisp-package exports documentation) "Creates a script package in the given compilation environment" (labels ((normalize (string-like) (string string-like))) (let* ((explicit-lisp-package-p (not (null lisp-package))) (lisp-package (or (and explicit-lisp-package-p (find-package lisp-package)) (make-package (gensym (string name)))))) (labels ((package-intern (string-like) (intern (normalize string-like) lisp-package))) (let ((script-package (make-instance 'script-package :name (normalize name) :comp-env comp-env :nicknames (mapcar #'normalize nicknames) :lisp-package (find-package lisp-package) :secondary-lisp-packages (mapcar #'find-package secondary-lisp-packages) :exclusive-lisp-package? (not explicit-lisp-package-p) :exports (mapcar #'package-intern exports) :used-packages (mapcar #'(lambda (script-package-designator) (find-script-package script-package-designator comp-env)) used-packages) :documentation documentation))) (push script-package (comp-env-script-packages comp-env))))))) (defmethod initialize-instance :after ((package script-package) &key) (assert (script-package-comp-env package)) (assert (script-package-lisp-package package)) (let ((lisp-packages (cons (script-package-lisp-package package) (script-package-secondary-lisp-packages package)))) (dolist (lisp-package lisp-packages) (when (lisp-to-script-package lisp-package (script-package-comp-env package)) (error "Lisp package already has corresponding script package: ~A" (package-name lisp-package))) (setf (lisp-to-script-package lisp-package (script-package-comp-env package)) package)))) (defgeneric comp-env-find-package (comp-env package-designator) (:documentation "Finds the script package named by PACKAGE-DESIGNATOR in the current compilation environment. PACKAGE-DESIGNATOR is a string or symbol.") (:method ((comp-env compilation-environment) (name string)) (find name (comp-env-script-packages comp-env) :key #'script-package-name :test #'equal)) (:method ((comp-env compilation-environment) (package-designator symbol)) (comp-env-find-package comp-env (string package-designator)))) ;; TODO loop through all defined macros and add them to the script package's ;; macro environment ; (labels ((name-member (name) ; (eql (script-package-lisp-package script-package) (symbol-package name))) ; (import-macro (name function) ; (when (name-member name) ; (setf (gethash name (script-package-macro-table script-package)) ; function))) ; (import-special-form (name function) ; (when (name-member name) ; (setf (gethash name (script-package-special-form-table script-package)) ; function)))) ; (maphash #'import-special-form *toplevel-special-forms*) ; (maphash #'import-special-form *toplevel-special-forms*) ;(defgeneric comp-env-select-package (comp-env script-package) ; (:documentation "") ; (:method ((comp-env compilation-environment) (package script-package)) ; (setf (comp-env-current-package (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *toplevel-special-forms* (make-hash-table) "A hash-table containing functions that implement Parenscript special forms, indexed by name (as symbols)") (defun undefine-script-special-form (name) "Undefines the special form with the given name (name is a symbol)." (declare (type symbol name)) (when (gethash name *toplevel-special-forms*) (remhash name *toplevel-special-forms*)))) (defmacro define-script-special-form (name lambda-list &rest body) "Define a special form NAME. Arguments are destructured according to LAMBDA-LIST. The resulting Parenscript language types are appended to the ongoing javascript compilation." (declare (type symbol name)) (let ((script-name (intern (format nil "PAREN-~A" (symbol-name name)) (find-package :parenscript))) (arglist (gensym "ps-arglist-"))) `(eval-when (:compile-toplevel :load-toplevel :execute) (defun ,script-name (&rest ,arglist) (destructuring-bind ,lambda-list ,arglist ,@body)) (setf (gethash (quote ,name) *toplevel-special-forms*) #',script-name)))) (defun get-script-special-form (name) "Returns the special form function corresponding to the given name." ; (declare (type symbol name)) (when (symbolp name) (gethash name *toplevel-special-forms*))) ;;; sexp form predicates (defun script-special-form-p (form) "Returns T if FORM is a special form and NIL otherwise." (and (consp form) (symbolp (car form)) (gethash (car form) *toplevel-special-forms*))) (defun funcall-form-p (form) (and (listp form) (not (op-form-p form)) (not (script-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)) (defvar *script-macro-toplevel* (make-macro-env-dictionary) "Toplevel macro environment dictionary. Key is symbol-name of the macro, value is (symbol-macro-p . expansion-function).") (defvar *script-macro-env* (list *script-macro-toplevel*) ;(list nil) "Current macro environment.")) (defmacro 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-op expansion-function)." `(gethash ,name ,env-dict)) (defun lookup-macro-spec (name &optional (environment *script-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. NAME must be a symbol." (when (symbolp name) (do ((env environment (cdr env))) ((null env) nil) (let ((val (get-macro-spec name (car env)))) (when val (return-from lookup-macro-spec (values val (or (cdr env) (list *script-macro-toplevel*))))))))) (defun script-symbol-macro-p (name &optional (environment *script-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*)) "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)))))) (defun lookup-macro-expansion-function (name &optional (environment *script-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." (multiple-value-bind (macro-spec parent-env) (lookup-macro-spec name environment) (values (cdr macro-spec) parent-env))) (defmacro defscriptmacro (name args &body body) "Define a ParenScript macro, and store it in the toplevel ParenScript macro environment." (let ((lambda-list (gensym "ps-lambda-list-")) (body (if (stringp (first body)) (rest body) body))) ;; drop docstring (undefine-script-special-form name) `(setf (get-macro-spec ',name *script-macro-toplevel*) (cons nil (lambda (&rest ,lambda-list) (destructuring-bind ,args ,lambda-list ,@body)))))) (defmacro defpsmacro (name args &body body) `(defscriptmacro (,name ,args ,@body))) (defun expand-script-form (expr) "Expands a Parenscript form down to special forms." (if (consp expr) (let ((op (car expr)) (args (cdr expr))) (cond ((equal op 'quote) expr) ;; leave quotes alone ((script-macro-p op) ;; recursively expand parenscript macros in parent env. (multiple-value-bind (expansion-function macro-env) (lookup-macro-expansion-function op) (expand-script-form (let ((*script-macro-env* macro-env)) (apply expansion-function args))))) (t expr))) ;; not a cons (cond ((script-special-form-p expr) ;; leave special forms alone (expanded during compile) expr) ((script-symbol-macro-p expr) ;; recursively expand symbol macros in parent env. (multiple-value-bind (expansion-function macro-env) (lookup-macro-expansion-function expr) (expand-script-form (let ((*script-macro-env* macro-env)) (funcall expansion-function))))) ;; leave anything else alone (t expr)))) (defun process-eval-when-args (args) "(eval-when form-language? (situation*) form*) - returns 3 values: form-language, a list of situations, and a list of body forms" (let* ((rest args) (form-language (when (not (listp (first rest))) (setf rest (rest args)) (first args))) (situations (first rest)) (body (rest rest))) (when (and (find :compile-toplevel situations) (find :execute situations)) (error "Cannot use EVAL-WHEN to execute COMPILE-TOPLEVEL and EXECUTE code simultaneously.")) (when (null form-language) (setf form-language (cond ((find :compile-toplevel situations) :lisp) ((find :execute situations) :parenscript)))) (values form-language situations body))) ;;;; compiler interface ;;;; (defgeneric compile-parenscript-form (compilation-environment form &key toplevel-p) (:documentation "Compiles FORM, which is a ParenScript form. If toplevel-p is NIL, the result is a compilation object (the AST root). Subsequently TRANSLATE-AST can be called to convert the result to Javascript. If the compiler is in the COMPILE-TOPLEVEL stage, then the result will be a Parenscript form (after it has been processed according to semantics like those of Lisp's COMPILE-FILE). See http://www.lispworks.com/documentation/HyperSpec/Body/03_bca.htm")) (defmethod compile-parenscript-form ((comp-env compilation-environment) form &key toplevel-p) (setf form (expand-script-form form)) ;; ensures proper compilation environment TOPLEVEL-P slot value (setf (comp-env-compiling-toplevel-p comp-env) toplevel-p) (if toplevel-p (cond ((not (listp form)) form) ;; process each clause of a progn as a toplevel form ((eql 'progn (car form)) `(progn ,@(mapcar #'(lambda (subform) (compile-parenscript-form comp-env subform :toplevel-p t)) (rest form)))) ;; TODO process macrolets, symbol-macrolets, and file inclusions ;; process eval-when. evaluates in :COMPILE-TOPLEVEL situation and returns ;; the resultant form. for :EXECUTE situation it returns ((eql 'eval-when (car form)) (multiple-value-bind (body-language situations body) (process-eval-when-args (rest form)) (cond ((find :compile-toplevel situations) (when (eql body-language :lisp) (let ((other-situations (remove :compile-toplevel situations))) (multiple-value-bind (function warnings-p failure-p) (compile nil `(lambda () ,@body)) (declare (ignore warnings-p) (ignore failure-p)) `(progn ,(funcall function) ,@(when other-situations (list `(eval-when ,other-situations ,@body)))))))) ;; if :compile-toplevel is not in the situation list, return the form (t form)))) (t form)) (cond ((stringp form) (make-instance 'string-literal :value form)) ((characterp form) (make-instance 'string-literal :value (string form))) ((numberp form) (make-instance 'number-literal :value form)) ((symbolp form) ;; is this the correct behavior? (let ((c-macro (get-script-special-form form))) (if c-macro (funcall c-macro) (make-instance 'script-variable :value form)))) ((and (consp form) (eql (first form) 'quote)) (make-instance 'script-quote :value (second form))) ((consp form) (let* ((name (car form)) (args (cdr form)) (script-form (get-script-special-form name))) (cond (script-form (apply script-form args)) ((op-form-p form) (make-instance 'op-form :operator (script-convert-op-name (compile-to-symbol (first form))) :args (mapcar #'compile-to-expression (rest form)))) ((method-call-p form) (make-instance 'method-call :method (compile-to-symbol (first form)) :object (compile-to-expression (second form)) :args (mapcar #'compile-to-expression (cddr form)))) ((funcall-form-p form) (make-instance 'function-call :function (compile-to-expression (first form)) :args (mapcar #'compile-to-expression (rest form)))) (t (error "Unknown form ~S" form))))) (t (error "Unknown atomar expression ~S" form))))) (defun compile-script-form (form &key (comp-env *compilation-environment*)) "Compiles a Parenscript form to an AST node." (compile-parenscript-form comp-env form )) (defun compile-to-expression (form) "Compiles the given Parenscript form and guarantees the result is an expression." (let ((res (compile-script-form form))) (assert (typep res 'expression)) res)) (defun compile-to-symbol (form) "Compiles the given Parenscript form and guarantees a symbolic result." (let ((res (compile-script-form form))) (when (typep res 'script-variable) (setf res (value res))) (assert (symbolp res) () "~a is expected to be a symbol, but compiles to ~a. This could be due to ~a being a special form." form res form) res)) (defun compile-to-statement (form) "Compiles the given Parenscript form and guarantees the result is a statement." (let ((res (compile-script-form form))) (assert (typep res 'statement)) res)) (defun compile-to-body (form &key (indent "")) "Compiles the given Parenscript form and guarantees the result is of type SCRIPT-BODY" (let ((res (compile-to-statement form))) (if (typep res 'script-body) (progn (setf (b-indent res) indent) res) (make-instance 'script-body :indent indent :statements (list res)))))