Commit 4a987e2b authored by Vladimir Sedach's avatar Vladimir Sedach
Browse files

Big refactoring of the ParenScript compiler.

parent 12c7e19c
......@@ -18,18 +18,15 @@
(:module :src
:components ((:file "package")
(:file "utils" :depends-on ("package"))
(:file "js-source-model" :depends-on ("package" "utils"))
(:file "ps-source-model" :depends-on ("js-source-model"))
(:file "namespace" :depends-on ("js-source-model" "ps-source-model"))
(:file "parser" :depends-on ("js-source-model" "ps-source-model" "namespace"))
(:file "builtin-packages" :depends-on ("parser"))
(:file "deprecated-interface" :depends-on ("parser"))
(:file "parse-lambda-list" :depends-on ("package"))
(:file "js-macrology" :depends-on ("deprecated-interface"))
(:file "namespace" :depends-on ("package"))
(:file "parse-lambda-list" :depends-on ("package"))
(:file "parser" :depends-on ("namespace"))
(:file "js-macrology" :depends-on ("parser"))
(:file "ps-macrology" :depends-on ("js-macrology" "parse-lambda-list"))
(:file "js-translation" :depends-on ("ps-macrology"))
; (:file "js-ugly-translation" :depends-on ("js-translation"))
(:file "compilation-interface" :depends-on ("package" "js-translation" "builtin-packages")); "js-ugly-translation"))
(:file "compilation-interface" :depends-on ("package" "js-translation")); "js-ugly-translation"))
(:file "deprecated-interface" :depends-on ("compilation-interface"))
;; standard library
(:module :lib
:components ((:static-file "functional.lisp")
(in-package :parenscript)
(defmethod setup-compilation-environment ((comp-env compilation-environment))
(install-standard-script-packages comp-env)
(setf (comp-env-current-package comp-env)
(find-script-package :parenscript-user comp-env))
(defparameter *javascript-exports*
(defparameter *parenscript-exports*
(defgeneric install-standard-script-packages (comp-env)
(:documentation "Creates standard script packages and installs them in the current compilation
(defmethod install-standard-script-packages ((comp-env compilation-environment))
:name "KEYWORD" :lisp-package :keyword)
:name "GLOBAL" :lisp-package
;; symbols in the parenscript, javascript and parenscript-user packages are non-prefixed
:name "JAVASCRIPT" :prefix "" :nicknames (list "JS") :lisp-package :parenscript.javascript
:exports *javascript-exports*
:secondary-lisp-packages '(:common-lisp))
:name "PARENSCRIPT" :prefix "" :lisp-package :parenscript
:exports *parenscript-exports*
:used-packages '(:javascript)
:name "PARENSCRIPT-USER" :prefix "" :lisp-package :parenscript-user
:secondary-lisp-packages (list :cl-user)
:used-packages '("PARENSCRIPT")
:nicknames '("PS-USER" "PAREN-USER"))
:name "PS_GS" :lisp-package
:name "UNINTERNED" :prefix "")))
\ No newline at end of file
(in-package :parenscript)
(defmacro with-new-compilation-environment ((var) &body body)
`(let* ((,var (make-basic-compilation-environment))
(*compilation-environment* ,var))
(defun translate-ast (compiled-expr
(comp-env *compilation-environment*)
(output-stream *standard-output*)
(output-spec :javascript)
(pretty-print t))
(defun translate-ast (compiled-expr &key (output-stream *standard-output*) (output-spec :javascript) (pretty-print t))
"Translates a compiled Parenscript program (compiled with COMPILE-PAREN-FORM)
to a Javascript string. Outputs to the stream OUTPUT-STREAM in the language given
by OUTPUT-SPEC, pretty printing if PRETTY-PRINT is non-null.
OUTPUT-SPEC must be :javascript at the moment."
(declare (ignore comp-env))
(when (not (eql :javascript output-spec))
(error "Unsupported output-spec for translation: ~A" output-spec))
(when (eql :javascript output-spec)
; (if (not pretty-print)
; (js-translate compiled-expr :statement output-stream)
(write-string (string-join
(ps-js::js-to-statement-strings compiled-expr 0)
(string #\Newline))
(write-string (string-join (ps-print compiled-expr 0)
(string #\Newline))
(defun non-nil-comp-env ()
"Returns a sane compilation environment. Either the one currently bound or a new
(or *compilation-environment*
(defun compile-script (script-form
(output-spec :javascript)
(pretty-print t)
(output-stream nil)
(toplevel-p t)
(comp-env (non-nil-comp-env)))
(defun compile-script (script-form &key (output-spec :javascript) (pretty-print t) (output-stream nil) (toplevel-p t))
"Compiles the Parenscript form SCRIPT-FORM into the language specified by OUTPUT-SPEC.
Non-null PRETTY-PRINT values result in a pretty-printed output code. If OUTPUT-STREAM
is NIL, then the result is a string; otherwise code is output to the OUTPUT-STREAM stream.
COMP-ENV is the compilation environment in which to compile the form.
This is the main function used by Parenscript users to compile their code to Javascript (and
potentially other languages)."
......@@ -54,49 +25,20 @@ potentially other languages)."
(let ((,var output-stream))
;; we might want to bind this rather than set it
(setf (comp-env-compiling-toplevel-p comp-env) toplevel-p)
(with-output-stream (stream)
(let* ((*compilation-environment* comp-env)
(compiled (let ((first-result (compile-parenscript-form comp-env script-form)))
(if (not toplevel-p)
(setf (comp-env-compiling-toplevel-p comp-env) nil)
(compile-parenscript-form comp-env first-result))))))
; (compile-script-form script-form :comp-env comp-env)
:comp-env comp-env
:output-stream stream
:output-spec output-spec
:pretty-print pretty-print)))))
(translate-ast (compile-parenscript-form script-form)
:output-stream stream
:output-spec output-spec
:pretty-print pretty-print))))
(defun ps-to-string (expr)
"Given an AST node, compiles it to a Javascript string."
(ps-js::js-to-statement-strings (compile-script-form expr) 0)
(string #\Newline)))
(string-join (ps-print (compile-parenscript-form expr) 0) (string #\Newline)))
;;; SEXPs -> Javascript string functionality
(defmacro script (&body body)
(defmacro ps (&body body)
"A macro that returns a Javascript string of the supplied Parenscript forms."
`(script* '(progn ,@body)))
`(ps* '(progn ,@body)))
(defun script* (&rest body)
(defun ps* (&rest body)
"Return the javascript string representing BODY.
Body is evaluated."
(compile-script `(progn ,@body)))
;;; Handy synonyms
(defmacro ps (&body body)
`(script ,@body))
(defmacro ps* (&body body)
`(script* ,@body))
(defmacro js (&body body)
`(script ,@body))
(defmacro js* (&body body)
`(script* ,@body))
......@@ -28,7 +28,7 @@
(defmacro defjsmacro (&rest args)
(warn-deprecated 'defjsmacro 'defpsmacro)
`(defscriptmacro ,@args))
`(defpsmacro ,@args))
(defmacro js-file (&rest body)
(warn-deprecated 'js-file)
......@@ -58,8 +58,10 @@
(defmacro gen-js-name (&rest args)
(warn-deprecated 'gen-js-name 'gen-ps-name)
`(gen-ps-name ,@args))
`(ps-gensym ,@args))
(defmacro gen-js-name-string (&rest args)
(warn-deprecated 'gen-js-name-string 'gen-script-name-string)
`(gen-script-name-string ,@args))
(defmacro js (&rest args)
`(ps ,@args))
(defmacro js* (&rest args)
`(ps ,@args))
\ No newline at end of file
This diff is collapsed.
(in-package :parenscript)
(defgeneric script-equal (compiled-ast-node1 compiled-ast-node2)
(:documentation "Determines if the AST nodes are equal."))
;;; AST node equality
(defmethod script-equal ((obj1 list) (obj2 list))
(and (= (length obj1) (length obj2))
(every #'script-equal obj1 obj2)))
(defmethod script-equal ((obj1 t) (obj2 t))
(equal obj1 obj2))
(defmacro defscriptclass (name superclasses slots &rest class-options)
(let ((slot-names (mapcar #'(lambda (slot) (if (atom slot) slot (first slot))) slots)))
(defclass ,name ,superclasses
,slots ,@class-options)
(defmethod script-equal ((obj1 ,name) (obj2 ,name))
(every #'(lambda (slot)
(script-equal (slot-value obj1 slot)
(slot-value obj2 slot)))
(in-package :parenscript.javascript)
(defgeneric expression-precedence (expression)
(:documentation "Returns the precedence of an enscript-javascript expression"))
;;;; define Javascript language types
(defclass statement ()
((value :initarg :value :accessor value :initform nil))
(:documentation "A Javascript entity without a value."))
(defclass expression (statement)
(:documentation "A Javascript entity with a value."))
;;; array literals
(defscriptclass array-literal (expression)
((values :initarg :values :accessor array-values)))
(defscriptclass js-aref (expression)
((array :initarg :array
:accessor aref-array)
(index :initarg :index
:accessor aref-index)))
;;; object literals (maps and hash-tables)
(defscriptclass object-literal (expression)
((values :initarg :values :accessor object-values)))
;;; string literals
(defscriptclass string-literal (expression)
;;; number literals
(defscriptclass number-literal (expression)
;;; variables
(defscriptclass js-variable (expression)
;;; operators
(defscriptclass op-form (expression)
((operator :initarg :operator :accessor operator)
(args :initarg :args :accessor op-args)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *op-precedence-hash* (make-hash-table :test #'equal))
;;; generate the operator precedences from *OP-PRECEDENCES*
(let ((precedence 1))
(dolist (ops '((aref)
(! not ~)
(* / %)
(+ -)
(<< >>)
(< > <= >=)
(in if)
(eql == != =)
(=== !==)
(\&\& and)
(\|\| or)
(setf *= /= %= += -= <<= >>= >>>= \&= ^= \|=)
(dolist (op ops)
(let ((op-name (symbol-name op)))
(setf (gethash op-name *op-precedence-hash*) precedence)))
(incf precedence)))
(defun op-precedence (op)
(gethash (if (symbolp op)
(symbol-name op)
(defscriptclass one-op (expression)
((pre-p :initarg :pre-p
:initform nil
:accessor one-op-pre-p)
(op :initarg :op
:accessor one-op)))
;;; function calls
(defscriptclass function-call (expression)
((function :initarg :function :accessor f-function)
(args :initarg :args :accessor f-args)))
(defscriptclass method-call (expression)
((method :initarg :method :accessor m-method)
(object :initarg :object :accessor m-object)
(args :initarg :args :accessor m-args)))
;;; body forms
(defscriptclass js-block (expression)
((statements :initarg :statements :accessor block-statements)
(indent :initarg :indent :initform "" :accessor block-indent)))
(defmethod initialize-instance :after ((block js-block) &rest initargs)
(declare (ignore initargs))
(let* ((statements (block-statements block))
(last (last statements))
(last-stmt (car last)))
(when (typep last-stmt 'js-block)
(setf (block-statements block)
(nconc (butlast statements)
(block-statements last-stmt))))))
(defscriptclass js-sub-block (js-block)
(statements indent))
;;; function definition
(defscriptclass js-lambda (expression)
((args :initarg :args :accessor lambda-args)
(body :initarg :body :accessor lambda-body)))
(defscriptclass js-defun (js-lambda)
((name :initarg :name :accessor defun-name)))
;;; object creation
(defscriptclass js-object (expression)
((slots :initarg :slots
:accessor o-slots)))
(defscriptclass js-slot-value (expression)
((object :initarg :object
:accessor sv-object)
(slot :initarg :slot
:accessor sv-slot)))
;;; cond
(defscriptclass js-cond (expression)
((tests :initarg :tests
:accessor cond-tests)
(bodies :initarg :bodies
:accessor cond-bodies)))
(defscriptclass js-if (expression)
((test :initarg :test
:accessor if-test)
(then :initarg :then
:accessor if-then)
(else :initarg :else
:accessor if-else)))
(defmethod initialize-instance :after ((if js-if) &rest initargs)
(declare (ignore initargs))
(when (and (if-then if)
(typep (if-then if) 'js-sub-block))
(change-class (if-then if) 'js-block))
(when (and (if-else if)
(typep (if-else if) 'js-sub-block))
(change-class (if-else if) 'js-block)))
;;; switch
(defscriptclass js-switch (statement)
((value :initarg :value :accessor case-value)
(clauses :initarg :clauses :accessor case-clauses)))
;;; assignment
(defscriptclass js-setf (expression)
((lhs :initarg :lhs :accessor setf-lhs)
(rhsides :initarg :rhsides :accessor setf-rhsides)))
;;; defvar
(defscriptclass js-defvar (statement)
((names :initarg :names :accessor var-names)
(value :initarg :value :accessor var-value)))
;;; iteration
(defscriptclass js-for (statement)
((vars :initarg :vars :accessor for-vars)
(steps :initarg :steps :accessor for-steps)
(check :initarg :check :accessor for-check)
(body :initarg :body :accessor for-body)))
(defscriptclass for-each (statement)
((name :initarg :name :accessor fe-name)
(value :initarg :value :accessor fe-value)
(body :initarg :body :accessor fe-body)))
(defscriptclass js-while (statement)
((check :initarg :check :accessor while-check)
(body :initarg :body :accessor while-body)))
;;; with
(defscriptclass js-with (statement)
((obj :initarg :obj :accessor with-obj)
(body :initarg :body :accessor with-body)))
;;; try-catch
(defscriptclass js-try (statement)
((body :initarg :body :accessor try-body)
(catch :initarg :catch :accessor try-catch)
(finally :initarg :finally :accessor try-finally)))
;;; regular expressions
(defscriptclass regex (expression)
;;; conditional compilation
(defscriptclass cc-if ()
((test :initarg :test :accessor cc-if-test)
(body :initarg :body :accessor cc-if-body)))
;; TODO this may not be the best integrated implementation of
;; instanceof into the rest of the code
(defscriptclass js-instanceof (expression)
(type :initarg :type)))
(defmacro define-js-single-op (name &optional (superclass 'expression))
(let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
(defscriptclass ,js-name (,superclass)
(define-js-single-op return statement)
(define-js-single-op throw statement)
(define-js-single-op delete)
(define-js-single-op void)
(define-js-single-op typeof)
(define-js-single-op new)
\ No newline at end of file
This diff is collapsed.
......@@ -71,17 +71,17 @@
(map nil #'handle-form forms))
(cons '+ (optimize-string-list (nreverse res)))))
(define-script-special-form html (&rest forms)
(compile-script-form (process-html-forms forms)))
(define-ps-special-form html (expecting &rest forms)
(compile-parenscript-form (process-html-forms forms)))
(defun process-css-forms(proplist)
(defun process-css-forms (proplist)
(optimize-string-list (butlast
(loop for propval on proplist by #'cddr appending
(list (string-downcase ( symbol-name (first propval)))
(list (string-downcase (symbol-name (first propval)))
(second propval)
(define-script-special-form css-inline (&rest forms)
(compile-script-form (cons '+ (process-css-forms forms))))
(define-ps-special-form css-inline (expecting &rest forms)
(compile-parenscript-form (cons '+ (process-css-forms forms))))
......@@ -3,13 +3,13 @@
;;; Handy utilities for doing common tasks found in many web browser
;;; JavaScript implementations
(defscriptmacro do-set-timeout ((timeout) &body body)
(defpsmacro do-set-timeout ((timeout) &body body)
`(set-timeout (lambda () ,@body) ,timeout))
;;; Arithmetic
(defmacro def-js-maths (&rest mathdefs)
`(progn ,@(mapcar (lambda (def) (cons 'defscriptmacro def)) mathdefs)))
`(progn ,@(mapcar (lambda (def) (cons 'defpsmacro def)) mathdefs)))
(min (&rest nums) `(*math.min ,@nums))
......@@ -34,7 +34,7 @@
;;; Exception handling
(defscriptmacro ignore-errors (&body body)
(defpsmacro ignore-errors (&body body)
`(try (progn ,@body) (:catch (e))))
;;; Misc
;;; ParenScript package system
;;; ParenScript namespace system
(in-package :parenscript)
(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).")
(prefix :accessor script-package-prefix :initform nil :initarg :prefix :type string
:documentation "The prefix string that will be used when translating the symbols in the current package to Javascript.")
(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 :initarg :exports
:initform nil;(make-hash-table :test #'equal)
: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
(symbol-table :accessor script-package-symbol-table :initform nil :initarg :symbol-table
:documentation "Contains symbols when there is no lisp package for this package.")
(:documentation "A Parenscript package is a lisp object that holds information
about a set of code.
(defun lisp-symbol-to-ps-identifier (symbol context)
(case context
(:special-form (symbol-name symbol))
(:macro symbol)
(otherwise (symbol-name symbol))))
(defmethod print-object ((sp script-package) stream)
(format stream "#<SCRIPT-PACKAGE ~s>" (script-package-name sp)))
(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.")
:accessor comp-env-lisp-to-script-package-table :initform (make-hash-table)
:documentation "Maps a lisp package to a script package.")
:accessor comp-env-compiling-toplevel-p :initform nil :initarg :processing-toplevel-p
:documentation "T if the environment is currently processing toplevel forms.")
(symbol-table :accessor symbol-to-script-package :initform (make-hash-table)
:documentation "Maps symbols to script packages. Used for only the
symbols in script packages that do not have a primary lisp package."))
(:documentation ""))
(defgeneric symbol-script-package (symbol)
(:documentation "Gets the Parenscript package associated with a Lisp/Parenscript symbol."))
(defvar *warn-ps-package* nil
"If true, warns when ParenScript attempts to compile symbols that
don't have an associated ParenScript package.")
(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*))
"Sets the script package corresponding to the given Lisp package."
`(setf (gethash ,lisp-package (comp-env-lisp-to-script-package-table ,comp-env))
(defmethod symbol-script-package ((symbol symbol))
(if (symbol-package symbol)
(or (lisp-to-script-package (symbol-package symbol) *compilation-environment*)
(progn (when *warn-ps-package*
(warn 'simple-style-warning
:format-control "~s is a symbol with lisp package ~s, which has no corresponding ParenScript package.