:version "0"
:maintainer "Vladimir Sedach <vsedach@gmail.com>"
:licence "BSD"
- :description "js - javascript compiler"
+ :description "Parenscript is a lispy language that compiles to Javascript."
:components ((:static-file "parenscript.asd")
(:module :src
:components ((:file "package")
(:file "utils" :depends-on ("package"))
- (:file "defgenerics" :depends-on ("package"))
- (:file "source-model" :depends-on ("package" "utils" "defgenerics"))
+ (:file "source-model" :depends-on ("package" "utils"))
(:file "parser" :depends-on ("source-model"))
- (:file "js-translation" :depends-on ("parser"))
- (:file "js-html" :depends-on ("package" "js-translation" "utils"))
- (:file "css" :depends-on ("package" "utils"))
- (:file "compile-js" :depends-on ("package" "js-translation"))
- (:file "js-utils" :depends-on ("package" "js-translation"))
+ (:file "deprecated-interface" :depends-on ("parser"))
+ (:file "macrology" :depends-on ("deprecated-interface"))
+ (:file "js-translation" :depends-on ("macrology"))
+ (:file "compilation-interface" :depends-on ("package" "js-translation"))
+ ;; standard library
(:module :lib
- :components ((:static-file "functional.lisp")))))))
+ :components ((:static-file "functional.lisp")
+ (:file "js-html")
+ (:file "css" )
+ (:file "js-utils"))
+ :depends-on ("compilation-interface")))))
+ :depends-on ())
(defmethod asdf:perform :after ((op asdf:load-op) (system (eql (asdf:find-system :parenscript))))
(pushnew :parenscript cl:*features*))
--- /dev/null
+(in-package :parenscript)
+
+(defmacro with-new-compilation-environment ((var) &body body)
+ `(let* ((,var (make-basic-compilation-environment))
+ (*compilation-environment* ,var))
+ ,@body))
+
+
+(defun translate-ast (compiled-expr
+ &key
+ (comp-env *compilation-environment*)
+ (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 pretty-print) (ignore comp-env))
+ (when (not (eql :javascript output-spec))
+ (error "Unsupported output-spec for translation: ~A" output-spec))
+ (when (eql :javascript output-spec)
+ (write-string (string-join
+ (js-to-statement-strings compiled-expr 0)
+ (string #\Newline))
+ output-stream)))
+
+(defun compile-script (script-form
+ &key
+ (output-spec :javascript)
+ (pretty-print t)
+ (output-stream nil)
+ (comp-env (make-basic-compilation-environment)))
+ "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)."
+ (macrolet ((with-output-stream ((var) &body body)
+ `(if (null output-stream)
+ (with-output-to-string (,var)
+ ,@body)
+ (let ((,var output-stream))
+ ,@body))))
+ (with-output-stream (stream)
+ (let ((*compilation-environment* comp-env))
+ (translate-ast (compile-script-form script-form :comp-env comp-env)
+ :comp-env comp-env
+ :output-stream stream
+ :output-spec output-spec
+ :pretty-print pretty-print)))))
+
+;;; SEXPs -> Javascript string functionality
+(defmacro script (&body body)
+ "A macro that returns a Javascript string of the supplied Parenscript forms."
+ `(js* '(progn ,@body)))
+
+(defmacro script* (&body body)
+ "Return the javascript string representing BODY.
+
+Body is evaluated."
+ `(compile-script (progn ,@body)))
+
+;; DEPRECATED
+(defmacro js (&body body)
+ "A macro that returns a javascript string of the supplied Parenscript forms."
+ `(script ,@body))
+
+(defmacro js* (&body body)
+ `(script* ,@body))
+
+(defun js-to-string (expr)
+ "Given an AST node, compiles it to a Javascript string."
+ (string-join
+ (js-to-statement-strings (compile-script-form expr) 0)
+ (string #\Newline)))
+
+(defun js-to-line (expr)
+ "Given an AST node, compiles it to a Javascript string."
+ (string-join
+ (js-to-statement-strings (compile-script-form expr) 0) " "))
+
+(defun compile-parenscript-file-to-string (source-file
+ &key
+ (log-stream nil)
+ (comment nil)
+ (eval-forms-p nil))
+ "Compile SOURCE-FILE (a parenscript file) to a javascript string. (in-package ...) forms
+behave as expected and all other forms are evaluated according to the value of
+EVAL-FORMS-P. If the result of the evaluation is not nil then it's compiled with
+js:js* and written to the output."
+ (with-output-to-string (output)
+ (with-open-file (input source-file :direction :input)
+ (flet ((read-form ()
+ (read input nil))
+ (log-message (&rest args)
+ (when log-stream
+ (apply #'format log-stream args))))
+ (let ((*package* *package*))
+ (loop for form = (read-form)
+ while form do
+ (if (or (not (listp form))
+ (not (eq (car form) 'cl:in-package)))
+ (progn
+ (log-message "Processing form:~%~S~%" form)
+ (when comment
+ (princ "/*" output)
+ (print form output)
+ (terpri output)
+ (princ "*/" output)
+ (terpri output))
+ (when eval-forms-p
+ (setf form (eval form)))
+ (log-message "After evaluation:~%~S~%" form)
+ (when form
+ (let ((compiled (js:js* form)))
+ (log-message "Compiled into:~%~A~%~%" compiled)
+ (write-string compiled output)
+ (terpri output)
+ (terpri output))))
+ (when (and (listp form)
+ (eq (car form) 'cl:in-package))
+ (log-message "Setting package to: ~S~%" (cadr form))
+ (setf *package* (find-package (cadr form)))))))))))
+
+(defun compile-parenscript-file (source-file &rest args &key destination-file &allow-other-keys)
+ "Compile SOURCE-FILE (a parenscript file) to a javascript file with
+compile-parenscript-file-to-string. When DESTINATION-FILE is omitted,
+then it will be named the same as SOURCE-FILE but with js extension."
+ (setf args (copy-list args))
+ (remf args :destination-file)
+ (unless destination-file
+ (setf destination-file (merge-pathnames (make-pathname :type "js")
+ source-file)))
+ (with-open-file (output destination-file :if-exists :supersede :direction :output)
+ (write-string (apply #'compile-parenscript-file-to-string source-file args) output)))
+++ /dev/null
-(in-package :parenscript)
-
-(defun compile-parenscript-file-to-string (source-file &key
- (log-stream nil)
- (comment nil)
- (eval-forms-p nil))
- "Compile SOURCE-FILE (a parenscript file) to a javascript string. (in-package ...) forms
-behave as expected and all other forms are evaluated according to the value of
-EVAL-FORMS-P. If the result of the evaluation is not nil then it's compiled with
-js:js* and written to the output."
- (with-output-to-string (output)
- (with-open-file (input source-file :direction :input)
- (flet ((read-form ()
- (read input nil))
- (log-message (&rest args)
- (when log-stream
- (apply #'format log-stream args))))
- (let ((*package* *package*))
- (loop for form = (read-form)
- while form do
- (if (or (not (listp form))
- (not (eq (car form) 'cl:in-package)))
- (progn
- (log-message "Processing form:~%~S~%" form)
- (when comment
- (princ "/*" output)
- (print form output)
- (terpri output)
- (princ "*/" output)
- (terpri output))
- (when eval-forms-p
- (setf form (eval form)))
- (log-message "After evaluation:~%~S~%" form)
- (when form
- (let ((compiled (js:js* form)))
- (log-message "Compiled into:~%~A~%~%" compiled)
- (write-string compiled output)
- (terpri output)
- (terpri output))))
- (when (and (listp form)
- (eq (car form) 'cl:in-package))
- (log-message "Setting package to: ~S~%" (cadr form))
- (setf *package* (find-package (cadr form)))))))))))
-
-(defun compile-parenscript-file (source-file &rest args &key destination-file &allow-other-keys)
- "Compile SOURCE-FILE (a parenscript file) to a javascript file with
-compile-parenscript-file-to-string. When DESTINATION-FILE is omitted,
-then it will be named the same as SOURCE-FILE but with js extension."
- (setf args (copy-list args))
- (remf args :destination-file)
- (unless destination-file
- (setf destination-file (merge-pathnames (make-pathname :type "js")
- source-file)))
- (with-open-file (output destination-file :if-exists :supersede :direction :output)
- (write-string (apply #'compile-parenscript-file-to-string source-file args) output)))
+++ /dev/null
-(in-package :parenscript)
-
-(defgeneric js-equal (obj1 obj2)
- (:documentation "Determine if two enscript-javascript statements are equivalent"))
-
-(defgeneric js-to-strings (expression start-pos)
- (:documentation "Transform an enscript-javascript expression to a string"))
-
-(defgeneric js-to-statement-strings (code-fragment start-pos)
- (:documentation "Transform an enscript-javascript code fragment to a string"))
-
-(defgeneric expression-precedence (expression)
- (:documentation "Returns the precedence of an enscript-javascript expression"))
-
-(defgeneric function-start-string (function)
- (:documentation "Returns the string that starts the function - this varies according to whether
-this is a lambda or a defun"))
--- /dev/null
+(in-package :parenscript)
+
+;;; DEPRECATED INTERFACE ;;;
+(defun js-equal (a b) (script-equal a b))
+
+(defun js-compile (form)
+ (compile-script form :output-spec :javascript))
+
+(defun js-compile-list (form)
+ (compile-script form :output-spec :javascript))
+
+(defun js-gensym (&rest args)
+ (apply #'script-gensym args))
+
+(defmacro defjsmacro (name args &rest body)
+ "Define a ParenScript macro, and store it in the toplevel ParenScript macro environment.
+
+DEPRECATED"
+ `(defscriptmacro ,name ,args ,@body))
\ No newline at end of file
(in-package :parenscript)
+
+(defgeneric js-to-strings (expression start-pos)
+ (:documentation "Transform an enscript-javascript expression to a string"))
+
+(defgeneric js-to-statement-strings (code-fragment start-pos)
+ (:documentation "Transform an enscript-javascript code fragment to a string"))
+
;;; indenter
(defun special-append-to-last (form elt)
:start "[ " :end " ]"
:join-after ",")))
-(defmethod js-to-strings ((aref js-aref) start-pos)
+(defmethod js-to-strings ((aref script-aref) start-pos)
(dwim-join (cons (js-to-strings (aref-array aref) start-pos)
(mapcar #'(lambda (x) (dwim-join (list (js-to-strings x (+ start-pos 2)))
(- 80 start-pos 2)
finally (write-char *js-quote-char* escaped)))))
;;; variables
-(defmethod js-to-strings ((v js-variable) start-form)
+(defmethod js-to-strings ((v script-variable) start-form)
(declare (ignore start-form))
(list (symbol-to-js (value v))))
;;; arithmetic operators
-(defun js-convert-op-name (op)
+(defun script-convert-op-name (op)
(case op
(and '\&\&)
(or '\|\|)
(defun op-form-p (form)
(and (listp form)
- (not (js-special-form-p form))
+ (not (script-special-form-p form))
(not (null (op-precedence (first form))))))
(defun klammer (string-list)
(args (dwim-join value-string-lists max-length
:start "(" :end ")" :join-after ",")))
(etypecase (f-function form)
- (js-lambda
+ (script-lambda
(dwim-join (list (append (dwim-join (list (js-to-strings (f-function form) (+ start-pos 2)))
max-length
:start "(" :end ")" :separator "")
args))
max-length
:separator ""))
- ((or js-variable js-aref js-slot-value)
+ ((or script-variable script-aref script-slot-value)
(dwim-join (list (js-to-strings (f-function form) (+ start-pos 2))
args)
max-length
;; TODO: this may not be the best way to add ()'s around lambdas
;; probably there is or should be a more general solution working
;; in other situations involving lambda's
- (when (member (m-object form) (list 'js-lambda 'number-literal 'js-object 'op-form) :test #'typep)
+ (when (member (m-object form) (list 'script-lambda 'number-literal 'script-object 'op-form) :test #'typep)
(push "(" object)
(nconc object (list ")")))
(let* ((fname (dwim-join (list object
(list ensure-no-newline-before-dot)
(rest method-and-args)))))
-(defmethod js-to-statement-strings ((body js-body) start-pos)
+(defmethod js-to-statement-strings ((body script-body) start-pos)
(dwim-join (mapcar #'(lambda (x) (js-to-statement-strings x (+ start-pos 2)))
- (b-stmts body))
+ (b-statements body))
(- 80 start-pos 2)
:join-after ";"
:append-to-last #'special-append-to-last
:start (b-indent body) :collect nil
:end ";"))
-(defmethod js-to-strings ((body js-body) start-pos)
+(defmethod js-to-strings ((body script-body) start-pos)
(dwim-join (mapcar #'(lambda (x) (js-to-strings x (+ start-pos 2)))
- (b-stmts body))
+ (b-statements body))
(- 80 start-pos 2)
:append-to-last #'special-append-to-last
:join-after ","
:start (b-indent body)))
-(defmethod js-to-statement-strings ((body js-sub-body) start-pos)
+(defmethod js-to-statement-strings ((body script-sub-body) start-pos)
(declare (ignore start-pos))
(nconc (list "{") (call-next-method) (list "}")))
;;; function definition
-(defmethod js-to-strings ((lambda js-lambda) start-pos)
+(defmethod js-to-strings ((lambda script-lambda) start-pos)
(let ((fun-header (dwim-join (mapcar #'(lambda (x)
(list (symbol-to-js x)))
(lambda-args lambda))
(fun-body (js-to-statement-strings (lambda-body lambda) (+ start-pos 2))))
(nconc fun-header fun-body (list "}"))))
-(defmethod function-start-string ((lambda js-lambda))
+(defgeneric function-start-string (function)
+ (:documentation "Returns the string that starts the function - this varies according to whether
+this is a lambda or a defun"))
+
+(defmethod function-start-string ((lambda script-lambda))
"function (")
-(defmethod js-to-statement-strings ((lambda js-lambda) start-pos)
+(defmethod js-to-statement-strings ((lambda script-lambda) start-pos)
(js-to-strings lambda start-pos))
-(defmethod function-start-string ((defun js-defun))
+(defmethod function-start-string ((defun script-defun))
(format nil "function ~A(" (symbol-to-js (defun-name defun))))
;;; object creation
-(defmethod js-to-strings ((object js-object) start-pos)
+(defmethod js-to-strings ((object script-object) start-pos)
(let ((value-string-lists
(mapcar #'(lambda (slot)
(dwim-join (list (js-to-strings (second slot) (+ start-pos 4)))
:white-space " "
:collect nil)))
-(defmethod js-to-strings ((sv js-slot-value) start-pos)
+(defmethod js-to-strings ((sv script-slot-value) start-pos)
(append-to-last (js-to-strings (sv-object sv) start-pos)
- (if (typep (sv-slot sv) 'js-quote)
+ (if (typep (sv-slot sv) 'script-quote)
(if (symbolp (value (sv-slot sv)))
(format nil ".~A" (symbol-to-js (value (sv-slot sv))))
(format nil ".~A" (first (js-to-strings (sv-slot sv) 0))))
(format nil "[~A]" (first (js-to-strings (sv-slot sv) 0))))))
;;; cond
-(defmethod js-to-statement-strings ((cond js-cond) start-pos)
+(defmethod js-to-statement-strings ((cond script-cond) start-pos)
(loop :for body :on (cond-bodies cond)
:for first = (eq body (cond-bodies cond))
:for last = (not (cdr body))
:append (js-to-statement-strings (car body) (+ start-pos 2))
:collect "}"))
-(defmethod js-to-statement-strings ((if js-if) start-pos)
+(defmethod js-to-statement-strings ((if script-if) start-pos)
(let ((if-strings (dwim-join (list (js-to-strings (if-test if) 0))
(- 80 start-pos 2)
:start "if ("
(nconc (list "} else {") else-strings (list "}"))
(list "}")))))
-(defmethod js-to-strings ((if js-if) start-pos)
+(defmethod js-to-strings ((if script-if) start-pos)
(assert (typep (if-then if) 'expression))
(when (if-else if)
(assert (typep (if-else if) 'expression)))
(dwim-join (list (append-to-last (js-to-strings (if-test if) start-pos) " ?")
- (let* ((new-then (make-instance 'js-body
- :stmts (b-stmts (if-then if))
+ (let* ((new-then (make-instance 'script-body
+ :statements (b-statements (if-then if))
:indent ""))
(res (js-to-strings new-then start-pos)))
(if (>= (expression-precedence (if-then if))
res))
(list ":")
(if (if-else if)
- (let* ((new-else (make-instance 'js-body
- :stmts (b-stmts (if-else if))
+ (let* ((new-else (make-instance 'script-body
+ :statements (b-statements (if-else if))
:indent ""))
(res (js-to-strings new-else start-pos)))
(if (>= (expression-precedence (if-else if))
:white-space " "))
;;; setf
-(defmethod js-to-strings ((setf js-setf) start-pos)
+(defmethod js-to-strings ((setf script-setf) start-pos)
(dwim-join (cons (js-to-strings (setf-lhs setf) start-pos)
(mapcar #'(lambda (x) (js-to-strings x start-pos)) (setf-rhsides setf)))
(- 80 start-pos 2)
:join-after " ="))
;;; defvar
-(defmethod js-to-statement-strings ((defvar js-defvar) start-pos)
+(defmethod js-to-statement-strings ((defvar script-defvar) start-pos)
(dwim-join (nconc (mapcar #'(lambda (x) (list (symbol-to-js x))) (var-names defvar))
(when (var-value defvar)
(list (js-to-strings (var-value defvar) start-pos))))
:start "var " :end ";"))
;;; iteration
-(defmethod js-to-statement-strings ((for js-for) start-pos)
+(defmethod js-to-statement-strings ((for script-for) start-pos)
(let* ((init (dwim-join (mapcar #'(lambda (x)
(dwim-join (list (list (symbol-to-js (first (var-names x))))
(js-to-strings (var-value x)
(body (js-to-statement-strings (fe-body fe) (+ start-pos 2))))
(nconc header body (list "}"))))
-(defmethod js-to-statement-strings ((while js-while) start-pos)
+(defmethod js-to-statement-strings ((while script-while) start-pos)
(let ((header (dwim-join (list (js-to-strings (while-check while) (+ start-pos 2)))
(- 80 start-pos 2)
:start "while ("
(nconc header body (list "}"))))
;;; with
-(defmethod js-to-statement-strings ((with js-with) start-pos)
+(defmethod js-to-statement-strings ((with script-with) start-pos)
(nconc (dwim-join (list (js-to-strings (with-obj with) (+ start-pos 2)))
(- 80 start-pos 2)
:start "with (" :end ") {")
(list "}")))
;;; switch
-(defmethod js-to-statement-strings ((case js-switch) start-pos)
+(defmethod js-to-statement-strings ((case script-switch) start-pos)
(let ((body (mapcan #'(lambda (clause)
(let ((val (car clause))
(body (second clause)))
(list "}"))))
;;; try-catch
-(defmethod js-to-statement-strings ((try js-try) start-pos)
+(defmethod js-to-statement-strings ((try script-try) start-pos)
(let* ((catch (try-catch try))
(finally (try-finally try))
(catch-list (when catch
;;; TODO instanceof
-(defmethod js-to-strings ((instanceof js-instanceof) start-pos)
+(defmethod js-to-strings ((instanceof script-instanceof) start-pos)
(dwim-join
(list (js-to-strings (value instanceof) (+ start-pos 2))
(list "instanceof")
;;; single operations
(defmacro define-translate-js-single-op (name &optional (superclass 'expression))
- (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
+ (let ((script-name (intern (concatenate 'string "SCRIPT-" (symbol-name name)) #.*package*)))
`(defmethod ,(if (eql superclass 'expression)
'js-to-strings
'js-to-statement-strings)
- ((,name ,js-name) start-pos)
+ ((,name ,script-name) start-pos)
(dwim-join (list (js-to-strings (value ,name) (+ start-pos 2)))
(- 80 start-pos 2)
:start ,(concatenate 'string (string-downcase (symbol-name name)) " ")
(define-translate-js-single-op void)
(define-translate-js-single-op typeof)
(define-translate-js-single-op new)
+
+(defmethod js-to-statement-strings ((blank-statement blank-statement) start-pos)
+ (declare (ignore blank-statement) (ignore start-pos))
+ '(";"))
\ No newline at end of file
";"))
(defmacro css-inline (&rest propvals)
- `(js::css-inline-func ,propvals))
+ `(parenscript::css-inline-func ,propvals))
(defmacro css-file (&rest rules)
`(html
(in-package :js)
+;;;; this file might be a little dated
+
;; This file contains JS code and is meant to be compiled and included
;; into the host environment in one way or another
(map nil #'handle-form forms))
(cons '+ (optimize-string-list (nreverse res)))))
-(define-js-special-form html (&rest forms)
- (js-compile (process-html-forms forms)))
+(define-script-special-form html (&rest forms)
+ (compile-script-form (process-html-forms forms)))
(defun process-css-forms(proplist)
(optimize-string-list (butlast
";")))))
-(define-js-special-form css-inline (&rest forms)
- (js-compile (cons '+ (process-css-forms forms))))
+(define-script-special-form css-inline (&rest forms)
+ (compile-script-form (cons '+ (process-css-forms forms))))
;;; Handy utilities for doing common tasks found in many web browser
;;; JavaScript implementations
-(defjsmacro do-set-timeout ((timeout) &body body)
+(defscriptmacro do-set-timeout ((timeout) &body body)
`(set-timeout (lambda () ,@body) ,timeout))
;;; Arithmetic
(defmacro def-js-maths (&rest mathdefs)
- `(progn ,@(mapcar (lambda (def) (cons 'defjsmacro def)) mathdefs)))
+ `(progn ,@(mapcar (lambda (def) (cons 'defscriptmacro def)) mathdefs)))
(def-js-maths
(min (&rest nums) `(*math.min ,@nums))
;;; Exception handling
-(defjsmacro ignore-errors (&body body)
+(defscriptmacro ignore-errors (&body body)
`(try (progn ,@body) (:catch (e))))
--- /dev/null
+(in-package :parenscript)
+
+;;;; The macrology of the basic Parenscript language. Special forms and macros in the
+;;;; Parenscript language.
+
+;;; parenscript gensyms
+(defvar *gen-script-name-counter* 0)
+
+(defun gen-script-name-string (&key (prefix "_ps_"))
+ "Generates a unique valid javascript identifier ()"
+ (concatenate 'string
+ prefix (princ-to-string (incf *gen-script-name-counter*))))
+
+(defun gen-script-name (&key (prefix "_ps_"))
+ "Generate a new javascript identifier."
+ (intern (gen-script-name-string :prefix prefix)
+ (find-package :js)))
+
+(defmacro with-unique-js-names (symbols &body body)
+ "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
+
+Each element of SYMBOLS is either a symbol or a list of (symbol
+prefix)."
+ `(let* ,(mapcar (lambda (symbol)
+ (destructuring-bind (symbol &optional prefix)
+ (if (consp symbol)
+ symbol
+ (list symbol))
+ (if prefix
+ `(,symbol (gen-script-name :prefix ,prefix))
+ `(,symbol (gen-script-name)))))
+ symbols)
+ ,@body))
+
+(defvar *var-counter* 0)
+
+(defun script-gensym (&optional (name "js"))
+ (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
+
+;;; literals
+(defmacro defscriptliteral (name string)
+ "Define a Javascript literal that will expand to STRING."
+ `(define-script-special-form ,name () (make-instance 'expression :value ,string)))
+
+(defscriptliteral this "this")
+(defscriptliteral t "true")
+(defscriptliteral nil "null")
+(defscriptliteral false "false")
+(defscriptliteral undefined "undefined")
+
+(defmacro defscriptkeyword (name string)
+ "Define a Javascript keyword that will expand to STRING."
+ `(define-script-special-form ,name () (make-instance 'statement :value ,string)))
+
+(defscriptkeyword break "break")
+(defscriptkeyword continue "continue")
+
+;;; array literals
+(define-script-special-form array (&rest values)
+ (make-instance 'array-literal
+ :values (mapcar #'compile-to-expression values)))
+
+(defscriptmacro list (&rest values)
+ `(array ,@values))
+
+(define-script-special-form aref (array &rest coords)
+ (make-instance 'script-aref
+ :array (compile-to-expression array)
+ :index (mapcar #'compile-to-expression coords)))
+
+
+(defscriptmacro make-array (&rest inits)
+ `(new (*array ,@inits)))
+
+;;; object literals (maps and hash-tables)
+(define-script-special-form {} (&rest values)
+ (make-instance 'object-literal
+ :values (loop
+ for (key value) on values by #'cddr
+ collect (cons key (compile-to-expression value)))))
+
+;;; operators
+(define-script-special-form ++ (x)
+ (make-instance 'one-op :pre-p nil :op "++"
+ :value (compile-to-expression x)))
+
+(define-script-special-form -- (x)
+ (make-instance 'one-op :pre-p nil :op "--"
+ :value (compile-to-expression x)))
+
+(define-script-special-form incf (x &optional (delta 1))
+ (if (eql delta 1)
+ (make-instance 'one-op :pre-p t :op "++"
+ :value (compile-to-expression x))
+ (make-instance 'op-form
+ :operator '+=
+ :args (mapcar #'compile-to-expression
+ (list x delta )))))
+
+(define-script-special-form decf (x &optional (delta 1))
+ (if (eql delta 1)
+ (make-instance 'one-op :pre-p t :op "--"
+ :value (compile-to-expression x))
+ (make-instance 'op-form
+ :operator '-=
+ :args (mapcar #'compile-to-expression
+ (list x delta )))))
+
+(define-script-special-form - (first &rest rest)
+ (if (null rest)
+ (make-instance 'one-op
+ :pre-p t
+ :op "-"
+ :value (compile-to-expression first))
+ (make-instance 'op-form
+ :operator '-
+ :args (mapcar #'compile-to-expression
+ (cons first rest)))))
+
+(define-script-special-form not (x)
+ (let ((value (compile-to-expression x)))
+ (if (and (typep value 'op-form)
+ (= (length (op-args value)) 2))
+ (let ((new-op (case (operator value)
+ (== '!=)
+ (< '>=)
+ (> '<=)
+ (<= '>)
+ (>= '<)
+ (!= '==)
+ (=== '!==)
+ (!== '===)
+ (t nil))))
+ (if new-op
+ (make-instance 'op-form :operator new-op
+ :args (op-args value))
+ (make-instance 'one-op :pre-p t :op "!"
+ :value value)))
+ (make-instance 'one-op :pre-p t :op "!"
+ :value value))))
+
+(define-script-special-form ~ (x)
+ (let ((expr (compile-to-expression x)))
+ (make-instance 'one-op :pre-p t :op "~" :value expr)))
+
+;;; progn
+(define-script-special-form progn (&rest body)
+ (make-instance 'script-body
+ :statements (mapcar #'compile-to-statement body)))
+
+(defmethod expression-precedence ((body script-body))
+ (if (= (length (b-statements body)) 1)
+ (expression-precedence (first (b-statements body)))
+ (op-precedence 'comma)))
+
+;;; function definition
+(define-script-special-form lambda (args &rest body)
+ (make-instance 'script-lambda
+ :args (mapcar #'compile-to-symbol args)
+ :body (make-instance 'script-body
+ :indent " "
+ :statements (mapcar #'compile-to-statement body))))
+
+(define-script-special-form defun (name args &rest body)
+ (make-instance 'script-defun
+ :name (compile-to-symbol name)
+ :args (mapcar #'compile-to-symbol args)
+ :body (make-instance 'script-body
+ :indent " "
+ :statements (mapcar #'compile-to-statement body))))
+
+;;; object creation
+(define-script-special-form create (&rest args)
+ (make-instance 'script-object
+ :slots (loop for (name val) on args by #'cddr
+ collect (let ((name-expr (compile-to-expression name)))
+ (assert (or (typep name-expr 'script-variable)
+ (typep name-expr 'string-literal)
+ (typep name-expr 'number-literal)))
+ (list name-expr (compile-to-expression val))))))
+
+
+(define-script-special-form slot-value (obj slot)
+ (make-instance 'script-slot-value :object (compile-to-expression obj)
+ :slot (compile-script-form slot)))
+
+;;; cond
+(define-script-special-form cond (&rest clauses)
+ (make-instance 'script-cond
+ :tests (mapcar (lambda (clause) (compile-to-expression (car clause)))
+ clauses)
+ :bodies (mapcar (lambda (clause) (compile-to-body (cons 'progn (cdr clause)) :indent " "))
+ clauses)))
+
+;;; if
+(define-script-special-form if (test then &optional else)
+ (make-instance 'script-if :test (compile-to-expression test)
+ :then (compile-to-body then :indent " ")
+ :else (when else
+ (compile-to-body else :indent " "))))
+
+(defmethod expression-precedence ((if script-if))
+ (op-precedence 'if))
+
+;;; switch
+(define-script-special-form switch (value &rest clauses)
+ (let ((clauses (mapcar #'(lambda (clause)
+ (let ((val (first clause))
+ (body (cdr clause)))
+ (list (if (eql val 'default)
+ 'default
+ (compile-to-expression val))
+ (compile-to-body (cons 'progn body) :indent " "))))
+ clauses))
+ (check (compile-to-expression value)))
+ (make-instance 'script-switch :value check
+ :clauses clauses)))
+
+
+(defscriptmacro case (value &rest clauses)
+ (labels ((make-clause (val body more)
+ (cond ((listp val)
+ (append (mapcar #'list (butlast val))
+ (make-clause (first (last val)) body more)))
+ ((member val '(t otherwise))
+ (make-clause 'default body more))
+ (more `((,val ,@body break)))
+ (t `((,val ,@body))))))
+ `(switch ,value ,@(mapcon #'(lambda (x)
+ (make-clause (car (first x))
+ (cdr (first x))
+ (rest x)))
+ clauses))))
+
+;;; assignment
+(defun assignment-op (op)
+ (case op
+ (+ '+=)
+ (~ '~=)
+ (\& '\&=)
+ (\| '\|=)
+ (- '-=)
+ (* '*=)
+ (% '%=)
+ (>> '>>=)
+ (^ '^=)
+ (<< '<<=)
+ (>>> '>>>=)
+ (/ '/=)
+ (t nil)))
+
+(defun make-js-test (lhs rhs)
+ (if (and (typep rhs 'op-form)
+ (member lhs (op-args rhs) :test #'js-equal))
+ (let ((args-without (remove lhs (op-args rhs)
+ :count 1 :test #'js-equal))
+ (args-without-first (remove lhs (op-args rhs)
+ :count 1 :end 1
+ :test #'js-equal))
+ (one (list (make-instance 'number-literal :value 1))))
+ #+nil
+ (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
+ (operator rhs)
+ args-without
+ args-without-first)
+ (cond ((and (js-equal args-without one)
+ (eql (operator rhs) '+))
+ (make-instance 'one-op :pre-p nil :op "++"
+ :value lhs))
+ ((and (js-equal args-without-first one)
+ (eql (operator rhs) '-))
+ (make-instance 'one-op :pre-p nil :op "--"
+ :value lhs))
+ ((and (assignment-op (operator rhs))
+ (member (operator rhs)
+ '(+ *))
+ (js-equal lhs (first (op-args rhs))))
+ (make-instance 'op-form
+ :operator (assignment-op (operator rhs))
+ :args (list lhs (make-instance 'op-form
+ :operator (operator rhs)
+ :args args-without-first))))
+ ((and (assignment-op (operator rhs))
+ (js-equal (first (op-args rhs)) lhs))
+ (make-instance 'op-form
+ :operator (assignment-op (operator rhs))
+ :args (list lhs (make-instance 'op-form
+ :operator (operator rhs)
+ :args (cdr (op-args rhs))))))
+ (t (make-instance 'script-setf :lhs lhs :rhsides (list rhs)))))
+ (make-instance 'script-setf :lhs lhs :rhsides (list rhs))))
+
+(define-script-special-form setf (&rest args)
+ (let ((assignments (loop for (lhs rhs) on args by #'cddr
+ for rexpr = (compile-to-expression rhs)
+ for lexpr = (compile-to-expression lhs)
+ collect (make-js-test lexpr rexpr))))
+ (if (= (length assignments) 1)
+ (first assignments)
+ (make-instance 'script-body :indent "" :statements assignments))))
+
+(defmethod expression-precedence ((setf script-setf))
+ (op-precedence '=))
+
+;;; defvar
+(define-script-special-form defvar (name &optional value)
+ (make-instance 'script-defvar :names (list (compile-to-symbol name))
+ :value (when value (compile-to-expression value))))
+
+;;; let
+(define-script-special-form let (decls &rest body)
+ (let ((defvars (mapcar #'(lambda (decl)
+ (if (atom decl)
+ (make-instance 'script-defvar
+ :names (list (compile-to-symbol decl))
+ :value nil)
+ (let ((name (first decl))
+ (value (second decl)))
+ (make-instance 'script-defvar
+ :names (list (compile-to-symbol name))
+ :value (compile-to-expression value)))))
+ decls)))
+ (make-instance 'script-sub-body
+ :indent " "
+ :statements (nconc defvars
+ (mapcar #'compile-to-statement body)))))
+
+;;; iteration
+(defun make-for-vars (decls)
+ (loop for decl in decls
+ for var = (if (atom decl) decl (first decl))
+ for init = (if (atom decl) nil (second decl))
+ collect (make-instance 'script-defvar :names (list (compile-to-symbol var))
+ :value (compile-to-expression init))))
+
+(defun make-for-steps (decls)
+ (loop for decl in decls
+ when (= (length decl) 3)
+ collect (compile-to-expression (third decl))))
+
+(define-script-special-form do (decls termination &rest body)
+ (let ((vars (make-for-vars decls))
+ (steps (make-for-steps decls))
+ (check (compile-to-expression (list 'not (first termination))))
+ (body (compile-to-body (cons 'progn body) :indent " ")))
+ (make-instance 'script-for
+ :vars vars
+ :steps steps
+ :check check
+ :body body)))
+
+(defscriptmacro dotimes (iter &rest body)
+ (let ((var (first iter))
+ (times (second iter)))
+ `(do ((,var 0 (1+ ,var)))
+ ((>= ,var ,times))
+ ,@body)))
+
+(defscriptmacro dolist (i-array &rest body)
+ (let ((var (first i-array))
+ (array (second i-array))
+ (arrvar (script-gensym "arr"))
+ (idx (script-gensym "i")))
+ `(let ((,arrvar ,array))
+ (do ((,idx 0 (1+ ,idx)))
+ ((>= ,idx (slot-value ,arrvar 'length)))
+ (let ((,var (aref ,arrvar ,idx)))
+ ,@body)))))
+
+(define-script-special-form doeach (decl &rest body)
+ (make-instance 'for-each :name (compile-to-symbol (first decl))
+ :value (compile-to-expression (second decl))
+ :body (compile-to-body (cons 'progn body) :indent " ")))
+
+(define-script-special-form while (check &rest body)
+ (make-instance 'script-while
+ :check (compile-to-expression check)
+ :body (compile-to-body (cons 'progn body) :indent " ")))
+
+;;; with
+(define-script-special-form with (statement &rest body)
+ (make-instance 'script-with
+ :obj (compile-to-expression statement)
+ :body (compile-to-body (cons 'progn body) :indent " ")))
+
+
+;;; try-catch
+(define-script-special-form try (body &rest clauses)
+ (let ((body (compile-to-body body :indent " "))
+ (catch (cdr (assoc :catch clauses)))
+ (finally (cdr (assoc :finally clauses))))
+ (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
+ (make-instance 'script-try
+ :body body
+ :catch (when catch (list (compile-to-symbol (caar catch))
+ (compile-to-body (cons 'progn (cdr catch))
+ :indent " ")))
+ :finally (when finally (compile-to-body (cons 'progn finally)
+ :indent " ")))))
+;;; regex
+(define-script-special-form regex (regex)
+ (make-instance 'regex :value (string regex)))
+
+;;; TODO instanceof
+(define-script-special-form instanceof (value type)
+ (make-instance 'script-instanceof
+ :value (compile-to-expression value)
+ :type (compile-to-expression type)))
+
+;;; script packages
+(define-script-special-form blank-statement ()
+ (make-instance 'blank-statement))
+
+(defscriptmacro defpackage (name &rest options)
+ "Defines a Parenscript package."
+ (labels ((opt-name (opt) (if (listp opt) (car opt) opt)))
+ (let ((nicknames nil) (lisp-package nil) (secondary-lisp-packages nil)
+ (exports nil) (used-packages nil) (documentation nil))
+ (dolist (opt options)
+ (case (opt-name opt)
+ (:nicknames (setf nicknames (rest opt)))
+ (:secondary-lisp-packages secondary-lisp-packages t)
+ (:export (setf exports (rest opt)))
+ (:use (setf used-packages (rest opt)))
+ (:documentation (setf documentation (second opt)))))
+ (create-script-package
+ *compilation-environment*
+ :name name
+ :nicknames nicknames
+ :secondary-lisp-packages secondary-lisp-packages
+ :used-packages used-packages
+ :lisp-package lisp-package
+ :exports exports
+ :documentation documentation)))
+ `(progn))
+
+(defscriptmacro in-package (package-designator)
+ "Changes the current script package in the parenscript compilation environment. This mostly
+affects the reader and how it interns non-prefixed symbols"
+ (setf (comp-env-current-package
+ *compilation-environment*)
+ (comp-env-find-package *compilation-environment* package-designator))
+ `(progn))
+
+;;; single operations
+(defmacro define-parse-script-single-op (name &optional (superclass 'expression))
+ (let ((script-name (intern (concatenate 'string "SCRIPT-" (symbol-name name)) #.*package*)))
+ `(define-script-special-form ,name (value)
+ (make-instance ',script-name :value (compile-to-expression value)))
+ ))
+
+(define-parse-script-single-op return statement)
+(define-parse-script-single-op throw statement)
+(define-parse-script-single-op delete)
+(define-parse-script-single-op void)
+(define-parse-script-single-op typeof)
+(define-parse-script-single-op new)
+
+;;; conditional compilation
+(define-script-special-form cc-if (test &rest body)
+ (make-instance 'cc-if :test test
+ :body (mapcar #'compile-script-form body)))
+
+;;; standard macros
+(defscriptmacro with-slots (slots object &rest body)
+ `(symbol-macrolet ,(mapcar #'(lambda (slot)
+ `(,slot '(slot-value ,object ',slot)))
+ slots)
+ ,@body))
+
+(defscriptmacro when (test &rest body)
+ `(if ,test (progn ,@body)))
+
+(defscriptmacro unless (test &rest body)
+ `(if (not ,test) (progn ,@body)))
+
+(defscriptmacro 1- (form)
+ `(- ,form 1))
+
+(defscriptmacro 1+ (form)
+ `(+ ,form 1))
+
+;;; macros
+(defmacro with-temp-macro-environment ((var) &body body)
+ `(let* ((,var (make-macro-env-dictionary))
+ (*script-macro-env* (cons ,var *script-macro-env*)))
+ ,@body))
+
+(define-script-special-form macrolet (macros &body body)
+ (with-temp-macro-environment (macro-env-dict)
+ (dolist (macro macros)
+ (destructuring-bind (name arglist &body body)
+ macro
+ (setf (get-macro-spec name macro-env-dict)
+ (cons nil (let ((args (gensym "ps-macrolet-args-")))
+ (compile nil `(lambda (&rest ,args)
+ (destructuring-bind ,arglist
+ ,args
+ ,@body))))))))
+ (compile-script-form `(progn ,@body))))
+
+(define-script-special-form symbol-macrolet (symbol-macros &body body)
+ (with-temp-macro-environment (macro-env-dict)
+ (dolist (macro symbol-macros)
+ (destructuring-bind (name &body expansion)
+ macro
+ (setf (get-macro-spec name macro-env-dict)
+ (cons t (compile nil `(lambda () ,@expansion))))))
+ (compile-script-form `(progn ,@body))))
+
+(defscriptmacro defmacro (name args &body body)
+ `(lisp (defscriptmacro ,name ,args ,@body) nil))
+
+(defscriptmacro lisp (&body forms)
+ "Evaluates the given forms in Common Lisp at ParenScript
+macro-expansion time. The value of the last form is treated as a
+ParenScript expression and is inserted into the generated Javascript
+(use nil for no-op)."
+ (eval (cons 'progn forms)))
+
+
+(defscriptmacro rebind (variables expression)
+ "Creates a new js lexical environment and copies the given
+ variable(s) there. Executes the body in the new environment. This
+ has the same effect as a new (let () ...) form in lisp but works on
+ the js side for js closures."
+ (unless (listp variables)
+ (setf variables (list variables)))
+ `((lambda ()
+ (let ((new-context (new *object)))
+ ,@(loop for variable in variables
+ do (setf variable (symbol-to-js variable))
+ collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
+ (with new-context
+ (return ,expression))))))
+
+;;; Math library
+(defscriptmacro floor (expr)
+ `(*Math.floor ,expr))
+
+(defscriptmacro random ()
+ `(*Math.random))
+
+(defscriptmacro evenp (num)
+ `(= (% ,num 2) 0))
+
+(defscriptmacro oddp (num)
+ `(= (% ,num 2) 1))
+
+;;; helper macros
+(define-script-special-form js (&rest body)
+ (make-instance 'string-literal
+ :value (string-join (js-to-statement-strings
+ (compile-script-form (cons 'progn body)) 0) " ")))
+
+(define-script-special-form script-inline (&rest body)
+ (make-instance 'string-literal
+ :value (concatenate
+ 'string
+ "javascript:"
+ (string-join (js-to-statement-strings
+ (compile-script-form (cons 'progn body)) 0) " "))))
+(defscriptmacro js-inline (&rest body)
+ `(script-inline ,@body))
+
+;;; dual lisp/parenscript macro balderdash
+;;; TODO: should probably move elsewhere ;;;
+(defmacro defmacro/js (name args &body body)
+ "Define a Lisp macro and import it into the ParenScript macro environment."
+ `(progn (defmacro ,name ,args ,@body)
+ (js:import-macros-from-lisp ',name)))
+
+(defmacro defmacro+js (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."
+ `(progn (defmacro ,name ,args ,@body)
+ (defscriptmacro ,name ,args ,@body)))
+
+(defun import-macros-from-lisp (&rest names)
+ "Import the named Lisp macros into the ParenScript macro environment."
+ (dolist (name names)
+ (let ((name name))
+ (undefine-js-special-form name)
+ (setf (get-macro-spec name *script-macro-toplevel*)
+ (cons nil (lambda (&rest args)
+ (macroexpand `(,name ,@args))))))))
+
+(defmacro js-file (&rest body)
+ `(html
+ (:princ
+ (js ,@body))))
+
+(defmacro js-script (&rest body)
+ `((:script :type "text/javascript")
+ (:princ (format nil "~%// <![CDATA[~%"))
+ (:princ (js ,@body))
+ (:princ (format nil "~%// ]]>~%"))))
+
+(defmacro js-inline (&rest body)
+ `(js-inline* '(progn ,@body)))
+
+(defmacro js-inline* (&rest body)
+ "Just like JS-INLINE except that BODY is evaluated before being
+converted to javascript."
+ `(concatenate 'string "javascript:"
+ (string-join (js-to-statement-strings (compile-script-form (list 'progn ,@body)) 0) " ")))
(defpackage :parenscript
(:use :common-lisp)
- (:nicknames :js)
+ (:nicknames :js :ps)
(:export
;; addition js symbols
#:new
#:with
;; case
+ #:switch
#:case
#:default
#:html
;; compiler
- #:js-compile
- #:js
- #:js*
- #:js-inline
- #:js-inline*
- #:js-file
- #:js-script
- #:js-to-strings
- #:js-to-statement-strings
- #:js-to-string
- #:js-to-line
- #:defjsmacro
+ #:compile-script
+ #:script
+ #:with-new-compilation-environment ; tentative
+ #:with-compilation-environment ; tentative
+
+ ;; for parenscript macro definition within lisp
+ #:defscriptmacro #:defpsmacro ; should we use one or the other of these?
#:defmacro/js
#:defmacro+js
#:import-macros-from-lisp
#:compile-parenscript-file
#:compile-parenscript-file-to-string
+
+ ;; deprecated interface
+ #:defjsmacro
+ #:js-compile
+ #:js ; replaced by #:script
+ #:js*
+ #:js-inline
+ #:js-inline*
+ #:js-file
+ #:js-script
+ #:js-to-strings
+ #:js-to-statement-strings
+ #:js-to-string
+ #:js-to-line
))
--- /dev/null
+(in-package parenscript)
+;;;; This software was taken from the SBCL system. there are very few
+;;;; changes, and one SBCL-specific thing left (sb-c::collect
+
+;;; if you have found this on google, THIS IS NOT AN SBCL SOURCE FILE
+
+;;; Break something like a lambda list (but not necessarily actually a
+;;; lambda list, e.g. the representation of argument types which is
+;;; used within an FTYPE specification) into its component parts. We
+;;; return twelve values:
+;;; 1. a list of the required args;
+;;; 2. a list of the &OPTIONAL arg specs;
+;;; 3. true if a &REST arg was specified;
+;;; 4. the &REST arg;
+;;; 5. true if &KEY args are present;
+;;; 6. a list of the &KEY arg specs;
+;;; 7. true if &ALLOW-OTHER-KEYS was specified.;
+;;; 8. true if any &AUX is present (new in SBCL vs. CMU CL);
+;;; 9. a list of the &AUX specifiers;
+;;; 10. true if a &MORE arg was specified;
+;;; 11. the &MORE context var;
+;;; 12. the &MORE count var;
+;;; 13. true if any lambda list keyword is present (only for
+;;; PARSE-LAMBDA-LIST-LIKE-THING).
+;;;
+;;; The top level lambda list syntax is checked for validity, but the
+;;; arg specifiers are just passed through untouched. If something is
+;;; wrong, we use COMPILER-ERROR, aborting compilation to the last
+;;; recovery point.
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+ (defun collect-list-expander (n-value n-tail forms)
+ (let ((n-res (gensym)))
+ `(progn
+ ,@(mapcar (lambda (form)
+ `(let ((,n-res (cons ,form nil)))
+ (cond (,n-tail
+ (setf (cdr ,n-tail) ,n-res)
+ (setq ,n-tail ,n-res))
+ (t
+ (setq ,n-tail ,n-res ,n-value ,n-res)))))
+ forms)
+ ,n-value))))
+
+(defmacro collect (collections &body body)
+ (let ((macros ())
+ (binds ()))
+ (dolist (spec collections)
+ ; (unless (proper-list-of-length-p spec 1 3)
+ ; (error "malformed collection specifier: ~S" spec))
+ (let* ((name (first spec))
+ (default (second spec))
+ (kind (or (third spec) 'collect))
+ (n-value (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-VALUE-"))))
+ (push `(,n-value ,default) binds)
+ (if (eq kind 'collect)
+ (let ((n-tail (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-TAIL-"))))
+ (if default
+ (push `(,n-tail (last ,n-value)) binds)
+ (push n-tail binds))
+ (push `(,name (&rest args)
+ (collect-list-expander ',n-value ',n-tail args))
+ macros))
+ (push `(,name (&rest args)
+ (collect-normal-expander ',n-value ',kind args))
+ macros))))
+ `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
+
+(defparameter *lambda-list-keywords*
+ '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
+
+(defun style-warn (&rest args) (apply #'format t args))
+
+
+(defun parse-lambda-list-like-thing (list)
+ (collect ((required)
+ (optional)
+ (keys)
+ (aux))
+ (let ((restp nil)
+ (rest nil)
+ (morep nil)
+ (more-context nil)
+ (more-count nil)
+ (keyp nil)
+ (auxp nil)
+ (allowp nil)
+ (state :required))
+ (declare (type (member :allow-other-keys :aux
+ :key
+ :more-context :more-count
+ :optional
+ :post-more :post-rest
+ :required :rest)
+ state))
+ (dolist (arg list)
+ (if (member arg *lambda-list-keywords*)
+ (case arg
+ (&optional
+ (unless (eq state :required)
+ (format t "misplaced &OPTIONAL in lambda list: ~S"
+ list))
+ (setq state :optional))
+ (&rest
+ (unless (member state '(:required :optional))
+ (format t "misplaced &REST in lambda list: ~S" list))
+ (setq state :rest))
+ (&more
+ (unless (member state '(:required :optional))
+ (format t "misplaced &MORE in lambda list: ~S" list))
+ (setq morep t
+ state :more-context))
+ (&key
+ (unless (member state
+ '(:required :optional :post-rest :post-more))
+ (format t "misplaced &KEY in lambda list: ~S" list))
+ #-sb-xc-host
+ (when (optional)
+ (format t
+ "&OPTIONAL and &KEY found in the same lambda list: ~S" list))
+ (setq keyp t
+ state :key))
+ (&allow-other-keys
+ (unless (eq state ':key)
+ (format t "misplaced &ALLOW-OTHER-KEYS in ~
+ lambda list: ~S"
+ list))
+ (setq allowp t
+ state :allow-other-keys))
+ (&aux
+ (when (member state '(:rest :more-context :more-count))
+ (format t "misplaced &AUX in lambda list: ~S" list))
+ (when auxp
+ (format t "multiple &AUX in lambda list: ~S" list))
+ (setq auxp t
+ state :aux))
+ (t (format t "unknown LAMBDA-LIST-KEYWORD in lambda list: ~S." arg)))
+ (progn
+ (when (symbolp arg)
+ (let ((name (symbol-name arg)))
+ (when (and (plusp (length name))
+ (char= (char name 0) #\&))
+ (style-warn
+ "suspicious variable in lambda list: ~S." arg))))
+ (case state
+ (:required (required arg))
+ (:optional (optional arg))
+ (:rest
+ (setq restp t
+ rest arg
+ state :post-rest))
+ (:more-context
+ (setq more-context arg
+ state :more-count))
+ (:more-count
+ (setq more-count arg
+ state :post-more))
+ (:key (keys arg))
+ (:aux (aux arg))
+ (t
+ (format t "found garbage in lambda list when expecting ~
+ a keyword: ~S"
+ arg))))))
+ (when (eq state :rest)
+ (format t "&REST without rest variable"))
+
+ (values (required) (optional) restp rest keyp (keys) allowp auxp (aux)
+ morep more-context more-count
+ (not (eq state :required))))))
+
+;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument
+;;; really *is* a lambda list, not just a "lambda-list-like thing", so
+;;; can barf on things which're illegal as arguments in lambda lists
+;;; even if they could conceivably be legal in not-quite-a-lambda-list
+;;; weirdosities
+(defun parse-lambda-list (lambda-list)
+
+ ;; Classify parameters without checking their validity individually.
+ (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux
+ morep more-context more-count)
+ (parse-lambda-list-like-thing lambda-list)
+
+ ;; Check validity of parameters.
+ (flet ((need-symbol (x why)
+ (unless (or (symbolp x) t)
+ (format t "~A is not a symbol: ~S" why x))))
+ (dolist (i required)
+ (need-symbol i "Required argument"))
+ (dolist (i optional)
+ (typecase i
+ (symbol)
+ (cons
+ (destructuring-bind (var &optional init-form supplied-p) i
+ (declare (ignore init-form supplied-p))
+ (need-symbol var "&OPTIONAL parameter name")))
+ (t
+ (format t "&OPTIONAL parameter is not a symbol or cons: ~S"
+ i))))
+ (when restp
+ (need-symbol rest "&REST argument"))
+ (when keyp
+ (dolist (i keys)
+ (typecase i
+ (symbol)
+ (cons
+ (destructuring-bind (var-or-kv &optional init-form supplied-p) i
+ (declare (ignore init-form supplied-p))
+ (if (consp var-or-kv)
+ (destructuring-bind (keyword-name var) var-or-kv
+ (declare (ignore keyword-name))
+ (need-symbol var "&KEY parameter name"))
+ (need-symbol var-or-kv "&KEY parameter name"))))
+ (t
+ (format t "&KEY parameter is not a symbol or cons: ~S"
+ i))))))
+
+ ;; Voila.
+ (values required optional restp rest keyp keys allowp auxp aux
+ morep more-context more-count)))
-(in-package :parenscript)
-
-;;; special forms
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *js-special-forms* (make-hash-table :test 'equal)
- "A hash-table containing functions that implement ParenScript
-special forms, indexed by name (a string).")
-
- (defun undefine-js-special-form (name)
- (when (gethash (symbol-name name) *js-special-forms*)
- (warn "Redefining ParenScript special form ~S" name)
- (remhash (symbol-name name) *js-special-forms*))))
-
-(defmacro define-js-special-form (name lambda-list &rest body)
- "Define a special form NAME. Arguments are destructured according to
-LAMBDA-LIST. The resulting JS language types are appended to the
-ongoing javascript compilation."
- (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*))
- (arglist (gensym "ps-arglist-")))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun ,js-name (&rest ,arglist)
- (destructuring-bind ,lambda-list
- ,arglist
- ,@body))
- (setf (gethash ,(symbol-name name) *js-special-forms*) #',js-name))))
-
-(defun js-special-form-p (form)
- (and (consp form)
- (symbolp (car form))
- (gethash (symbol-name (car form)) *js-special-forms*)))
-
-(defun js-get-special-form (name)
- (when (symbolp name)
- (gethash (symbol-name name) *js-special-forms*)))
-
-;;; macro expansion
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun make-macro-env-dictionary ()
- (make-hash-table :test 'equal))
-
- (defvar *js-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 *js-macro-env* (list *js-macro-toplevel*)
- "Current macro environment."))
-
-(defmacro get-macro-spec (name env-dict)
- `(gethash (symbol-name ,name) ,env-dict))
-
-(defun lookup-macro-spec (name &optional (environment *js-macro-env*))
- (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 *js-macro-toplevel*)))))))))
-
-(defun symbol-macro-p (name &optional (environment *js-macro-env*))
- (and (symbolp name) (car (lookup-macro-spec name environment))))
-
-(defun macro-p (name &optional (environment *js-macro-env*))
- (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 *js-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 defjsmacro (name args &rest 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-js-special-form name)
- `(setf (get-macro-spec ',name *js-macro-toplevel*)
- (cons nil (lambda (&rest ,lambda-list)
- (destructuring-bind ,args
- ,lambda-list
- ,@body))))))
-
-(defmacro defmacro/js (name args &body body)
- "Define a Lisp macro and import it into the ParenScript macro environment."
- `(progn (defmacro ,name ,args ,@body)
- (js:import-macros-from-lisp ',name)))
-
-(defmacro defmacro+js (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."
- `(progn (defmacro ,name ,args ,@body)
- (js:defjsmacro ,name ,args ,@body)))
-
-(defun import-macros-from-lisp (&rest names)
- "Import the named Lisp macros into the ParenScript macro environment."
- (dolist (name names)
- (let ((name name))
- (undefine-js-special-form name)
- (setf (get-macro-spec name *js-macro-toplevel*)
- (cons nil (lambda (&rest args)
- (macroexpand `(,name ,@args))))))))
-
-(defun js-expand-form (expr)
- (if (consp expr)
- (let ((op (car expr))
- (args (cdr expr)))
- (cond ((equal op 'quote) expr)
- ((macro-p op) (multiple-value-bind (expansion-function macro-env)
- (lookup-macro-expansion-function op)
- (js-expand-form (let ((*js-macro-env* macro-env))
- (apply expansion-function args)))))
- (t expr)))
- (cond ((js-special-form-p expr) expr)
- ((symbol-macro-p expr) (multiple-value-bind (expansion-function macro-env)
- (lookup-macro-expansion-function expr)
- (js-expand-form (let ((*js-macro-env* macro-env))
- (funcall expansion-function)))))
- (t expr))))
-
-(defvar *gen-js-name-counter* 0)
-
-(defun gen-js-name-string (&key (prefix "_ps_"))
- "Generates a unique valid javascript identifier ()"
- (concatenate 'string
- prefix (princ-to-string (incf *gen-js-name-counter*))))
-
-(defun gen-js-name (&key (prefix "_ps_"))
- "Generate a new javascript identifier."
- (intern (gen-js-name-string :prefix prefix)
- (find-package :js)))
-
-(defmacro with-unique-js-names (symbols &body body)
- "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
-
-Each element of SYMBOLS is either a symbol or a list of (symbol
-prefix)."
- `(let* ,(mapcar (lambda (symbol)
- (destructuring-bind (symbol &optional prefix)
- (if (consp symbol)
- symbol
- (list symbol))
- (if prefix
- `(,symbol (gen-js-name :prefix ,prefix))
- `(,symbol (gen-js-name)))))
- symbols)
- ,@body))
-
-(defjsmacro rebind (variables expression)
- "Creates a new js lexical environment and copies the given
- variable(s) there. Executes the body in the new environment. This
- has the same effect as a new (let () ...) form in lisp but works on
- the js side for js closures."
- (unless (listp variables)
- (setf variables (list variables)))
- `((lambda ()
- (let ((new-context (new *object)))
- ,@(loop for variable in variables
- do (setf variable (symbol-to-js variable))
- collect `(setf (slot-value new-context ,variable) (slot-value this ,variable)))
- (with new-context
- (return ,expression))))))
-
-(defvar *var-counter* 0)
-
-(defun js-gensym (&optional (name "js"))
- (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
-
-;;; reserved Javascript keywords
-
-(defvar *reserved-javascript-keywords*
- '("abstract" "else" "instanceof" "switch" "boolean" "enum" "int" "synchronized"
- "break" "export" "interface" "this" "byte" "extends" "long" "throw" "case"
- "native" "throws" "catch" "final" "new" "transient" "char" "finally" "float"
- "package" "try" "const" "for" "private" "typeof" "continue" "function"
- "protected" "var" "debugger" "goto" "public" "void" "default" "if" "return"
- "volatile" "delete" "implements" "short" "while" "do" "import" "static" "with"
- "double" "in" "super" "class"))
-
-(defun reserved-identifier-p (id-string)
- (find id-string *reserved-javascript-keywords* :test #'string-equal))
-
-(defmethod initialize-instance :after ((var js-variable) &rest initargs)
- (declare (ignore initargs))
- (when (reserved-identifier-p (slot-value var 'value))
- (warn "~a is a reserved Javascript keyword and should not be used as a variable or function name." (slot-value var 'value))))
-
-;;; literals
-
-(defmacro defjsliteral (name string)
- "Define a Javascript literal that will expand to STRING."
- `(define-js-special-form ,name () (make-instance 'expression :value ,string)))
-
-(defjsliteral this "this")
-(defjsliteral t "true")
-(defjsliteral nil "null")
-(defjsliteral false "false")
-(defjsliteral undefined "undefined")
-
-(defmacro defjskeyword (name string)
- "Define a Javascript keyword that will expand to STRING."
- `(define-js-special-form ,name () (make-instance 'statement :value ,string)))
-
-(defjskeyword break "break")
-(defjskeyword continue "continue")
-
-;;; array literals
-
-(define-js-special-form array (&rest values)
- (make-instance 'array-literal
- :values (mapcar #'js-compile-to-expression values)))
-
-(defjsmacro list (&rest values)
- `(array ,@values))
-
-(define-js-special-form aref (array &rest coords)
- (make-instance 'js-aref
- :array (js-compile-to-expression array)
- :index (mapcar #'js-compile-to-expression coords)))
-
-
-(defjsmacro make-array (&rest inits)
- `(new (*array ,@inits)))
-
-;;; object literals (maps and hash-tables)
-
-(define-js-special-form {} (&rest values)
- (make-instance 'object-literal
- :values (loop
- for (key value) on values by #'cddr
- collect (cons key (js-compile-to-expression value)))))
-
-;;; operators
-(define-js-special-form ++ (x)
- (make-instance 'one-op :pre-p nil :op "++"
- :value (js-compile-to-expression x)))
-
-(define-js-special-form -- (x)
- (make-instance 'one-op :pre-p nil :op "--"
- :value (js-compile-to-expression x)))
-
-(define-js-special-form incf (x &optional (delta 1))
- (if (eql delta 1)
- (make-instance 'one-op :pre-p t :op "++"
- :value (js-compile-to-expression x))
- (make-instance 'op-form
- :operator '+=
- :args (mapcar #'js-compile-to-expression
- (list x delta )))))
-
-(define-js-special-form decf (x &optional (delta 1))
- (if (eql delta 1)
- (make-instance 'one-op :pre-p t :op "--"
- :value (js-compile-to-expression x))
- (make-instance 'op-form
- :operator '-=
- :args (mapcar #'js-compile-to-expression
- (list x delta )))))
-
-(define-js-special-form - (first &rest rest)
- (if (null rest)
- (make-instance 'one-op
- :pre-p t
- :op "-"
- :value (js-compile-to-expression first))
- (make-instance 'op-form
- :operator '-
- :args (mapcar #'js-compile-to-expression
- (cons first rest)))))
-
-(define-js-special-form not (x)
- (let ((value (js-compile-to-expression x)))
- (if (and (typep value 'op-form)
- (= (length (op-args value)) 2))
- (let ((new-op (case (operator value)
- (== '!=)
- (< '>=)
- (> '<=)
- (<= '>)
- (>= '<)
- (!= '==)
- (=== '!==)
- (!== '===)
- (t nil))))
- (if new-op
- (make-instance 'op-form :operator new-op
- :args (op-args value))
- (make-instance 'one-op :pre-p t :op "!"
- :value value)))
- (make-instance 'one-op :pre-p t :op "!"
- :value value))))
-
-(define-js-special-form ~ (x)
- (let ((expr (js-compile-to-expression x)))
- (make-instance 'one-op :pre-p t :op "~" :value expr)))
-
-;;; function calls
-
-(defun funcall-form-p (form)
- (and (listp form)
- (not (op-form-p form))
- (not (js-special-form-p form))))
-
-(defun method-call-p (form)
- (and (funcall-form-p form)
- (symbolp (first form))
- (eql (char (symbol-name (first form)) 0) #\.)))
-
-;;; progn
-
-(define-js-special-form progn (&rest body)
- (make-instance 'js-body
- :stmts (mapcar #'js-compile-to-statement body)))
-
-(defmethod expression-precedence ((body js-body))
- (if (= (length (b-stmts body)) 1)
- (expression-precedence (first (b-stmts body)))
- (op-precedence 'comma)))
-
-;;; function definition
-(define-js-special-form lambda (args &rest body)
- (make-instance 'js-lambda
- :args (mapcar #'js-compile-to-symbol args)
- :body (make-instance 'js-body
- :indent " "
- :stmts (mapcar #'js-compile-to-statement body))))
-
-(define-js-special-form defun (name args &rest body)
- (make-instance 'js-defun
- :name (js-compile-to-symbol name)
- :args (mapcar #'js-compile-to-symbol args)
- :body (make-instance 'js-body
- :indent " "
- :stmts (mapcar #'js-compile-to-statement body))))
-
-;;; object creation
-(define-js-special-form create (&rest args)
- (make-instance 'js-object
- :slots (loop for (name val) on args by #'cddr
- collect (let ((name-expr (js-compile-to-expression name)))
- (assert (or (typep name-expr 'js-variable)
- (typep name-expr 'string-literal)
- (typep name-expr 'number-literal)))
- (list name-expr (js-compile-to-expression val))))))
-
-
-(define-js-special-form slot-value (obj slot)
- (make-instance 'js-slot-value :object (js-compile-to-expression obj)
- :slot (js-compile slot)))
-
-;;; cond
-(define-js-special-form cond (&rest clauses)
- (make-instance 'js-cond
- :tests (mapcar (lambda (clause) (js-compile-to-expression (car clause)))
- clauses)
- :bodies (mapcar (lambda (clause) (js-compile-to-body (cons 'progn (cdr clause)) :indent " "))
- clauses)))
-
-;;; if
-(define-js-special-form if (test then &optional else)
- (make-instance 'js-if :test (js-compile-to-expression test)
- :then (js-compile-to-body then :indent " ")
- :else (when else
- (js-compile-to-body else :indent " "))))
-
-(defmethod expression-precedence ((if js-if))
- (op-precedence 'if))
-
-;;; switch
-(define-js-special-form switch (value &rest clauses)
- (let ((clauses (mapcar #'(lambda (clause)
- (let ((val (first clause))
- (body (cdr clause)))
- (list (if (eql val 'default)
- 'default
- (js-compile-to-expression val))
- (js-compile-to-body (cons 'progn body) :indent " "))))
- clauses))
- (check (js-compile-to-expression value)))
- (make-instance 'js-switch :value check
- :clauses clauses)))
-
-
-(defjsmacro case (value &rest clauses)
- (labels ((make-clause (val body more)
- (cond ((listp val)
- (append (mapcar #'list (butlast val))
- (make-clause (first (last val)) body more)))
- ((member val '(t otherwise))
- (make-clause 'default body more))
- (more `((,val ,@body break)))
- (t `((,val ,@body))))))
- `(switch ,value ,@(mapcon #'(lambda (x)
- (make-clause (car (first x))
- (cdr (first x))
- (rest x)))
- clauses))))
-
-;;; assignment
-(defun assignment-op (op)
- (case op
- (+ '+=)
- (~ '~=)
- (\& '\&=)
- (\| '\|=)
- (- '-=)
- (* '*=)
- (% '%=)
- (>> '>>=)
- (^ '^=)
- (<< '<<=)
- (>>> '>>>=)
- (/ '/=)
- (t nil)))
-
-(defun make-js-test (lhs rhs)
- (if (and (typep rhs 'op-form)
- (member lhs (op-args rhs) :test #'js-equal))
- (let ((args-without (remove lhs (op-args rhs)
- :count 1 :test #'js-equal))
- (args-without-first (remove lhs (op-args rhs)
- :count 1 :end 1
- :test #'js-equal))
- (one (list (make-instance 'number-literal :value 1))))
- #+nil
- (format t "OPERATOR: ~S, ARGS-WITHOUT: ~S, ARGS-WITHOUT-FIRST ~S~%"
- (operator rhs)
- args-without
- args-without-first)
- (cond ((and (js-equal args-without one)
- (eql (operator rhs) '+))
- (make-instance 'one-op :pre-p nil :op "++"
- :value lhs))
- ((and (js-equal args-without-first one)
- (eql (operator rhs) '-))
- (make-instance 'one-op :pre-p nil :op "--"
- :value lhs))
- ((and (assignment-op (operator rhs))
- (member (operator rhs)
- '(+ *))
- (js-equal lhs (first (op-args rhs))))
- (make-instance 'op-form
- :operator (assignment-op (operator rhs))
- :args (list lhs (make-instance 'op-form
- :operator (operator rhs)
- :args args-without-first))))
- ((and (assignment-op (operator rhs))
- (js-equal (first (op-args rhs)) lhs))
- (make-instance 'op-form
- :operator (assignment-op (operator rhs))
- :args (list lhs (make-instance 'op-form
- :operator (operator rhs)
- :args (cdr (op-args rhs))))))
- (t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
- (make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
-
-(define-js-special-form setf (&rest args)
- (let ((assignments (loop for (lhs rhs) on args by #'cddr
- for rexpr = (js-compile-to-expression rhs)
- for lexpr = (js-compile-to-expression lhs)
- collect (make-js-test lexpr rexpr))))
- (if (= (length assignments) 1)
- (first assignments)
- (make-instance 'js-body :indent "" :stmts assignments))))
-
-(defmethod expression-precedence ((setf js-setf))
- (op-precedence '=))
-
-;;; defvar
-(define-js-special-form defvar (name &optional value)
- (make-instance 'js-defvar :names (list (js-compile-to-symbol name))
- :value (when value (js-compile-to-expression value))))
-
-;;; let
-(define-js-special-form let (decls &rest body)
- (let ((defvars (mapcar #'(lambda (decl)
- (if (atom decl)
- (make-instance 'js-defvar
- :names (list (js-compile-to-symbol decl))
- :value nil)
- (let ((name (first decl))
- (value (second decl)))
- (make-instance 'js-defvar
- :names (list (js-compile-to-symbol name))
- :value (js-compile-to-expression value)))))
- decls)))
- (make-instance 'js-sub-body
- :indent " "
- :stmts (nconc defvars
- (mapcar #'js-compile-to-statement body)))))
-
-;;; iteration
-(defun make-for-vars (decls)
- (loop for decl in decls
- for var = (if (atom decl) decl (first decl))
- for init = (if (atom decl) nil (second decl))
- collect (make-instance 'js-defvar :names (list (js-compile-to-symbol var))
- :value (js-compile-to-expression init))))
-
-(defun make-for-steps (decls)
- (loop for decl in decls
- when (= (length decl) 3)
- collect (js-compile-to-expression (third decl))))
-
-(define-js-special-form do (decls termination &rest body)
- (let ((vars (make-for-vars decls))
- (steps (make-for-steps decls))
- (check (js-compile-to-expression (list 'not (first termination))))
- (body (js-compile-to-body (cons 'progn body) :indent " ")))
- (make-instance 'js-for
- :vars vars
- :steps steps
- :check check
- :body body)))
-
-(defjsmacro dotimes (iter &rest body)
- (let ((var (first iter))
- (times (second iter)))
- `(do ((,var 0 (1+ ,var)))
- ((>= ,var ,times))
- ,@body)))
-
-(defjsmacro dolist (i-array &rest body)
- (let ((var (first i-array))
- (array (second i-array))
- (arrvar (js-gensym "arr"))
- (idx (js-gensym "i")))
- `(let ((,arrvar ,array))
- (do ((,idx 0 (1+ ,idx)))
- ((>= ,idx (slot-value ,arrvar 'length)))
- (let ((,var (aref ,arrvar ,idx)))
- ,@body)))))
-
-(define-js-special-form doeach (decl &rest body)
- (make-instance 'for-each :name (js-compile-to-symbol (first decl))
- :value (js-compile-to-expression (second decl))
- :body (js-compile-to-body (cons 'progn body) :indent " ")))
-
-(define-js-special-form while (check &rest body)
- (make-instance 'js-while
- :check (js-compile-to-expression check)
- :body (js-compile-to-body (cons 'progn body) :indent " ")))
-
-;;; with
-
-(define-js-special-form with (statement &rest body)
- (make-instance 'js-with
- :obj (js-compile-to-expression statement)
- :body (js-compile-to-body (cons 'progn body) :indent " ")))
-
-;;; try-catch
-(define-js-special-form try (body &rest clauses)
- (let ((body (js-compile-to-body body :indent " "))
- (catch (cdr (assoc :catch clauses)))
- (finally (cdr (assoc :finally clauses))))
- (assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
- (make-instance 'js-try
- :body body
- :catch (when catch (list (js-compile-to-symbol (caar catch))
- (js-compile-to-body (cons 'progn (cdr catch))
- :indent " ")))
- :finally (when finally (js-compile-to-body (cons 'progn finally)
- :indent " ")))))
-;;; regex
-(define-js-special-form regex (regex)
- (make-instance 'regex :value (string regex)))
-
-;;; TODO instanceof
-(define-js-special-form instanceof (value type)
- (make-instance 'js-instanceof
- :value (js-compile-to-expression value)
- :type (js-compile-to-expression type)))
-
-;;; single operations
-(defmacro define-parse-js-single-op (name &optional (superclass 'expression))
- (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
- `(define-js-special-form ,name (value)
- (make-instance ',js-name :value (js-compile-to-expression value)))
- ))
-
-(define-parse-js-single-op return statement)
-(define-parse-js-single-op throw statement)
-(define-parse-js-single-op delete)
-(define-parse-js-single-op void)
-(define-parse-js-single-op typeof)
-(define-parse-js-single-op new)
-
-;;; conditional compilation
-(define-js-special-form cc-if (test &rest body)
- (make-instance 'cc-if :test test
- :body (mapcar #'js-compile body)))
-
-;;; standard macros
-(defjsmacro with-slots (slots object &rest body)
- `(symbol-macrolet ,(mapcar #'(lambda (slot)
- `(,slot '(slot-value ,object ',slot)))
- slots)
- ,@body))
-
-(defjsmacro when (test &rest body)
- `(if ,test (progn ,@body)))
-
-(defjsmacro unless (test &rest body)
- `(if (not ,test) (progn ,@body)))
-
-(defjsmacro 1- (form)
- `(- ,form 1))
-
-(defjsmacro 1+ (form)
- `(+ ,form 1))
-
-;;; macros
-(defmacro with-temp-macro-environment ((var) &body body)
- `(let* ((,var (make-macro-env-dictionary))
- (*js-macro-env* (cons ,var *js-macro-env*)))
- ,@body))
-
-(define-js-special-form macrolet (macros &body body)
- (with-temp-macro-environment (macro-env-dict)
- (dolist (macro macros)
- (destructuring-bind (name arglist &body body)
- macro
- (setf (get-macro-spec name macro-env-dict)
- (cons nil (let ((args (gensym "ps-macrolet-args-")))
- (compile nil `(lambda (&rest ,args)
- (destructuring-bind ,arglist
- ,args
- ,@body))))))))
- (js-compile `(progn ,@body))))
-
-(define-js-special-form symbol-macrolet (symbol-macros &body body)
- (with-temp-macro-environment (macro-env-dict)
- (dolist (macro symbol-macros)
- (destructuring-bind (name &body expansion)
- macro
- (setf (get-macro-spec name macro-env-dict)
- (cons t (compile nil `(lambda () ,@expansion))))))
- (js-compile `(progn ,@body))))
-
-(defjsmacro defmacro (name args &body body)
- `(lisp (defjsmacro ,name ,args ,@body) nil))
-
-(defjsmacro lisp (&body forms)
- "Evaluates the given forms in Common Lisp at ParenScript
-macro-expansion time. The value of the last form is treated as a
-ParenScript expression and is inserted into the generated Javascript
-(use nil for no-op)."
- (eval (cons 'progn forms)))
-
-;;; Math library
-(defjsmacro floor (expr)
- `(*Math.floor ,expr))
-
-(defjsmacro random ()
- `(*Math.random))
-
-(defjsmacro evenp (num)
- `(= (% ,num 2) 0))
-
-(defjsmacro oddp (num)
- `(= (% ,num 2) 1))
-
-;;; helper macros
-(define-js-special-form js (&rest body)
- (make-instance 'string-literal
- :value (string-join (js-to-statement-strings
- (js-compile (cons 'progn body)) 0) " ")))
-
-(define-js-special-form js-inline (&rest body)
- (make-instance 'string-literal
- :value (concatenate
- 'string
- "javascript:"
- (string-join (js-to-statement-strings
- (js-compile (cons 'progn body)) 0) " "))))
-
-;;;; compiler interface ;;;;
-(defun js-compile (form)
- (setf form (js-expand-form 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)
- (let ((c-macro (js-get-special-form form)))
- (if c-macro
- (funcall c-macro)
- (make-instance 'js-variable :value form))))
- ((and (consp form)
- (eql (first form) 'quote))
- (make-instance 'js-quote :value (second form)))
- ((consp form)
- (js-compile-list form))
- (t (error "Unknown atomar expression ~S" form))))
-
-(defun js-compile-list (form)
- (let* ((name (car form))
- (args (cdr form))
- (js-form (js-get-special-form name)))
- (cond (js-form
- (apply js-form args))
-
- ((op-form-p form)
- (make-instance 'op-form
- :operator (js-convert-op-name (js-compile-to-symbol (first form)))
- :args (mapcar #'js-compile-to-expression (rest form))))
-
- ((method-call-p form)
- (make-instance 'method-call
- :method (js-compile-to-symbol (first form))
- :object (js-compile-to-expression (second form))
- :args (mapcar #'js-compile-to-expression (cddr form))))
-
- ((funcall-form-p form)
- (make-instance 'function-call
- :function (js-compile-to-expression (first form))
- :args (mapcar #'js-compile-to-expression (rest form))))
-
- (t (error "Unknown form ~S" form)))))
-
-(defun js-compile-to-expression (form)
- (let ((res (js-compile form)))
- (assert (typep res 'expression))
- res))
-
-(defun js-compile-to-symbol (form)
- (let ((res (js-compile form)))
- (when (typep res 'js-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 js-compile-to-statement (form)
- (let ((res (js-compile form)))
- (assert (typep res 'statement))
- res))
-
-(defun js-compile-to-body (form &key (indent ""))
- (let ((res (js-compile-to-statement form)))
- (if (typep res 'js-body)
- (progn (setf (b-indent res) indent)
- res)
- (make-instance 'js-body
- :indent indent
- :stmts (list res)))))
-
-(defmacro js (&rest body)
- `(js* '(progn ,@body)))
-
-(defmacro js* (&rest body)
- "Return the javascript string representing BODY.
-
-Body is evaluated."
- `(string-join
- (js-to-statement-strings (js-compile (list 'progn ,@body)) 0)
- (string #\Newline)))
-
-(defun js-to-string (expr)
- (string-join
- (js-to-statement-strings (js-compile expr) 0)
- (string #\Newline)))
-
-(defun js-to-line (expr)
- (string-join
- (js-to-statement-strings (js-compile expr) 0) " "))
-
-(defmacro js-file (&rest body)
- `(html
- (:princ
- (js ,@body))))
-
-(defmacro js-script (&rest body)
- `((:script :type "text/javascript")
- (:princ (format nil "~%// <![CDATA[~%"))
- (:princ (js ,@body))
- (:princ (format nil "~%// ]]>~%"))))
-
-(defmacro js-inline (&rest body)
- `(js-inline* '(progn ,@body)))
-
-(defmacro js-inline* (&rest body)
- "Just like JS-INLINE except that BODY is evaluated before being
-converted to javascript."
- `(concatenate 'string "javascript:"
- (string-join (js-to-statement-strings (js-compile (list 'progn ,@body)) 0) " ")))
-
-
+(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."))
+ (:documentation ""))
+
+(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))))
+
+;;;; compiler interface ;;;;
+(defgeneric compile-parenscript-form (compilation-environment form)
+ (:documentation "Compiles FORM, which is a ParenScript form, into a pre-text
+compilation object (the AST root). Subsequently TRANSLATE-AST can be called
+to convert the result to Javascript."))
+
+(defmethod compile-parenscript-form ((comp-env compilation-environment) form)
+ (setf form (expand-script-form 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 *compilation-environment* 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)))))
\ No newline at end of file
--- /dev/null
+c;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: reader.lisp,v 1.10 2004/02/20 07:23:42 yuji Exp $
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; * Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; * Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in
+;; the documentation and/or other materials provided with the
+;; distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package parenscript-reader)
+
+(defstruct (readtable (:predicate readtablep) (:copier nil))
+ (syntax (make-hash-table) :type hash-table)
+ (case :upcase :type (member :upcase :downcase :preserve :invert)))
+
+(defvar *read-base* '10)
+(defvar *read-default-float-format* 'single-float)
+(defvar *read-eval* 't)
+(defvar *read-suppress* 'nil)
+(defvar *readtable*)
+
+
+(defvar *sharp-equal-alist* nil)
+(defvar *consing-dot-allowed* nil)
+(defvar *consing-dot* (gensym))
+(defvar *preserve-whitespace-p* nil)
+(defvar *input-stream* nil)
+(defvar *backquote-level* 0)
+(defvar *dispatch-macro-char* nil)
+(defvar *standard-readtable*)
+
+(define-condition reader-error (parse-error)
+ ((format-control :reader reader-error-format-control :initarg :format-control)
+ (format-arguments :reader reader-error-format-arguments
+ :initarg :format-arguments)))
+
+(define-condition invalid-character-error (reader-error)
+ ((character :type character :reader invalid-character-error-character
+ :initarg :character))
+ (:report
+ (lambda (condition stream)
+ (format stream "Invalid character ~S is read."
+ (invalid-character-error-character condition)))))
+
+(defun reader-error (&optional format-control &rest format-arguments)
+ (error 'reader-error
+ :format-control format-control :format-arguments format-arguments))
+
+(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
+ (flet ((copy-syntax (src)
+ (let ((new (make-hash-table)))
+ (maphash
+ #'(lambda (k v)
+ (let ((plist (copy-list v)))
+ (setf (gethash k new) plist)
+ (when (getf plist :dispatch-table)
+ (let ((hash (make-hash-table)))
+ (maphash #'(lambda (k v) (setf (gethash k hash) v))
+ (getf plist :dispatch-table))
+ (setf (getf plist :dispatch-table) hash)))))
+ src)
+ new)))
+ (let ((from (or from-readtable *standard-readtable*)))
+ (if to-readtable
+ (prog1 to-readtable
+ (setf (readtable-syntax to-readtable)
+ (copy-syntax (readtable-syntax from)))
+ (setf (readtable-case to-readtable) (readtable-case from)))
+ (make-readtable :syntax (copy-syntax (readtable-syntax from))
+ :case (readtable-case from))))))
+
+(defun syntax-type (char &optional (readtable *readtable*))
+ (let ((plist (gethash char (readtable-syntax readtable))))
+ (getf plist :syntax :constituent)))
+
+(defun get-macro-character (char &optional (readtable *readtable*))
+ (unless readtable (setq readtable *standard-readtable*))
+ (let ((plist (gethash char (readtable-syntax readtable))))
+ (case (syntax-type char readtable)
+ (:terminating-macro-char (values (getf plist :macro-function) nil))
+ (:non-terminating-macro-char (values (getf plist :macro-function) t))
+ (t (values nil nil)))))
+
+(defun set-macro-character (char new-function
+ &optional non-terminating-p (readtable *readtable*))
+ (check-type char character)
+; (check-type new-function function-designator)
+ (when (null readtable)
+ (error "Standard readtable must not be changed."))
+ (let ((plist (gethash char (readtable-syntax readtable))))
+ (setf (getf plist :syntax) (if non-terminating-p
+ :non-terminating-macro-char
+ :terminating-macro-char)
+ (getf plist :macro-function) new-function
+ (gethash char (readtable-syntax readtable)) plist))
+ t)
+
+(defun get-dispatch-macro-character (disp-char sub-char
+ &optional (readtable *readtable*))
+ (unless readtable (setq readtable *standard-readtable*))
+ (unless (eq (get-macro-character disp-char readtable)
+ 'dispatch-macro-character)
+ (error "~S is not a dispatching macro character." disp-char))
+ (let* ((syntax-table (readtable-syntax readtable))
+ (dispatch-table (getf (gethash disp-char syntax-table) :dispatch-table))
+ (sub-char (char-upcase sub-char)))
+ (multiple-value-bind (value present-p) (gethash sub-char dispatch-table)
+ (cond
+ ((digit-char-p sub-char 10) nil)
+ (present-p value)
+ (t
+ #'(lambda (stream sub-char number)
+ (declare (ignore stream number))
+ (reader-error "No dispatch function defined for ~S." sub-char)))))))
+
+(defun set-dispatch-macro-character (disp-char sub-char new-function
+ &optional (readtable *readtable*))
+ (when (null readtable) (error "Standard readtable must not be changed."))
+ (unless (eq (get-macro-character disp-char readtable)
+ 'dispatch-macro-character)
+ (error "~S is not a dispatch character." disp-char))
+ (let* ((syntax-table (readtable-syntax readtable))
+ (dispatch-table (getf (gethash disp-char syntax-table) :dispatch-table))
+ (sub-char (char-upcase sub-char)))
+ (setf (gethash sub-char dispatch-table) new-function)
+ t))
+
+(defun make-dispatch-macro-character (char &optional non-terminating-p
+ (readtable *readtable*))
+ (when (null readtable) (error "Standard readtable must not be changed."))
+ (set-macro-character char 'dispatch-macro-character
+ non-terminating-p readtable)
+
+ (setf (getf (gethash char (readtable-syntax readtable)) :dispatch-table)
+ (make-hash-table))
+ t)
+
+(defun dispatch-macro-character (stream char)
+ (let ((n (when (digit-char-p (peek-char nil stream t nil t) 10)
+ (loop
+ with n = 0
+ for digit = (read-char stream t nil t)
+ do (setq n (+ (* n 10) (digit-char-p digit 10)))
+ while (digit-char-p (peek-char nil stream t nil t) 10)
+ finally (return n))))
+ (*dispatch-macro-char* char)
+ (sub-char (char-upcase (read-char stream t nil t))))
+ (funcall (get-dispatch-macro-character char sub-char) stream sub-char n)))
+
+(defun set-syntax-from-char (to-char from-char
+ &optional (to-readtable *readtable*)
+ (from-readtable *standard-readtable*))
+ (check-type to-char character)
+ (check-type from-char character)
+ (check-type to-readtable readtable)
+ (unless from-readtable (setq from-readtable *standard-readtable*))
+ (check-type from-readtable readtable)
+ (let ((plist (copy-list (gethash from-char
+ (readtable-syntax from-readtable)))))
+ (when (getf plist :dispatch-table)
+ (let ((hash (make-hash-table)))
+ (maphash #'(lambda (k v) (setf (gethash k hash) v))
+ (getf plist :dispatch-table))
+ (setf (getf plist :dispatch-table) hash)))
+ (setf (gethash to-char (readtable-syntax to-readtable)) plist)
+ t))
+
+;; (defmacro with-standard-io-syntax (&rest forms)
+;; `(let ((*package* (find-package "CL-USER"))
+;; (*print-array* t)
+;; (*print-base* 10)
+;; (*print-case* :upcase)
+;; (*print-circle* nil)
+;; (*print-escape* t)
+;; (*print-gensym* t)
+;; (*print-length* nil)
+;; (*print-level* nil)
+;; (*print-lines* nil)
+;; (*print-miser-width* nil)
+;; ;;(*print-pprint-dispatch* *standard-print-pprint-dispatch*)
+;; (*print-pretty* nil)
+;; (*print-radix* nil)
+;; (*print-readably* t)
+;; (*print-right-margin* nil)
+;; (*read-base* 10)
+;; (*read-default-float-format* 'single-float)
+;; (*read-eval* t)
+;; (*read-suppress* nil)
+;; (*readtable* (copy-readtable nil)))
+;; ,@forms))
+
+
+(defun read-preserving-whitespace (&optional (input-stream *standard-input*)
+ (eof-error-p t) eof-value recursive-p)
+ (let ((*preserve-whitespace-p* (if recursive-p *preserve-whitespace-p* t)))
+ (declare (special *preserve-whitespace-p*))
+ (read-lisp-object input-stream eof-error-p eof-value recursive-p)))
+
+(defun read (&optional (input-stream *standard-input*)
+ (eof-error-p t) eof-value recursive-p)
+ (let ((*preserve-whitespace-p* (when recursive-p *preserve-whitespace-p*)))
+ (declare (special *preserve-whitespace-p*))
+ (read-lisp-object input-stream eof-error-p eof-value recursive-p)))
+
+(defun read-from-string (string &optional (eof-error-p t) eof-value
+ &key (start 0) end preserve-whitespace)
+ (let ((index nil))
+ (values (with-input-from-string (stream string :index index
+ :start start :end end)
+ (funcall (if preserve-whitespace
+ #'read-preserving-whitespace
+ #'read)
+ stream eof-error-p eof-value))
+ index)))
+
+(defun make-str (chars)
+ (make-array (length chars) :element-type 'character :initial-contents chars))
+
+(defun read-list (char &optional (stream *standard-input*) recursive-p
+ &key allow-consing-dot)
+ (let ((*sharp-equal-alist* (when recursive-p *sharp-equal-alist*))
+ (*consing-dot-allowed* allow-consing-dot)
+ c stack values)
+ (loop
+ (setq c (peek-char t stream t nil t))
+ (when (char= char c)
+ (when (eq (first stack) *consing-dot*)
+ (error "Nothing appears after . in list."))
+ (read-char stream t nil t)
+ (if (eq (second stack) *consing-dot*)
+ (return (nreconc (cddr stack) (first stack)))
+ (return (nreverse stack))))
+ (when (setq values (multiple-value-list (lisp-object? stream t nil t)))
+ (if (eq (second stack) *consing-dot*)
+ (error "More than one object follows . in list.")
+ (push (car values) stack))))))
+
+(defun read-delimited-list (char &optional (stream *standard-input*) recursive-p)
+ (let ((list (read-list char stream recursive-p)))
+ (unless *read-suppress* list)))
+
+(defun lisp-object? (stream eof-error-p eof-value recursive-p)
+ (loop
+ (let* ((c (read-char stream eof-error-p eof-value recursive-p)))
+ (when (and (not eof-error-p) (eq c eof-value)) (return eof-value))
+ (ecase (syntax-type c)
+ (:invalid (error 'invalid-character-error :character c))
+ (:whitespace 'skip)
+ ((:single-escape :multiple-escape :constituent)
+ (return (read-number-or-symbol stream c)))
+ ((:terminating-macro-char :non-terminating-macro-char)
+ (return (funcall (get-macro-character c) stream c)))))))
+
+(defun read-lisp-object (stream eof-error-p eof-value recursive-p)
+ (let ((*sharp-equal-alist* (when recursive-p *sharp-equal-alist*)))
+ (loop
+ (let ((values (multiple-value-list (lisp-object? stream
+ eof-error-p eof-value
+ recursive-p))))
+ (when values (return (unless *read-suppress* (car values))))))))
+
+(defun read-ch () (read-char *input-stream* nil nil t))
+(defun read-ch-or-die () (read-char *input-stream* t nil t))
+(defun unread-ch (c) (unread-char c *input-stream*))
+
+(defun collect-escaped-lexemes (c)
+ (ecase (syntax-type c)
+ (:invalid (error 'invalid-character-error :character c))
+ (:multiple-escape nil)
+ (:single-escape (cons (read-ch-or-die)
+ (collect-escaped-lexemes (read-ch-or-die))))
+ ((:constituent
+ :whitespace :terminating-macro-char :non-terminating-macro-char)
+ (cons c (collect-escaped-lexemes (read-ch-or-die))))))
+
+(defun collect-lexemes (c &optional (stream *input-stream*))
+ (let ((*input-stream* stream))
+ (when c
+ (ecase (syntax-type c)
+ (:invalid (error 'invalid-character-error :character c))
+ (:whitespace (when *preserve-whitespace-p* (unread-ch c)))
+ (:terminating-macro-char (unread-ch c))
+ (:multiple-escape (cons (collect-escaped-lexemes (read-ch-or-die))
+ (collect-lexemes (read-ch))))
+ (:single-escape (cons (list (read-ch-or-die))
+ (collect-lexemes (read-ch))))
+ ((:constituent :non-terminating-macro-char)
+ (cons c (collect-lexemes (read-ch))))))))
+
+;; integer ::= [sign] decimal-digit+ decimal-point
+;; | [sign] digit+
+;; ratio ::= [sign] {digit}+ slash {digit}+
+;; float ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
+;; | [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
+;; exponent ::= exponent-marker [sign] {digit}+
+
+(defun construct-number (chars)
+ (labels ((sign ()
+ (let ((c (and chars (car chars))))
+ (cond
+ ((eql c #\-) (pop chars) -1)
+ ((eql c #\+) (pop chars) +1)
+ (t +1))))
+ (digit* (&optional (base *read-base*))
+ (let ((pos (or (position-if-not #'(lambda (d) (digit-char-p d base))
+ chars)
+ (length chars))))
+ (prog1 (subseq chars 0 pos)
+ (setq chars (subseq chars pos)))))
+ (int? (sign digits &optional (base *read-base*))
+ (when (and digits
+ (every #'(lambda (d) (digit-char-p d base)) digits))
+ (* sign (reduce #'(lambda (a b) (+ (* base a) b))
+ (mapcar #'(lambda (d) (digit-char-p d base))
+ digits)))))
+ (float? (sign)
+ (let* ((int (digit* 10))
+ (fraction (when (eql (car chars) #\.)
+ (pop chars) (digit* 10)))
+ (exp-marker (when (and chars
+ (find (char-upcase (car chars))
+ '(#\D #\E #\F #\L #\S)))
+ (char-upcase (pop chars))))
+ (exp-sign (and exp-marker (sign)))
+ (exp-digits (and exp-sign (digit*))))
+ (when (and (null chars)
+ (or fraction (and int exp-marker exp-digits)))
+ (float (* (int? sign (append int fraction) 10)
+ (expt 10 (- (or (int? exp-sign exp-digits 10) 0)
+ (length fraction))))
+ (ecase (or exp-marker *read-default-float-format*)
+ (#\E 1.0e0)
+ ((#\D double-float) 1.0d0)
+ ((#\F single-float) 1.0f0)
+ ((#\L long-float) 1.0l0)
+ ((#\S short-float) 1.0s0)))))))
+ (let ((sign (sign))
+ pos numerator denominator)
+ (when chars
+ (or
+ ;; [sign] digit+
+ (int? sign chars)
+ ;; [sign] decimal-digit+ decimal-point
+ (and (eql (car (last chars)) #\.) (int? sign (butlast chars) 10))
+ ;; [sign] {digit}+ slash {digit}+
+ (and (setq pos (position #\/ chars))
+ (setq numerator (int? sign (subseq chars 0 pos)))
+ (setq denominator (int? 1 (subseq chars (1+ pos))))
+ (not (zerop denominator))
+ (/ numerator denominator))
+ ;; [sign] {decimal-digit}* decimal-point {decimal-digit}+ [exponent]
+ ;; [sign] {decimal-digit}+ [decimal-point {decimal-digit}*] exponent
+ (float? sign))))))
+
+(defun ensure-external-symbol (name package)
+ (multiple-value-bind (symbol status) (find-script-symbol name package)
+ (unless (eq status :external)
+ (cerror (if (null status)
+ "Intern and export script symbol ~S in package ~S."
+ "Export script symbol ~S in package ~S.")
+ "There is no external symbol by the name of ~S in script package ~S."
+ name package)
+ (script-export (setq symbol (script-intern name package)) package))
+ symbol))
+
+(defvar *intern-package-prefixes* t)
+
+(defun construct-symbol (lexemes &key uninterned-symbol-wanted)
+ (labels ((up (x) (if (listp x) (copy-list x) (list (char-upcase x))))
+ (down (x) (if (listp x) (copy-list x) (list (char-downcase x))))
+ (chars (lexemes)
+ (ecase (readtable-case *readtable*)
+ (:upcase (mapcan #'up lexemes))
+ (:downcase (mapcan #'down lexemes))
+ (:invert
+ (let ((unescaped (remove-if-not #'alpha-char-p
+ (remove-if #'listp lexemes))))
+ (mapcan (cond
+ ((every #'upper-case-p unescaped) #'down)
+ ((every #'lower-case-p unescaped) #'up)
+ (t #'(lambda (x)
+ (if (listp x) (copy-list x) (list x)))))
+ lexemes)))
+ (:preserve (mapcan #'(lambda (x)
+ (if (listp x) (copy-list x) (list x)))
+ lexemes))))
+ (name (lexemes)
+ (when (and (find #\: lexemes) t)
+;; (not *intern-package-prefixes*))
+ (error "Too many package markers."))
+ (make-str (chars lexemes))))
+ (let* ((pos (position #\: lexemes))
+ (external-p (and pos (not (eql (nth (1+ pos) lexemes) #\:))))
+ (package (when pos (name (subseq lexemes 0 pos))))
+ (script-package (find-script-package *compilation-environment* package))
+ (name (name (subseq lexemes (if pos (+ pos (if external-p 1 2)) 0)))))
+ (values (cond
+ (*intern-package-prefixes*
+ (let ((str (if package
+ (concatenate 'string package ":" name)
+ name)))
+
+ (if uninterned-symbol-wanted
+ str
+ (intern str))))
+ (uninterned-symbol-wanted
+ (if package
+ (reader-error)
+ (make-symbol name)))
+ (external-p
+ (ensure-external-symbol name package))
+ (t (script-intern name
+ (or package
+ (current-package *compilation-environment*)))))))))
+
+(defun read-number-or-symbol (stream c)
+ (let ((lexemes (collect-lexemes c stream)))
+ (assert lexemes)
+ (unless *read-suppress*
+ (cond
+ ((and lexemes (every #'(lambda (x) (eql x #\.)) lexemes))
+ (when (rest lexemes)
+ (reader-error "Tokens consisting of only dots are invalid."))
+ (when (not *consing-dot-allowed*)
+ (reader-error "Consing dot is not allowed."))
+ *consing-dot*)
+ (t
+ (or (and (every #'characterp lexemes) (construct-number lexemes))
+ (construct-symbol lexemes)))))))
+
+
+;; backquote
+(defmacro define-constant (name value &optional doc)
+ `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
+ ,@(when doc (list doc))))
+(define-constant backquote (gensym))
+(define-constant backquote-comma (gensym))
+(define-constant backquote-comma-at (gensym))
+(define-constant backquote-comma-dot (gensym))
+
+(defun backquoted-expression-type (exp)
+ (if (atom exp)
+ :normal
+ (cond
+ ((eq (first exp) backquote-comma) :comma)
+ ((eq (first exp) backquote-comma-at) :comma-at)
+ ((eq (first exp) backquote-comma-dot) :comma-dot)
+ (t :normal))))
+
+(defmacro backquote (object)
+ (if (atom object)
+ (if (simple-vector-p object)
+ (list 'apply #'vector (list backquote (concatenate 'list object)))
+ (list 'quote object))
+ (let* ((list (copy-list object))
+ (last (loop for x = list then (cdr x)
+ until (or (atom (cdr x))
+ (find (cadr x) (list backquote
+ backquote-comma
+ backquote-comma-at
+ backquote-comma-dot)))
+ finally (return (prog1 (cdr x) (setf (cdr x) nil)))))
+ (types (mapcar #'backquoted-expression-type list)))
+ (append
+ (cons (if (notany #'(lambda (x) (eq x :comma-at)) types) 'nconc 'append)
+ (mapcar #'(lambda (x)
+ (ecase (backquoted-expression-type x)
+ (:normal (list 'list (list 'backquote x)))
+ (:comma (list 'list x))
+ ((:comma-at :comma-dot) x)))
+ list))
+ (list (ecase (backquoted-expression-type last)
+ (:normal (list 'quote last))
+ (:comma last)
+ (:comma-at (error ",@ after dot"))
+ (:comma-dot (error ",. after dot"))))))))
+
+(defmacro backquote-comma (obj) obj)
+(setf (macro-function backquote) (macro-function 'backquote))
+(setf (macro-function backquote-comma) (macro-function 'backquote-comma))
+(setf (macro-function backquote-comma-at) (macro-function 'backquote-comma))
+(setf (macro-function backquote-comma-dot) (macro-function 'backquote-comma))
+
+
+(defun read-comma-form (stream c)
+ (declare (ignore c))
+ (unless (> *backquote-level* 0)
+ (error "Comma must be used in a backquoted expression."))
+ (let ((*backquote-level* (1- *backquote-level*)))
+ (case (peek-char t stream t nil t)
+ (#\@ (read-char stream t nil t)
+ (list backquote-comma-at (read stream t nil t)))
+ (#\. (read-char stream t nil t)
+ (list backquote-comma-dot (read stream t nil t)))
+ (t (list backquote-comma (read stream t nil t))))))
+
+(defun read-backquoted-expression (stream c)
+ (declare (ignore c))
+ (let ((*backquote-level* (1+ *backquote-level*)))
+ (list backquote (read stream t nil t))))
+
+
+(defun sharp-backslash (stream sub-char n)
+ (declare (ignore n))
+ (let* ((lexemes (collect-lexemes sub-char stream))
+ (str (make-str (mapcan #'(lambda (x)
+ (if (listp x) (copy-list x) (list x)))
+ lexemes))))
+ (unless *read-suppress*
+ (cond
+ ((= 1 (length str)) (char str 0))
+ ((name-char str))
+ (t (reader-error "Unrecognized character name: ~S" str))))))
+
+(defun sharp-single-quote (stream sub-char n)
+ (declare (ignore sub-char n))
+ `(function ,(read stream t nil t)))
+
+(defun sharp-left-parenthesis (stream sub-char n)
+ (declare (ignore sub-char))
+ (let ((list (read-delimited-list #\) stream t)))
+ (unless *read-suppress*
+ (when (and n (> (length list) n))
+ (reader-error "vector is longer than specified length #~A*~A."
+ n list))
+ (apply #'vector
+ (if (and n (< (length list) n))
+ (append list (make-list (- n (length list))
+ :initial-element (car (last list))))
+ list)))))
+
+(defun sharp-asterisk (stream sub-char n)
+ (declare (ignore sub-char))
+ (let* ((*input-stream* stream)
+ (lexemes (collect-lexemes (read-ch)))
+ (bits (mapcar #'(lambda (d)
+ (unless (characterp d)
+ (error "Binary digit must be given"))
+ (digit-char-p d 2)) lexemes)))
+ (unless *read-suppress*
+ (unless (every #'(lambda (d) (digit-char-p d 2)) lexemes)
+ (reader-error "Illegal bit vector format."))
+ (when (and n (> (length bits) n))
+ (reader-error "Bit vector is longer than specified length #~A*~A."
+ n (make-str lexemes)))
+ (when (and n (> n 0) (zerop (length bits)))
+ (reader-error
+ "At least one bit must be given for non-zero #* bit-vectors."))
+ (make-array (or n (length bits)) :element-type 'bit
+ :initial-contents
+ (if (and n (< (length bits) n))
+ (append bits
+ (make-list (- n (length bits))
+ :initial-element (car (last bits))))
+ bits)))))
+
+(defun sharp-colon (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let* ((*input-stream* stream)
+ (lexemes (collect-lexemes (read-ch))))
+ (unless *read-suppress*
+ (construct-symbol lexemes :uninterned-symbol-wanted t))))
+
+(defun sharp-dot (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let ((object (read stream t nil t)))
+ (unless *read-suppress*
+ (unless *read-eval*
+ (reader-error "Attempt to read #. while *READ-EVAL* is bound to NIL."))
+ (eval object))))
+
+(defun sharp-b (stream sub-char n)
+ (declare (ignore n))
+ (sharp-r stream sub-char 2))
+
+(defun sharp-o (stream sub-char n)
+ (declare (ignore n))
+ (sharp-r stream sub-char 8))
+
+(defun sharp-x (stream sub-char n)
+ (declare (ignore n))
+ (sharp-r stream sub-char 16))
+
+(defun sharp-r (stream sub-char n)
+ (cond
+ (*read-suppress* (read stream t nil t))
+ ((not n) (reader-error "Radix missing in #R."))
+ ((not (<= 2 n 36)) (reader-error "Illegal radix for #R: ~D." n))
+ (t (let ((rational (let ((*read-base* n)) (read stream t nil t))))
+ (unless (typep rational 'rational)
+ (reader-error "#~A (base ~D) value is not a rational: ~S."
+ sub-char n rational))
+ rational))))
+
+
+(defun sharp-c (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let ((pair (read stream t nil t)))
+ (unless *read-suppress*
+ (unless (and (listp pair) (= (length pair) 2))
+ (reader-error "Illegal complex number format: #C~S" pair))
+ (complex (first pair) (second pair)))))
+
+(defun sharp-a (stream sub-char rank)
+ (declare (ignore sub-char))
+ (cond
+ (*read-suppress* (read stream t nil t))
+ ((null rank)
+ (reader-error "Rank for #A notation is missing."))
+ (t (let* ((contents (read stream t nil t))
+ (dimensions (loop repeat rank
+ for x = contents then (first x)
+ collect (length x))))
+ (make-array dimensions :initial-contents contents)))))
+
+
+(defun find-default-constructor (name)
+ (declare (ignore name)))
+
+(defun sharp-s (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let ((structure-spec (read stream t nil t)))
+ (unless *read-suppress*
+ (unless (listp structure-spec)
+ (reader-error "Non list follows #S."))
+ (unless (symbolp (first structure-spec))
+ (reader-error "Structure type is not a symbol: ~S" (car structure-spec)))
+ (let* ((name (first structure-spec))
+ (plist (loop
+ for list on (rest structure-spec) by #'cddr
+ append (list (intern (string (first list)) "KEYWORD")
+ (second list))))
+ (class (find-class name nil)))
+ (unless (typep class 'structure-class)
+ (reader-error "~S is not a defined structure type." name))
+ (let ((constructor (find-default-constructor name)))
+ (apply constructor plist))))))
+
+(defun sharp-p (stream sub-char n)
+ (declare (ignore sub-char n))
+ (let ((namestring (read stream t nil t)))
+ (unless *read-suppress* (parse-namestring namestring))))
+
+(defun container-subst (new old tree
+ &optional (done (make-hash-table :test 'eq)))
+ (cond
+ ((eq tree old) new)
+ ((gethash tree done) tree)
+ (t (setf (gethash tree done) t)
+ (typecase tree
+ (null nil)
+ (cons (setf (car tree) (container-subst new old (car tree) done)
+ (cdr tree) (container-subst new old (cdr tree) done))
+ tree)
+ (array (loop for i below (array-total-size tree)
+ do (setf (row-major-aref tree i)
+ (container-subst new old
+ (row-major-aref tree i) done)))
+ tree)
+ (t tree)))))
+
+(defun sharp-equal (stream sub-char n)
+ (declare (ignore sub-char))
+ (if *read-suppress*
+ (values)
+ (let* ((this (gensym))
+ (object (let ((*sharp-equal-alist* (acons n this
+ *sharp-equal-alist*)))
+ (read stream t nil t)))
+ (assoc (assoc n *sharp-equal-alist*)))
+ (when (null n)
+ (reader-error "Missing label number for #=."))
+ (when assoc
+ (reader-error "#~D= is already defined." n))
+ (setq *sharp-equal-alist* (acons n object *sharp-equal-alist*))
+ (when (eq object this)
+ (reader-error "need to tag something more than just #~D#." n))
+ (container-subst object this object))))
+
+(defun sharp-sharp (stream sub-char n)
+ (declare (ignore sub-char stream))
+ (unless *read-suppress*
+ (unless n (reader-error "Label is missing for ##."))
+ (let ((assoc (assoc n *sharp-equal-alist*)))
+ (unless assoc
+ (reader-error "No object labeld ~D is defined." n))
+ (cdr assoc))))
+
+(defun featurep (x)
+ (if (atom x)
+ (member x *features*)
+ (ecase (first x)
+ (:not (not (featurep (second x))))
+ (:and (every #'featurep (rest x)))
+ (:or (some #'featurep (rest x))))))
+
+(defun read-feature-test (stream)
+ (let ((*package* (or (find-package "KEYWORD")
+ (error "KEYWORD package not found."))))
+ (read stream t nil t)))
+
+(defun sharp-plus (stream sub-char n)
+ (declare (ignore sub-char n))
+ (if (featurep (read-feature-test stream))
+ (read stream t nil t)
+ (let ((*read-suppress* t)) (read stream t nil t) (values))))
+
+(defun sharp-minus (stream sub-char n)
+ (declare (ignore sub-char n))
+ (if (not (featurep (read-feature-test stream)))
+ (read stream t nil t)
+ (let ((*read-suppress* t)) (read stream t nil t) (values))))
+
+(defun sharp-vertical-bar (stream sub-char n)
+ (declare (ignore sub-char n))
+ (loop for c = (read-char stream t nil t)
+ if (and (char= c #\#) (char= (read-char stream t nil t) #\|))
+ do (sharp-vertical-bar stream #\| nil)
+ until (and (char= c #\|) (char= (read-char stream t nil t) #\#)))
+ (values))
+
+
+(defvar *standard-syntax-table*
+ (let ((table (make-hash-table)))
+ (mapc #'(lambda (x)
+ (let ((syntax (first x))
+ (chars (rest x)))
+ (dolist (c chars)
+ (setf (gethash c table) `(:syntax ,syntax)))))
+ '((:whitespace #\Tab #\Newline #\Linefeed #\Page #\Return #\Space)
+ (:single-escape #\\)
+ (:multiple-escape #\|)))
+ table))
+
+(setq *standard-readtable* (make-readtable :syntax *standard-syntax-table*))
+
+(set-macro-character #\` 'read-backquoted-expression nil *standard-readtable*)
+(set-macro-character #\, 'read-comma-form nil *standard-readtable*)
+
+(set-macro-character #\( #'(lambda (stream char)
+ (declare (ignore char))
+ (read-list #\) stream t :allow-consing-dot t))
+ nil *standard-readtable*)
+
+(set-macro-character #\) #'(lambda (stream char)
+ (declare (ignore stream char))
+ (error "Unmatched close parenthesis."))
+ nil *standard-readtable*)
+
+(set-macro-character #\' #'(lambda (stream char)
+ (declare (ignore char))
+ `(quote ,(read stream t nil t)))
+ nil *standard-readtable*)
+
+(set-macro-character #\; #'(lambda (stream char)
+ (declare (ignore char))
+ (loop
+ for c = (read-char stream nil nil t)
+ until (or (null c) (eql c #\Newline)))
+ (values))
+ nil *standard-readtable*)
+
+(set-macro-character #\" #'(lambda (stream char)
+ (declare (ignore char))
+ (loop
+ for c = (read-char stream t nil t)
+ until (char= c #\")
+ if (eq :single-escape (syntax-type c))
+ collect (read-char stream t nil t) into chars
+ else
+ collect c into chars
+ finally
+ (return (make-array (length chars)
+ :element-type 'character
+ :initial-contents chars))))
+ nil *standard-readtable*)
+
+
+(make-dispatch-macro-character #\# t *standard-readtable*)
+(mapc
+ #'(lambda (pair)
+ (set-dispatch-macro-character #\# (first pair) (second pair)
+ *standard-readtable*))
+ '((#\\ sharp-backslash) (#\' sharp-single-quote) (#\( sharp-left-parenthesis)
+ (#\* sharp-asterisk) (#\: sharp-colon) (#\. sharp-dot) (#\b sharp-b)
+ (#\o sharp-o) (#\x sharp-x) (#\r sharp-r) (#\c sharp-c) (#\a sharp-a)
+ (#\s sharp-s) (#\p sharp-p) (#\= sharp-equal) (#\# sharp-sharp)
+ (#\+ sharp-plus) (#\- sharp-minus) (#\| sharp-vertical-bar)))
+
+(setq *readtable* (copy-readtable nil))
(in-package :parenscript)
+(defgeneric script-equal (compiled-ast-node1 compiled-ast-node2)
+ (:documentation "Determines if the AST nodes are equal."))
+
+(defgeneric expression-precedence (expression)
+ (:documentation "Returns the precedence of an enscript-javascript expression"))
+
;;; AST node equality
-(defmethod js-equal ((obj1 list) (obj2 list))
+(defmethod script-equal ((obj1 list) (obj2 list))
(and (= (length obj1) (length obj2))
- (every #'js-equal obj1 obj2)))
+ (every #'script-equal obj1 obj2)))
-(defmethod js-equal ((obj1 t) (obj2 t))
+(defmethod script-equal ((obj1 t) (obj2 t))
(equal obj1 obj2))
-(defmacro defjsclass (name superclasses slots &rest class-options)
+(defmacro defscriptclass (name superclasses slots &rest class-options)
(let ((slot-names (mapcar #'(lambda (slot) (if (atom slot) slot (first slot))) slots)))
`(progn
(defclass ,name ,superclasses
,slots ,@class-options)
- (defmethod js-equal ((obj1 ,name) (obj2 ,name))
+ (defmethod script-equal ((obj1 ,name) (obj2 ,name))
(every #'(lambda (slot)
- (js-equal (slot-value obj1 slot)
+ (script-equal (slot-value obj1 slot)
(slot-value obj2 slot)))
',slot-names)))))
(:documentation "A Javascript entity with a value."))
;;; array literals
-(defjsclass array-literal (expression)
+(defscriptclass array-literal (expression)
((values :initarg :values :accessor array-values)))
-(defjsclass js-aref (expression)
+(defscriptclass script-aref (expression)
((array :initarg :array
:accessor aref-array)
(index :initarg :index
:accessor aref-index)))
;;; object literals (maps and hash-tables)
-(defjsclass object-literal (expression)
+(defscriptclass object-literal (expression)
((values :initarg :values :accessor object-values)))
;;; string literals
-(defjsclass string-literal (expression)
+(defscriptclass string-literal (expression)
(value))
;;; number literals
-(defjsclass number-literal (expression)
+(defscriptclass number-literal (expression)
(value))
;;; variables
-(defjsclass js-variable (expression)
+(defscriptclass script-variable (expression)
(value))
;;; quote
-(defjsclass js-quote (expression)
+(defscriptclass script-quote (expression)
())
;;; operators
-(defjsclass op-form (expression)
+(defscriptclass op-form (expression)
((operator :initarg :operator :accessor operator)
(args :initarg :args :accessor op-args)))
op)
*op-precedence-hash*)))
-(defjsclass one-op (expression)
+(defscriptclass one-op (expression)
((pre-p :initarg :pre-p
:initform nil
:accessor one-op-pre-p)
:accessor one-op)))
;;; function calls
-(defjsclass function-call (expression)
+(defscriptclass function-call (expression)
((function :initarg :function :accessor f-function)
(args :initarg :args :accessor f-args)))
-(defjsclass method-call (expression)
+(defscriptclass method-call (expression)
((method :initarg :method :accessor m-method)
(object :initarg :object :accessor m-object)
(args :initarg :args :accessor m-args)))
;;; body forms
-(defjsclass js-body (expression)
- ((stmts :initarg :stmts :accessor b-stmts)
+(defscriptclass script-body (expression)
+ ((statements :initarg :statements :accessor b-statements)
(indent :initarg :indent :initform "" :accessor b-indent)))
-(defmethod initialize-instance :after ((body js-body) &rest initargs)
+(defmethod initialize-instance :after ((body script-body) &rest initargs)
(declare (ignore initargs))
- (let* ((stmts (b-stmts body))
- (last (last stmts))
+ (let* ((statements (b-statements body))
+ (last (last statements))
(last-stmt (car last)))
- (when (typep last-stmt 'js-body)
- (setf (b-stmts body)
- (nconc (butlast stmts)
- (b-stmts last-stmt))))))
+ (when (typep last-stmt 'script-body)
+ (setf (b-statements body)
+ (nconc (butlast statements)
+ (b-statements last-stmt))))))
-(defjsclass js-sub-body (js-body)
- (stmts indent))
+(defscriptclass script-sub-body (script-body)
+ (statements indent))
;;; function definition
-(defjsclass js-lambda (expression)
+(defscriptclass script-lambda (expression)
((args :initarg :args :accessor lambda-args)
(body :initarg :body :accessor lambda-body)))
-(defjsclass js-defun (js-lambda)
+(defscriptclass script-defun (script-lambda)
((name :initarg :name :accessor defun-name)))
;;; object creation
-(defjsclass js-object (expression)
+(defscriptclass script-object (expression)
((slots :initarg :slots
:accessor o-slots)))
-(defjsclass js-slot-value (expression)
+(defscriptclass script-slot-value (expression)
((object :initarg :object
:accessor sv-object)
(slot :initarg :slot
:accessor sv-slot)))
;;; cond
-(defjsclass js-cond (expression)
+(defscriptclass script-cond (expression)
((tests :initarg :tests
:accessor cond-tests)
(bodies :initarg :bodies
:accessor cond-bodies)))
-(defjsclass js-if (expression)
+(defscriptclass script-if (expression)
((test :initarg :test
:accessor if-test)
(then :initarg :then
(else :initarg :else
:accessor if-else)))
-(defmethod initialize-instance :after ((if js-if) &rest initargs)
+(defmethod initialize-instance :after ((if script-if) &rest initargs)
(declare (ignore initargs))
(when (and (if-then if)
- (typep (if-then if) 'js-sub-body))
- (change-class (if-then if) 'js-body))
+ (typep (if-then if) 'script-sub-body))
+ (change-class (if-then if) 'script-body))
(when (and (if-else if)
- (typep (if-else if) 'js-sub-body))
- (change-class (if-else if) 'js-body)))
+ (typep (if-else if) 'script-sub-body))
+ (change-class (if-else if) 'script-body)))
;;; switch
-(defjsclass js-switch (statement)
+(defscriptclass script-switch (statement)
((value :initarg :value :accessor case-value)
(clauses :initarg :clauses :accessor case-clauses)))
;;; assignment
-(defjsclass js-setf (expression)
+(defscriptclass script-setf (expression)
((lhs :initarg :lhs :accessor setf-lhs)
(rhsides :initarg :rhsides :accessor setf-rhsides)))
;;; defvar
-(defjsclass js-defvar (statement)
+(defscriptclass script-defvar (statement)
((names :initarg :names :accessor var-names)
(value :initarg :value :accessor var-value)))
;;; iteration
-(defjsclass js-for (statement)
+(defscriptclass script-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)))
-(defjsclass for-each (statement)
+(defscriptclass for-each (statement)
((name :initarg :name :accessor fe-name)
(value :initarg :value :accessor fe-value)
(body :initarg :body :accessor fe-body)))
-(defjsclass js-while (statement)
+(defscriptclass script-while (statement)
((check :initarg :check :accessor while-check)
(body :initarg :body :accessor while-body)))
;;; with
-(defjsclass js-with (statement)
+(defscriptclass script-with (statement)
((obj :initarg :obj :accessor with-obj)
(body :initarg :body :accessor with-body)))
;;; try-catch
-(defjsclass js-try (statement)
+(defscriptclass script-try (statement)
((body :initarg :body :accessor try-body)
(catch :initarg :catch :accessor try-catch)
(finally :initarg :finally :accessor try-finally)))
;;; regular expressions
-(defjsclass regex (expression)
+(defscriptclass regex (expression)
(value))
;;; conditional compilation
-(defjsclass cc-if ()
+(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
-(defjsclass js-instanceof (expression)
+(defscriptclass script-instanceof (expression)
((value)
(type :initarg :type)))
-(defmacro define-js-single-op (name &optional (superclass 'expression))
- (let ((js-name (intern (concatenate 'string "JS-" (symbol-name name)) #.*package*)))
+(defmacro define-script-single-op (name &optional (superclass 'expression))
+ (let ((script-name (intern (concatenate 'string "SCRIPT-" (symbol-name name)) #.*package*)))
`(progn
- (defjsclass ,js-name (,superclass)
+ (defscriptclass ,script-name (,superclass)
(value)))))
-(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)
+(define-script-single-op return statement)
+(define-script-single-op throw statement)
+(define-script-single-op delete)
+(define-script-single-op void)
+(define-script-single-op typeof)
+(define-script-single-op new)
+;;; for script-package stuff
+(defscriptclass blank-statement (statement)
+ ()
+ (:documentation "An empty statement that does nothing."))
\ No newline at end of file
("u0080" . ,(code-char 128)) ;;Character over 127. Actually valid, parenscript escapes them to be sure.
("uABCD" . ,(code-char #xabcd)))));; Really above ascii.
(loop for (js-escape . lisp-char) in escapes
- for generated = (js-to-string `(let ((x , (format nil "hello~ahi" lisp-char)))))
- for wanted = (format nil "{
+ for generated = (compile-script `(let ((x , (format nil "hello~ahi" lisp-char)))))
+ for wanted = (format nil "{
var x = 'hello\\~ahi';
}" js-escape)
- do (is (string= generated wanted)))))
-
+ do (is (string= generated wanted)))))
+
(test-ps-js complicated-symbol-name1
grid-rows[foo].bar
"gridRows[foo].bar")
(in-package :cl-user)
-(defpackage :js-test
+(defpackage :parenscript-test
+ (:nicknames :js-test)
(:use :common-lisp :js :5am)
(:shadowing-import-from :js :!)
(:export #:run-tests
(setf js::*var-counter* 0)
;; is-macro expands its argument again when reporting failures, so
;; the reported temporary js-variables get wrong if we don't evalute first.
- (let ((generated-code (js-to-string ',parenscript))
+ (let ((generated-code (compile-script ',parenscript))
(js-code ,javascript))
(is (string= (normalize-js-code generated-code)
(normalize-js-code js-code))))))
HCoop / clinton / parenscript.git / commitdiff