X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=9fd5cbaadb73e7cc09bbbb7a7d9df09d4cf899af;hb=a492f6e21f55974a21f2f8ec5ccf105fb3f1a832;hp=53449f22d63fd8f04a9fbadc86805f8bf2c1d7dc;hpb=923e480ffde20c39b2d1dab63308b89f2d9150a2;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 53449f2..9fd5cba 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -23,46 +23,39 @@ ;;; language to the compiler to be able to run. #+ecmalisp -(js-eval "function pv (x) { return x ; }") - -#+ecmalisp -(js-eval " -function mv(){ - var r = []; - r['multiple-value'] = true; - for (var i=0; i")))) + (concat "#")) + (t + (concat "#")))) (defun write-line (x) (write-string x) @@ -821,6 +1010,7 @@ function mv(){ x)) + ;;;; Reader ;;; The Lisp reader, parse strings and return Lisp objects. The main @@ -836,7 +1026,7 @@ function mv(){ (defun %read-char (stream) (and (< (cdr stream) (length (car stream))) (prog1 (char (car stream) (cdr stream)) - (setcdr stream (1+ (cdr stream)))))) + (rplacd stream (1+ (cdr stream)))))) (defun whitespacep (ch) (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab))) @@ -956,14 +1146,58 @@ function mv(){ (incf index)) (setq name (subseq string index)))) ;; Canonalize symbol name and package - (setq name (string-upcase name)) + (when (not (eq package "JS")) + (setq name (string-upcase name))) (setq package (find-package package)) ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an ;; external symbol from PACKAGE. - (if (or internalp (eq package (find-package "KEYWORD"))) + (if (or internalp + (eq package (find-package "KEYWORD")) + (eq package (find-package "JS"))) (intern name package) (find-symbol name package)))) + +(defun !parse-integer (string junk-allow) + (block nil + (let ((value 0) + (index 0) + (size (length string)) + (sign 1)) + ;; Leading whitespace + (while (and (< index size) + (whitespacep (char string index))) + (incf index)) + (unless (< index size) (return (values nil 0))) + ;; Optional sign + (case (char string 0) + (#\+ (incf index)) + (#\- (setq sign -1) + (incf index))) + ;; First digit + (unless (and (< index size) + (setq value (digit-char-p (char string index)))) + (return (values nil index))) + (incf index) + ;; Other digits + (while (< index size) + (let ((digit (digit-char-p (char string index)))) + (unless digit (return)) + (setq value (+ (* value 10) digit)) + (incf index))) + ;; Trailing whitespace + (do ((i index (1+ i))) + ((or (= i size) (not (whitespacep (char string i)))) + (and (= i size) (setq index i)))) + (if (or junk-allow + (= index size)) + (values (* sign value) index) + (values nil index))))) + +#+ecmalisp +(defun parse-integer (string) + (!parse-integer string nil)) + (defvar *eof* (gensym)) (defun ls-read (stream) (skip-whitespaces-and-comments stream) @@ -992,9 +1226,8 @@ function mv(){ (read-sharp stream)) (t (let ((string (read-until stream #'terminalp))) - (if (every #'digit-char-p string) - (parse-integer string) - (read-symbol string))))))) + (or (values (!parse-integer string nil)) + (read-symbol string))))))) (defun ls-read-from-string (string) (ls-read (make-string-stream string))) @@ -1007,61 +1240,163 @@ function mv(){ ;;; too. The respective real functions are defined in the target (see ;;; the beginning of this file) as well as some primitive functions. -;;; If the special variable `*multiple-value-p*' is NON-NIL, then the -;;; compilation of the current form is allowed to return multiple -;;; values, using the VALUES variable. -(defvar *multiple-value-p* nil) +(defun code (&rest args) + (mapconcat (lambda (arg) + (cond + ((null arg) "") + ((integerp arg) (integer-to-string arg)) + ((stringp arg) arg) + (t (error "Unknown argument.")))) + args)) -(defvar *compilation-unit-checks* '()) +;;; Wrap X with a Javascript code to convert the result from +;;; Javascript generalized booleans to T or NIL. +(defun js!bool (x) + (code "(" x "?" (ls-compile t) ": " (ls-compile nil) ")")) -(defun make-binding (name type value &optional declarations) - (list name type value declarations)) +;;; Concatenate the arguments and wrap them with a self-calling +;;; Javascript anonymous function. It is used to make some Javascript +;;; statements valid expressions and provide a private scope as well. +;;; It could be defined as function, but we could do some +;;; preprocessing in the future. +(defmacro js!selfcall (&body body) + `(code "(function(){" *newline* (indent ,@body) "})()")) -(defun binding-name (b) (first b)) -(defun binding-type (b) (second b)) -(defun binding-value (b) (third b)) -(defun binding-declarations (b) (fourth b)) +;;; Like CODE, but prefix each line with four spaces. Two versions +;;; of this function are available, because the Ecmalisp version is +;;; very slow and bootstraping was annoying. -(defun set-binding-value (b value) - (setcar (cddr b) value)) +#+ecmalisp +(defun indent (&rest string) + (let ((input (apply #'code string))) + (let ((output "") + (index 0) + (size (length input))) + (when (plusp (length input)) (concatf output " ")) + (while (< index size) + (let ((str + (if (and (char= (char input index) #\newline) + (< index (1- size)) + (not (char= (char input (1+ index)) #\newline))) + (concat (string #\newline) " ") + (string (char input index))))) + (concatf output str)) + (incf index)) + output))) -(defun set-binding-declarations (b value) - (setcar (cdddr b) value)) +#+common-lisp +(defun indent (&rest string) + (with-output-to-string (*standard-output*) + (with-input-from-string (input (apply #'code string)) + (loop + for line = (read-line input nil) + while line + do (write-string " ") + do (write-line line))))) -(defun push-binding-declaration (decl b) - (set-binding-declarations b (cons decl (binding-declarations b)))) +;;; A Form can return a multiple values object calling VALUES, like +;;; values(arg1, arg2, ...). It will work in any context, as well as +;;; returning an individual object. However, if the special variable +;;; `*multiple-value-p*' is NIL, is granted that only the primary +;;; value will be used, so we can optimize to avoid the VALUES +;;; function call. +(defvar *multiple-value-p* nil) -(defun make-lexenv () - (list nil nil nil nil)) +;; A very simple defstruct built on lists. It supports just slot with +;; an optional default initform, and it will create a constructor, +;; predicate and accessors for you. +(defmacro def!struct (name &rest slots) + (unless (symbolp name) + (error "It is not a full defstruct implementation.")) + (let* ((name-string (symbol-name name)) + (slot-descriptions + (mapcar (lambda (sd) + (cond + ((symbolp sd) + (list sd)) + ((and (listp sd) (car sd) (cddr sd)) + sd) + (t + (error "Bad slot accessor.")))) + slots)) + (predicate (intern (concat name-string "-P")))) + `(progn + ;; Constructor + (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions) + (list ',name ,@(mapcar #'car slot-descriptions))) + ;; Predicate + (defun ,predicate (x) + (and (consp x) (eq (car x) ',name))) + ;; Copier + (defun ,(intern (concat "COPY-" name-string)) (x) + (copy-list x)) + ;; Slot accessors + ,@(with-collect + (let ((index 1)) + (dolist (slot slot-descriptions) + (let* ((name (car slot)) + (accessor-name (intern (concat name-string "-" (string name))))) + (collect + `(defun ,accessor-name (x) + (unless (,predicate x) + (error ,(concat "The object is not a type " name-string))) + (nth ,index x))) + ;; TODO: Implement this with a higher level + ;; abstraction like defsetf or (defun (setf ..)) + (collect + `(define-setf-expander ,accessor-name (x) + (let ((object (gensym)) + (new-value (gensym))) + (values (list object) + (list x) + (list new-value) + `(progn + (rplaca (nthcdr ,',index ,object) ,new-value) + ,new-value) + `(,',accessor-name ,object))))) + (incf index))))) + ',name))) + +(def!struct binding + name + type + value + declarations) + +(def!struct lexenv + variable + function + block + gotag) -(defun copy-lexenv (lexenv) - (copy-list lexenv)) +(defun lookup-in-lexenv (name lexenv namespace) + (find name (ecase namespace + (variable (lexenv-variable lexenv)) + (function (lexenv-function lexenv)) + (block (lexenv-block lexenv)) + (gotag (lexenv-gotag lexenv))) + :key #'binding-name)) (defun push-to-lexenv (binding lexenv namespace) (ecase namespace - (variable (setcar lexenv (cons binding (car lexenv)))) - (function (setcar (cdr lexenv) (cons binding (cadr lexenv)))) - (block (setcar (cddr lexenv) (cons binding (caddr lexenv)))) - (gotag (setcar (cdddr lexenv) (cons binding (cadddr lexenv)))))) + (variable (push binding (lexenv-variable lexenv))) + (function (push binding (lexenv-function lexenv))) + (block (push binding (lexenv-block lexenv))) + (gotag (push binding (lexenv-gotag lexenv))))) (defun extend-lexenv (bindings lexenv namespace) (let ((env (copy-lexenv lexenv))) (dolist (binding (reverse bindings) env) (push-to-lexenv binding env namespace)))) -(defun lookup-in-lexenv (name lexenv namespace) - (assoc name (ecase namespace - (variable (first lexenv)) - (function (second lexenv)) - (block (third lexenv)) - (gotag (fourth lexenv))))) (defvar *environment* (make-lexenv)) (defvar *variable-counter* 0) + (defun gvarname (symbol) - (concat "v" (integer-to-string (incf *variable-counter*)))) + (code "v" (incf *variable-counter*))) (defun translate-variable (symbol) (binding-value (lookup-in-lexenv symbol *environment* 'variable))) @@ -1069,7 +1404,7 @@ function mv(){ (defun extend-local-env (args) (let ((new (copy-lexenv *environment*))) (dolist (symbol args new) - (let ((b (make-binding symbol 'lexical-variable (gvarname symbol)))) + (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol)))) (push-to-lexenv b new 'variable))))) ;;; Toplevel compilations @@ -1086,11 +1421,12 @@ function mv(){ (defun %compile-defmacro (name lambda) (toplevel-compilation (ls-compile `',name)) - (push-to-lexenv (make-binding name 'macro lambda) *environment* 'function)) + (push-to-lexenv (make-binding :name name :type 'macro :value lambda) *environment* 'function) + name) (defun global-binding (name type namespace) (or (lookup-in-lexenv name *environment* namespace) - (let ((b (make-binding name type nil))) + (let ((b (make-binding :name name :type type :value nil))) (push-to-lexenv b *environment* namespace) b))) @@ -1103,19 +1439,15 @@ function mv(){ (special (dolist (name (cdr decl)) (let ((b (global-binding name 'variable 'variable))) - (push-binding-declaration 'special b)))) + (push 'special (binding-declarations b))))) (notinline (dolist (name (cdr decl)) (let ((b (global-binding name 'function 'function))) - (push-binding-declaration 'notinline b)))) + (push 'notinline (binding-declarations b))))) (constant (dolist (name (cdr decl)) (let ((b (global-binding name 'variable 'variable))) - (push-binding-declaration 'constant b)))) - (non-overridable - (dolist (name (cdr decl)) - (let ((b (global-binding name 'function 'function))) - (push-binding-declaration 'non-overridable b)))))) + (push 'constant (binding-declarations b))))))) #+ecmalisp (fset 'proclaim #'!proclaim) @@ -1132,45 +1464,189 @@ function mv(){ *compilations*)) (define-compilation if (condition true false) - (concat "(" (ls-compile condition) " !== " (ls-compile nil) - " ? " (ls-compile true *multiple-value-p*) - " : " (ls-compile false *multiple-value-p*) - ")")) + (code "(" (ls-compile condition) " !== " (ls-compile nil) + " ? " (ls-compile true *multiple-value-p*) + " : " (ls-compile false *multiple-value-p*) + ")")) -(defvar *lambda-list-keywords* '(&optional &rest)) +(defvar *ll-keywords* '(&optional &rest &key)) (defun list-until-keyword (list) - (if (or (null list) (member (car list) *lambda-list-keywords*)) + (if (or (null list) (member (car list) *ll-keywords*)) nil (cons (car list) (list-until-keyword (cdr list))))) -(defun lambda-list-required-arguments (lambda-list) - (list-until-keyword lambda-list)) +(defun ll-section (keyword ll) + (list-until-keyword (cdr (member keyword ll)))) -(defun lambda-list-optional-arguments-with-default (lambda-list) - (mapcar #'ensure-list (list-until-keyword (cdr (member '&optional lambda-list))))) +(defun ll-required-arguments (ll) + (list-until-keyword ll)) -(defun lambda-list-optional-arguments (lambda-list) - (mapcar #'car (lambda-list-optional-arguments-with-default lambda-list))) +(defun ll-optional-arguments-canonical (ll) + (mapcar #'ensure-list (ll-section '&optional ll))) -(defun lambda-list-rest-argument (lambda-list) - (let ((rest (list-until-keyword (cdr (member '&rest lambda-list))))) +(defun ll-optional-arguments (ll) + (mapcar #'car (ll-optional-arguments-canonical ll))) + +(defun ll-rest-argument (ll) + (let ((rest (ll-section '&rest ll))) (when (cdr rest) (error "Bad lambda-list")) (car rest))) +(defun ll-keyword-arguments-canonical (ll) + (flet ((canonicalize (keyarg) + ;; Build a canonical keyword argument descriptor, filling + ;; the optional fields. The result is a list of the form + ;; ((keyword-name var) init-form). + (let ((arg (ensure-list keyarg))) + (cons (if (listp (car arg)) + (car arg) + (list (intern (symbol-name (car arg)) "KEYWORD") (car arg))) + (cdr arg))))) + (mapcar #'canonicalize (ll-section '&key ll)))) + +(defun ll-keyword-arguments (ll) + (mapcar (lambda (keyarg) (second (first keyarg))) + (ll-keyword-arguments-canonical ll))) + +(defun ll-svars (lambda-list) + (let ((args + (append + (ll-keyword-arguments-canonical lambda-list) + (ll-optional-arguments-canonical lambda-list)))) + (remove nil (mapcar #'third args)))) + (defun lambda-docstring-wrapper (docstring &rest strs) (if docstring (js!selfcall "var func = " (join strs) ";" *newline* "func.docstring = '" docstring "';" *newline* "return func;" *newline*) - (join strs))) - -(define-compilation lambda (lambda-list &rest body) - (let ((required-arguments (lambda-list-required-arguments lambda-list)) - (optional-arguments (lambda-list-optional-arguments lambda-list)) - (rest-argument (lambda-list-rest-argument lambda-list)) + (apply #'code strs))) + +(defun lambda-check-argument-count + (n-required-arguments n-optional-arguments rest-p) + ;; Note: Remember that we assume that the number of arguments of a + ;; call is at least 1 (the values argument). + (let ((min (1+ n-required-arguments)) + (max (if rest-p 'n/a (+ 1 n-required-arguments n-optional-arguments)))) + (block nil + ;; Special case: a positive exact number of arguments. + (when (and (< 1 min) (eql min max)) + (return (code "checkArgs(arguments, " min ");" *newline*))) + ;; General case: + (code + (when (< 1 min) + (code "checkArgsAtLeast(arguments, " min ");" *newline*)) + (when (numberp max) + (code "checkArgsAtMost(arguments, " max ");" *newline*)))))) + +(defun compile-lambda-optional (ll) + (let* ((optional-arguments (ll-optional-arguments-canonical ll)) + (n-required-arguments (length (ll-required-arguments ll))) + (n-optional-arguments (length optional-arguments))) + (when optional-arguments + (code (mapconcat (lambda (arg) + (code "var " (translate-variable (first arg)) "; " *newline* + (when (third arg) + (code "var " (translate-variable (third arg)) + " = " (ls-compile t) + "; " *newline*)))) + optional-arguments) + "switch(arguments.length-1){" *newline* + (let ((cases nil) + (idx 0)) + (progn + (while (< idx n-optional-arguments) + (let ((arg (nth idx optional-arguments))) + (push (code "case " (+ idx n-required-arguments) ":" *newline* + (indent (translate-variable (car arg)) + "=" + (ls-compile (cadr arg)) ";" *newline*) + (when (third arg) + (indent (translate-variable (third arg)) + "=" + (ls-compile nil) + ";" *newline*))) + cases) + (incf idx))) + (push (code "default: break;" *newline*) cases) + (join (reverse cases)))) + "}" *newline*)))) + +(defun compile-lambda-rest (ll) + (let ((n-required-arguments (length (ll-required-arguments ll))) + (n-optional-arguments (length (ll-optional-arguments ll))) + (rest-argument (ll-rest-argument ll))) + (when rest-argument + (let ((js!rest (translate-variable rest-argument))) + (code "var " js!rest "= " (ls-compile nil) ";" *newline* + "for (var i = arguments.length-1; i>=" + (+ 1 n-required-arguments n-optional-arguments) + "; i--)" *newline* + (indent js!rest " = {car: arguments[i], cdr: ") js!rest "};" + *newline*))))) + +(defun compile-lambda-parse-keywords (ll) + (let ((n-required-arguments + (length (ll-required-arguments ll))) + (n-optional-arguments + (length (ll-optional-arguments ll))) + (keyword-arguments + (ll-keyword-arguments-canonical ll))) + (code + ;; Declare variables + (mapconcat (lambda (arg) + (let ((var (second (car arg)))) + (code "var " (translate-variable var) "; " *newline* + (when (third arg) + (code "var " (translate-variable (third arg)) + " = " (ls-compile nil) + ";" *newline*))))) + keyword-arguments) + ;; Parse keywords + (flet ((parse-keyword (keyarg) + ;; ((keyword-name var) init-form) + (code "for (i=" (+ 1 n-required-arguments n-optional-arguments) + "; i " - (integer-to-string (+ 1 n-required-arguments n-optional-arguments)) - ") throw 'too many arguments';" *newline*) - "") - ;; Optional arguments - (if optional-arguments - (concat "switch(arguments.length-1){" *newline* - (let ((optional-and-defaults - (lambda-list-optional-arguments-with-default lambda-list)) - (cases nil) - (idx 0)) - (progn - (while (< idx n-optional-arguments) - (let ((arg (nth idx optional-and-defaults))) - (push (concat "case " - (integer-to-string (+ idx n-required-arguments)) ":" *newline* - (translate-variable (car arg)) - "=" - (ls-compile (cadr arg)) - ";" *newline*) - cases) - (incf idx))) - (push (concat "default: break;" *newline*) cases) - (join (reverse cases)))) - "}" *newline*) - "") - ;; &rest/&body argument - (if rest-argument - (let ((js!rest (translate-variable rest-argument))) - (concat "var " js!rest "= " (ls-compile nil) ";" *newline* - "for (var i = arguments.length-1; i>=" - (integer-to-string (+ 1 n-required-arguments n-optional-arguments)) - "; i--)" *newline* - (indent js!rest " = " - "{car: arguments[i], cdr: ") js!rest "};" - *newline*)) - "") - ;; Body - (let ((*multiple-value-p* t)) (ls-compile-block body t))) - *newline* + ;; Check number of arguments + (lambda-check-argument-count n-required-arguments + n-optional-arguments + (or rest-argument keyword-arguments)) + (compile-lambda-optional ll) + (compile-lambda-rest ll) + (compile-lambda-parse-keywords ll) + (let ((*multiple-value-p* t)) + (ls-compile-block body t))) "})")))) (defun setq-pair (var val) (let ((b (lookup-in-lexenv var *environment* 'variable))) - (if (eq (binding-type b) 'lexical-variable) - (concat (binding-value b) " = " (ls-compile val)) + (if (and (binding-p b) + (eq (binding-type b) 'variable) + (not (member 'special (binding-declarations b))) + (not (member 'constant (binding-declarations b)))) + (code (binding-value b) " = " (ls-compile val)) (ls-compile `(set ',var ,val))))) + (define-compilation setq (&rest pairs) (let ((result "")) (while t @@ -1259,15 +1704,7 @@ function mv(){ (concat (setq-pair (car pairs) (cadr pairs)) (if (null (cddr pairs)) "" ", "))) (setq pairs (cddr pairs))))) - (concat "(" result ")"))) - -;;; FFI Variable accessors -(define-compilation js-vref (var) - var) - -(define-compilation js-vset (var val) - (concat "(" var " = " (ls-compile val) ")")) - + (code "(" result ")"))) ;;; Literals @@ -1291,39 +1728,50 @@ function mv(){ (defvar *literal-counter* 0) (defun genlit () - (concat "l" (integer-to-string (incf *literal-counter*)))) + (code "l" (incf *literal-counter*))) (defun literal (sexp &optional recursive) (cond ((integerp sexp) (integer-to-string sexp)) - ((stringp sexp) (concat "\"" (escape-string sexp) "\"")) + ((stringp sexp) (code "\"" (escape-string sexp) "\"")) ((symbolp sexp) (or (cdr (assoc sexp *literal-symbols*)) (let ((v (genlit)) - (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}") - #+ecmalisp - (let ((package (symbol-package sexp))) - (if (null package) - (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}") - (ls-compile `(intern ,(symbol-name sexp) ,(package-name package))))))) + (s #+common-lisp + (let ((package (symbol-package sexp))) + (if (eq package (find-package "KEYWORD")) + (code "{name: \"" (escape-string (symbol-name sexp)) + "\", 'package': '" (package-name package) "'}") + (code "{name: \"" (escape-string (symbol-name sexp)) "\"}"))) + #+ecmalisp + (let ((package (symbol-package sexp))) + (if (null package) + (code "{name: \"" (escape-string (symbol-name sexp)) "\"}") + (ls-compile `(intern ,(symbol-name sexp) ,(package-name package))))))) (push (cons sexp v) *literal-symbols*) - (toplevel-compilation (concat "var " v " = " s)) + (toplevel-compilation (code "var " v " = " s)) v))) ((consp sexp) - (let ((c (concat "{car: " (literal (car sexp) t) ", " - "cdr: " (literal (cdr sexp) t) "}"))) + (let* ((head (butlast sexp)) + (tail (last sexp)) + (c (code "QIList(" + (join-trailing (mapcar (lambda (x) (literal x t)) head) ",") + (literal (car tail) t) + "," + (literal (cdr tail) t) + ")"))) (if recursive c (let ((v (genlit))) - (toplevel-compilation (concat "var " v " = " c)) - v)))) + (toplevel-compilation (code "var " v " = " c)) + v)))) ((arrayp sexp) (let ((elements (vector-to-list sexp))) (let ((c (concat "[" (join (mapcar #'literal elements) ", ") "]"))) (if recursive c (let ((v (genlit))) - (toplevel-compilation (concat "var " v " = " c)) + (toplevel-compilation (code "var " v " = " c)) v))))))) (define-compilation quote (sexp) @@ -1339,20 +1787,70 @@ function mv(){ (define-compilation function (x) (cond ((and (listp x) (eq (car x) 'lambda)) - (ls-compile x)) + (compile-lambda (cadr x) (cddr x))) ((symbolp x) - (ls-compile `(symbol-function ',x))))) + (let ((b (lookup-in-lexenv x *environment* 'function))) + (if b + (binding-value b) + (ls-compile `(symbol-function ',x))))))) + + +(defun make-function-binding (fname) + (make-binding :name fname :type 'function :value (gvarname fname))) + +(defun compile-function-definition (list) + (compile-lambda (car list) (cdr list))) + +(defun translate-function (name) + (let ((b (lookup-in-lexenv name *environment* 'function))) + (and b (binding-value b)))) + +(define-compilation flet (definitions &rest body) + (let* ((fnames (mapcar #'car definitions)) + (fbody (mapcar #'cdr definitions)) + (cfuncs (mapcar #'compile-function-definition fbody)) + (*environment* + (extend-lexenv (mapcar #'make-function-binding fnames) + *environment* + 'function))) + (code "(function(" + (join (mapcar #'translate-function fnames) ",") + "){" *newline* + (let ((body (ls-compile-block body t))) + (indent body)) + "})(" (join cfuncs ",") ")"))) + +(define-compilation labels (definitions &rest body) + (let* ((fnames (mapcar #'car definitions)) + (*environment* + (extend-lexenv (mapcar #'make-function-binding fnames) + *environment* + 'function))) + (js!selfcall + (mapconcat (lambda (func) + (code "var " (translate-function (car func)) + " = " (compile-lambda (cadr func) (cddr func)) + ";" *newline*)) + definitions) + (ls-compile-block body t)))) + +(defvar *compiling-file* nil) (define-compilation eval-when-compile (&rest body) - (eval (cons 'progn body)) - nil) + (if *compiling-file* + (progn + (eval (cons 'progn body)) + nil) + (ls-compile `(progn ,@body)))) (defmacro define-transformation (name args form) `(define-compilation ,name ,args (ls-compile ,form))) (define-compilation progn (&rest body) - (js!selfcall (ls-compile-block body t))) + (if (null (cdr body)) + (ls-compile (car body) *multiple-value-p*) + (js!selfcall (ls-compile-block body t)))) (defun special-variable-p (x) (and (claimp x 'variable 'special) t)) @@ -1365,15 +1863,15 @@ function mv(){ (defun let-binding-wrapper (bindings body) (when (null bindings) (return-from let-binding-wrapper body)) - (concat + (code "try {" *newline* (indent "var tmp;" *newline* (mapconcat (lambda (b) (let ((s (ls-compile `(quote ,(car b))))) - (concat "tmp = " s ".value;" *newline* - s ".value = " (cdr b) ";" *newline* - (cdr b) " = tmp;" *newline*))) + (code "tmp = " s ".value;" *newline* + s ".value = " (cdr b) ";" *newline* + (cdr b) " = tmp;" *newline*))) bindings) body *newline*) "}" *newline* @@ -1381,7 +1879,7 @@ function mv(){ (indent (mapconcat (lambda (b) (let ((s (ls-compile `(quote ,(car b))))) - (concat s ".value" " = " (cdr b) ";" *newline*))) + (code s ".value" " = " (cdr b) ";" *newline*))) bindings)) "}" *newline*)) @@ -1391,31 +1889,31 @@ function mv(){ (cvalues (mapcar #'ls-compile (mapcar #'second bindings))) (*environment* (extend-local-env (remove-if #'special-variable-p variables))) (dynamic-bindings)) - (concat "(function(" - (join (mapcar (lambda (x) - (if (special-variable-p x) - (let ((v (gvarname x))) - (push (cons x v) dynamic-bindings) - v) - (translate-variable x))) - variables) - ",") - "){" *newline* - (let ((body (ls-compile-block body t))) - (indent (let-binding-wrapper dynamic-bindings body))) - "})(" (join cvalues ",") ")"))) + (code "(function(" + (join (mapcar (lambda (x) + (if (special-variable-p x) + (let ((v (gvarname x))) + (push (cons x v) dynamic-bindings) + v) + (translate-variable x))) + variables) + ",") + "){" *newline* + (let ((body (ls-compile-block body t))) + (indent (let-binding-wrapper dynamic-bindings body))) + "})(" (join cvalues ",") ")"))) ;;; Return the code to initialize BINDING, and push it extending the -;;; current lexical environment if the variable is special. +;;; current lexical environment if the variable is not special. (defun let*-initialize-value (binding) (let ((var (first binding)) (value (second binding))) (if (special-variable-p var) - (concat (ls-compile `(setq ,var ,value)) ";" *newline*) + (code (ls-compile `(setq ,var ,value)) ";" *newline*) (let* ((v (gvarname var)) - (b (make-binding var 'variable v))) - (prog1 (concat "var " v " = " (ls-compile value) ";" *newline*) + (b (make-binding :name var :type 'variable :value v))) + (prog1 (code "var " v " = " (ls-compile value) ";" *newline*) (push-to-lexenv b *environment* 'variable)))))) ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It @@ -1426,12 +1924,12 @@ function mv(){ (return-from let*-binding-wrapper body)) (let ((store (mapcar (lambda (s) (cons s (gvarname s))) (remove-if-not #'special-variable-p symbols)))) - (concat + (code "try {" *newline* (indent (mapconcat (lambda (b) (let ((s (ls-compile `(quote ,(car b))))) - (concat "var " (cdr b) " = " s ".value;" *newline*))) + (code "var " (cdr b) " = " s ".value;" *newline*))) store) body) "}" *newline* @@ -1439,7 +1937,7 @@ function mv(){ (indent (mapconcat (lambda (b) (let ((s (ls-compile `(quote ,(car b))))) - (concat s ".value" " = " (cdr b) ";" *newline*))) + (code s ".value" " = " (cdr b) ";" *newline*))) store)) "}" *newline*))) @@ -1456,52 +1954,66 @@ function mv(){ (defvar *block-counter* 0) (define-compilation block (name &rest body) - (let ((tr (integer-to-string (incf *block-counter*)))) - (let ((b (make-binding name 'block tr))) - (js!selfcall - "try {" *newline* - (let ((*environment* (extend-lexenv (list b) *environment* 'block))) - (indent "return " (ls-compile `(progn ,@body) *multiple-value-p*) ";" *newline*)) - "}" *newline* - "catch (cf){" *newline* - " if (cf.type == 'block' && cf.id == " tr ")" *newline* - " return cf.value;" *newline* - " else" *newline* - " throw cf;" *newline* - "}" *newline*)))) + (let* ((tr (incf *block-counter*)) + (b (make-binding :name name :type 'block :value tr))) + (when *multiple-value-p* + (push 'multiple-value (binding-declarations b))) + (let* ((*environment* (extend-lexenv (list b) *environment* 'block)) + (cbody (ls-compile-block body t))) + (if (member 'used (binding-declarations b)) + (js!selfcall + "try {" *newline* + (indent cbody) + "}" *newline* + "catch (cf){" *newline* + " if (cf.type == 'block' && cf.id == " tr ")" *newline* + (if *multiple-value-p* + " return values.apply(this, forcemv(cf.values));" + " return cf.values;") + *newline* + " else" *newline* + " throw cf;" *newline* + "}" *newline*) + (js!selfcall cbody))))) (define-compilation return-from (name &optional value) - (let ((b (lookup-in-lexenv name *environment* 'block))) - (if b - (js!selfcall - "throw ({" - "type: 'block', " - "id: " (binding-value b) ", " - "value: " (ls-compile value) ", " - "message: 'Return from unknown block " (symbol-name name) ".'" - "})") - (error (concat "Unknown block `" (symbol-name name) "'."))))) + (let* ((b (lookup-in-lexenv name *environment* 'block)) + (multiple-value-p (member 'multiple-value (binding-declarations b)))) + (when (null b) + (error (concat "Unknown block `" (symbol-name name) "'."))) + (push 'used (binding-declarations b)) + (js!selfcall + (when multiple-value-p (code "var values = mv;" *newline*)) + "throw ({" + "type: 'block', " + "id: " (binding-value b) ", " + "values: " (ls-compile value multiple-value-p) ", " + "message: 'Return from unknown block " (symbol-name name) ".'" + "})"))) (define-compilation catch (id &rest body) (js!selfcall "var id = " (ls-compile id) ";" *newline* "try {" *newline* - (indent "return " (ls-compile `(progn ,@body)) - ";" *newline*) + (indent (ls-compile-block body t)) *newline* "}" *newline* "catch (cf){" *newline* " if (cf.type == 'catch' && cf.id == id)" *newline* - " return cf.value;" *newline* + (if *multiple-value-p* + " return values.apply(this, forcemv(cf.values));" + " return pv.apply(this, forcemv(cf.values));") + *newline* " else" *newline* " throw cf;" *newline* "}" *newline*)) (define-compilation throw (id value) (js!selfcall + "var values = mv;" *newline* "throw ({" "type: 'catch', " "id: " (ls-compile id) ", " - "value: " (ls-compile value) ", " + "values: " (ls-compile value t) ", " "message: 'Throw uncatched.'" "})")) @@ -1516,7 +2028,7 @@ function mv(){ (let ((bindings (mapcar (lambda (label) (let ((tagidx (integer-to-string (incf *go-tag-counter*)))) - (make-binding label 'gotag (list tbidx tagidx)))) + (make-binding :name label :type 'gotag :value (list tbidx tagidx)))) (remove-if-not #'go-tag-p body)))) (extend-lexenv bindings *environment* 'gotag))) @@ -1530,7 +2042,7 @@ function mv(){ (unless (go-tag-p (car body)) (push (gensym "START") body)) ;; Tagbody compilation - (let ((tbidx (integer-to-string *tagbody-counter*))) + (let ((tbidx *tagbody-counter*)) (let ((*environment* (declare-tagbody-tags tbidx body)) initag) (let ((b (lookup-in-lexenv (first body) *environment* 'gotag))) @@ -1541,17 +2053,17 @@ function mv(){ "while (true) {" *newline* (indent "try {" *newline* (indent (let ((content "")) - (concat "switch(tagbody_" tbidx "){" *newline* - "case " initag ":" *newline* - (dolist (form (cdr body) content) - (concatf content - (if (not (go-tag-p form)) - (indent (ls-compile form) ";" *newline*) - (let ((b (lookup-in-lexenv form *environment* 'gotag))) - (concat "case " (second (binding-value b)) ":" *newline*))))) - "default:" *newline* - " break tbloop;" *newline* - "}" *newline*))) + (code "switch(tagbody_" tbidx "){" *newline* + "case " initag ":" *newline* + (dolist (form (cdr body) content) + (concatf content + (if (not (go-tag-p form)) + (indent (ls-compile form) ";" *newline*) + (let ((b (lookup-in-lexenv form *environment* 'gotag))) + (code "case " (second (binding-value b)) ":" *newline*))))) + "default:" *newline* + " break tbloop;" *newline* + "}" *newline*))) "}" *newline* "catch (jump) {" *newline* " if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline* @@ -1567,15 +2079,15 @@ function mv(){ (n (cond ((symbolp label) (symbol-name label)) ((integerp label) (integer-to-string label))))) - (if b - (js!selfcall - "throw ({" - "type: 'tagbody', " - "id: " (first (binding-value b)) ", " - "label: " (second (binding-value b)) ", " - "message: 'Attempt to GO to non-existing tag " n "'" - "})" *newline*) - (error (concat "Unknown tag `" n "'."))))) + (when (null b) + (error (concat "Unknown tag `" n "'."))) + (js!selfcall + "throw ({" + "type: 'tagbody', " + "id: " (first (binding-value b)) ", " + "label: " (second (binding-value b)) ", " + "message: 'Attempt to GO to non-existing tag " n "'" + "})" *newline*))) (define-compilation unwind-protect (form &rest clean-up) (js!selfcall @@ -1596,11 +2108,11 @@ function mv(){ "var values = mv;" *newline* "var vs;" *newline* (mapconcat (lambda (form) - (concat "vs = " (ls-compile form t) ";" *newline* - "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline* - (indent "args = args.concat(vs);" *newline*) - "else" *newline* - (indent "args.push(vs);" *newline*))) + (code "vs = " (ls-compile form t) ";" *newline* + "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline* + (indent "args = args.concat(vs);" *newline*) + "else" *newline* + (indent "args.push(vs);" *newline*))) forms) "return func.apply(window, args);" *newline*) ";" *newline*)) @@ -1611,40 +2123,267 @@ function mv(){ "return args;" *newline*)) -;;; A little backquote implementation without optimizations of any -;;; kind for ecmalisp. -(defun backquote-expand-1 (form) - (cond - ((symbolp form) - (list 'quote form)) - ((atom form) - form) - ((eq (car form) 'unquote) - (car form)) - ((eq (car form) 'backquote) - (backquote-expand-1 (backquote-expand-1 (cadr form)))) - (t - (cons 'append - (mapcar (lambda (s) - (cond - ((and (listp s) (eq (car s) 'unquote)) - (list 'list (cadr s))) - ((and (listp s) (eq (car s) 'unquote-splicing)) - (cadr s)) - (t - (list 'list (backquote-expand-1 s))))) - form))))) - -(defun backquote-expand (form) - (if (and (listp form) (eq (car form) 'backquote)) - (backquote-expand-1 (cadr form)) - form)) - -(defmacro backquote (form) - (backquote-expand-1 form)) +;;; Javascript FFI + +(define-compilation %js-vref (var) var) + +(define-compilation %js-vset (var val) + (code "(" var " = " (ls-compile val) ")")) + + +;;; Backquote implementation. +;;; +;;; Author: Guy L. Steele Jr. Date: 27 December 1985 +;;; Tested under Symbolics Common Lisp and Lucid Common Lisp. +;;; This software is in the public domain. + +;;; The following are unique tokens used during processing. +;;; They need not be symbols; they need not even be atoms. +(defvar *comma* 'unquote) +(defvar *comma-atsign* 'unquote-splicing) + +(defvar *bq-list* (make-symbol "BQ-LIST")) +(defvar *bq-append* (make-symbol "BQ-APPEND")) +(defvar *bq-list** (make-symbol "BQ-LIST*")) +(defvar *bq-nconc* (make-symbol "BQ-NCONC")) +(defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE")) +(defvar *bq-quote* (make-symbol "BQ-QUOTE")) +(defvar *bq-quote-nil* (list *bq-quote* nil)) + +;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes +;;; the expression foo, looking for occurrences of #:COMMA, +;;; #:COMMA-ATSIGN, and #:COMMA-DOT. It constructs code in strict +;;; accordance with the rules on pages 349-350 of the first edition +;;; (pages 528-529 of this second edition). It then optionally +;;; applies a code simplifier. + +;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE +;;; processing applies the code simplifier. If the value is NIL, +;;; then the code resulting from BACKQUOTE is exactly that +;;; specified by the official rules. +(defparameter *bq-simplify* t) + +(defmacro backquote (x) + (bq-completely-process x)) + +;;; Backquote processing proceeds in three stages: +;;; +;;; (1) BQ-PROCESS applies the rules to remove occurrences of +;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to +;;; this level of BACKQUOTE. (It also causes embedded calls to +;;; BACKQUOTE to be expanded so that nesting is properly handled.) +;;; Code is produced that is expressed in terms of functions +;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE. This is done +;;; so that the simplifier will simplify only list construction +;;; functions actually generated by BACKQUOTE and will not involve +;;; any user code in the simplification. #:BQ-LIST means LIST, +;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY +;;; but indicates places where "%." was used and where NCONC may +;;; therefore be introduced by the simplifier for efficiency. +;;; +;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by +;;; BQ-PROCESS to produce equivalent but faster code. The +;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be +;;; introduced into the code. +;;; +;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces +;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on. +;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being +;;; replaced by its argument). #:BQ-LIST* is replaced by either +;;; LIST* or CONS (the latter is used in the two-argument case, +;;; purely to make the resulting code a tad more readable). + +(defun bq-completely-process (x) + (let ((raw-result (bq-process x))) + (bq-remove-tokens (if *bq-simplify* + (bq-simplify raw-result) + raw-result)))) + +(defun bq-process (x) + (cond ((atom x) + (list *bq-quote* x)) + ((eq (car x) 'backquote) + (bq-process (bq-completely-process (cadr x)))) + ((eq (car x) *comma*) (cadr x)) + ((eq (car x) *comma-atsign*) + ;; (error ",@~S after `" (cadr x)) + (error "ill-formed")) + ;; ((eq (car x) *comma-dot*) + ;; ;; (error ",.~S after `" (cadr x)) + ;; (error "ill-formed")) + (t (do ((p x (cdr p)) + (q '() (cons (bracket (car p)) q))) + ((atom p) + (cons *bq-append* + (nreconc q (list (list *bq-quote* p))))) + (when (eq (car p) *comma*) + (unless (null (cddr p)) + ;; (error "Malformed ,~S" p) + (error "Malformed")) + (return (cons *bq-append* + (nreconc q (list (cadr p)))))) + (when (eq (car p) *comma-atsign*) + ;; (error "Dotted ,@~S" p) + (error "Dotted")) + ;; (when (eq (car p) *comma-dot*) + ;; ;; (error "Dotted ,.~S" p) + ;; (error "Dotted")) + )))) + +;;; This implements the bracket operator of the formal rules. +(defun bracket (x) + (cond ((atom x) + (list *bq-list* (bq-process x))) + ((eq (car x) *comma*) + (list *bq-list* (cadr x))) + ((eq (car x) *comma-atsign*) + (cadr x)) + ;; ((eq (car x) *comma-dot*) + ;; (list *bq-clobberable* (cadr x))) + (t (list *bq-list* (bq-process x))))) + +;;; This auxiliary function is like MAPCAR but has two extra +;;; purposes: (1) it handles dotted lists; (2) it tries to make +;;; the result share with the argument x as much as possible. +(defun maptree (fn x) + (if (atom x) + (funcall fn x) + (let ((a (funcall fn (car x))) + (d (maptree fn (cdr x)))) + (if (and (eql a (car x)) (eql d (cdr x))) + x + (cons a d))))) + +;;; This predicate is true of a form that when read looked +;;; like %@foo or %.foo. +(defun bq-splicing-frob (x) + (and (consp x) + (or (eq (car x) *comma-atsign*) + ;; (eq (car x) *comma-dot*) + ))) + +;;; This predicate is true of a form that when read +;;; looked like %@foo or %.foo or just plain %foo. +(defun bq-frob (x) + (and (consp x) + (or (eq (car x) *comma*) + (eq (car x) *comma-atsign*) + ;; (eq (car x) *comma-dot*) + ))) + +;;; The simplifier essentially looks for calls to #:BQ-APPEND and +;;; tries to simplify them. The arguments to #:BQ-APPEND are +;;; processed from right to left, building up a replacement form. +;;; At each step a number of special cases are handled that, +;;; loosely speaking, look like this: +;;; +;;; (APPEND (LIST a b c) foo) => (LIST* a b c foo) +;;; provided a, b, c are not splicing frobs +;;; (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo)) +;;; provided a, b, c are not splicing frobs +;;; (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo) +;;; (APPEND (CLOBBERABLE x) foo) => (NCONC x foo) +(defun bq-simplify (x) + (if (atom x) + x + (let ((x (if (eq (car x) *bq-quote*) + x + (maptree #'bq-simplify x)))) + (if (not (eq (car x) *bq-append*)) + x + (bq-simplify-args x))))) + +(defun bq-simplify-args (x) + (do ((args (reverse (cdr x)) (cdr args)) + (result + nil + (cond ((atom (car args)) + (bq-attach-append *bq-append* (car args) result)) + ((and (eq (caar args) *bq-list*) + (notany #'bq-splicing-frob (cdar args))) + (bq-attach-conses (cdar args) result)) + ((and (eq (caar args) *bq-list**) + (notany #'bq-splicing-frob (cdar args))) + (bq-attach-conses + (reverse (cdr (reverse (cdar args)))) + (bq-attach-append *bq-append* + (car (last (car args))) + result))) + ((and (eq (caar args) *bq-quote*) + (consp (cadar args)) + (not (bq-frob (cadar args))) + (null (cddar args))) + (bq-attach-conses (list (list *bq-quote* + (caadar args))) + result)) + ((eq (caar args) *bq-clobberable*) + (bq-attach-append *bq-nconc* (cadar args) result)) + (t (bq-attach-append *bq-append* + (car args) + result))))) + ((null args) result))) + +(defun null-or-quoted (x) + (or (null x) (and (consp x) (eq (car x) *bq-quote*)))) + +;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND +;;; or #:BQ-NCONC. This produces a form (op item result) but +;;; some simplifications are done on the fly: +;;; +;;; (op '(a b c) '(d e f g)) => '(a b c d e f g) +;;; (op item 'nil) => item, provided item is not a splicable frob +;;; (op item 'nil) => (op item), if item is a splicable frob +;;; (op item (op a b c)) => (op item a b c) +(defun bq-attach-append (op item result) + (cond ((and (null-or-quoted item) (null-or-quoted result)) + (list *bq-quote* (append (cadr item) (cadr result)))) + ((or (null result) (equal result *bq-quote-nil*)) + (if (bq-splicing-frob item) (list op item) item)) + ((and (consp result) (eq (car result) op)) + (list* (car result) item (cdr result))) + (t (list op item result)))) + +;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by +;;; `(LIST* ,@items ,result) but some simplifications are done +;;; on the fly. +;;; +;;; (LIST* 'a 'b 'c 'd) => '(a b c . d) +;;; (LIST* a b c 'nil) => (LIST a b c) +;;; (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g) +;;; (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g) +(defun bq-attach-conses (items result) + (cond ((and (every #'null-or-quoted items) + (null-or-quoted result)) + (list *bq-quote* + (append (mapcar #'cadr items) (cadr result)))) + ((or (null result) (equal result *bq-quote-nil*)) + (cons *bq-list* items)) + ((and (consp result) + (or (eq (car result) *bq-list*) + (eq (car result) *bq-list**))) + (cons (car result) (append items (cdr result)))) + (t (cons *bq-list** (append items (list result)))))) + +;;; Removes funny tokens and changes (#:BQ-LIST* a b) into +;;; (CONS a b) instead of (LIST* a b), purely for readability. +(defun bq-remove-tokens (x) + (cond ((eq x *bq-list*) 'list) + ((eq x *bq-append*) 'append) + ((eq x *bq-nconc*) 'nconc) + ((eq x *bq-list**) 'list*) + ((eq x *bq-quote*) 'quote) + ((atom x) x) + ((eq (car x) *bq-clobberable*) + (bq-remove-tokens (cadr x))) + ((and (eq (car x) *bq-list**) + (consp (cddr x)) + (null (cdddr x))) + (cons 'cons (maptree #'bq-remove-tokens (cdr x)))) + (t (maptree #'bq-remove-tokens x)))) (define-transformation backquote (form) - (backquote-expand-1 form)) + (bq-completely-process form)) + ;;; Primitives @@ -1658,27 +2397,26 @@ function mv(){ *builtins*)) (defmacro define-builtin (name args &body body) - `(progn - (define-raw-builtin ,name ,args - (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args) - ,@body)))) + `(define-raw-builtin ,name ,args + (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args) + ,@body))) ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations. (defmacro type-check (decls &body body) `(js!selfcall ,@(mapcar (lambda (decl) - `(concat "var " ,(first decl) " = " ,(third decl) ";" *newline*)) - decls) + `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*)) + decls) ,@(mapcar (lambda (decl) - `(concat "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline* - (indent "throw 'The value ' + " - ,(first decl) - " + ' is not a type " - ,(second decl) - ".';" - *newline*))) + `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline* + (indent "throw 'The value ' + " + ,(first decl) + " + ' is not a type " + ,(second decl) + ".';" + *newline*))) decls) - (concat "return " (progn ,@body) ";" *newline*))) + (code "return " (progn ,@body) ";" *newline*))) ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for ;;; a variable which holds a list of forms. It will compile them and @@ -1690,16 +2428,18 @@ function mv(){ (unless (consp args) (error "ARGS must be a non-empty list")) (let ((counter 0) - (variables '()) + (fargs '()) (prelude "")) (dolist (x args) - (let ((v (concat "x" (integer-to-string (incf counter))))) - (push v variables) - (concatf prelude - (concat "var " v " = " (ls-compile x) ";" *newline* - "if (typeof " v " !== 'number') throw 'Not a number!';" - *newline*)))) - (js!selfcall prelude (funcall function (reverse variables))))) + (if (numberp x) + (push (integer-to-string x) fargs) + (let ((v (code "x" (incf counter)))) + (push v fargs) + (concatf prelude + (code "var " v " = " (ls-compile x) ";" *newline* + "if (typeof " v " !== 'number') throw 'Not a number!';" + *newline*))))) + (js!selfcall prelude (funcall function (reverse fargs))))) (defmacro variable-arity (args &body body) @@ -1707,11 +2447,11 @@ function mv(){ (error "Bad usage of VARIABLE-ARITY, you must pass a symbol")) `(variable-arity-call ,args (lambda (,args) - (concat "return " ,@body ";" *newline*)))) + (code "return " ,@body ";" *newline*)))) (defun num-op-num (x op y) (type-check (("x" "number" x) ("y" "number" y)) - (concat "x" op "y"))) + (code "x" op "y"))) (define-raw-builtin + (&rest numbers) (if (null numbers) @@ -1766,14 +2506,14 @@ function mv(){ (define-builtin-comparison = "==") (define-builtin numberp (x) - (js!bool (concat "(typeof (" x ") == \"number\")"))) + (js!bool (code "(typeof (" x ") == \"number\")"))) (define-builtin floor (x) (type-check (("x" "number" x)) "Math.floor(x)")) (define-builtin cons (x y) - (concat "({car: " x ", cdr: " y "})")) + (code "({car: " x ", cdr: " y "})")) (define-builtin consp (x) (js!bool @@ -1795,13 +2535,13 @@ function mv(){ (ls-compile nil) ": tmp.cdr;" *newline*)) -(define-builtin setcar (x new) +(define-builtin rplaca (x new) (type-check (("x" "object" x)) - (concat "(x.car = " new ")"))) + (code "(x.car = " new ", x)"))) -(define-builtin setcdr (x new) +(define-builtin rplacd (x new) (type-check (("x" "object" x)) - (concat "(x.cdr = " new ")"))) + (code "(x.cdr = " new ", x)"))) (define-builtin symbolp (x) (js!bool @@ -1814,16 +2554,16 @@ function mv(){ "({name: name})")) (define-builtin symbol-name (x) - (concat "(" x ").name")) + (code "(" x ").name")) (define-builtin set (symbol value) - (concat "(" symbol ").value = " value)) + (code "(" symbol ").value = " value)) (define-builtin fset (symbol value) - (concat "(" symbol ").fvalue = " value)) + (code "(" symbol ").fvalue = " value)) (define-builtin boundp (x) - (js!bool (concat "(" x ".value !== undefined)"))) + (js!bool (code "(" x ".value !== undefined)"))) (define-builtin symbol-value (x) (js!selfcall @@ -1840,20 +2580,20 @@ function mv(){ "return func;" *newline*)) (define-builtin symbol-plist (x) - (concat "((" x ").plist || " (ls-compile nil) ")")) + (code "((" x ").plist || " (ls-compile nil) ")")) (define-builtin lambda-code (x) - (concat "(" x ").toString()")) + (code "(" x ").toString()")) -(define-builtin eq (x y) (js!bool (concat "(" x " === " y ")"))) -(define-builtin equal (x y) (js!bool (concat "(" x " == " y ")"))) +(define-builtin eq (x y) (js!bool (code "(" x " === " y ")"))) +(define-builtin equal (x y) (js!bool (code "(" x " == " y ")"))) (define-builtin char-to-string (x) (type-check (("x" "number" x)) "String.fromCharCode(x)")) (define-builtin stringp (x) - (js!bool (concat "(typeof(" x ") == \"string\")"))) + (js!bool (code "(typeof(" x ") == \"string\")"))) (define-builtin string-upcase (x) (type-check (("x" "string" x)) @@ -1868,9 +2608,7 @@ function mv(){ "var str = " (ls-compile string) ";" *newline* "var a = " (ls-compile a) ";" *newline* "var b;" *newline* - (if b - (concat "b = " (ls-compile b) ";" *newline*) - "") + (when b (code "b = " (ls-compile b) ";" *newline*)) "return str.slice(a,b);" *newline*)) (define-builtin char (string index) @@ -1884,15 +2622,17 @@ function mv(){ "string1.concat(string2)")) (define-raw-builtin funcall (func &rest args) - (concat "(" (ls-compile func) ")(" - (join (cons (if *multiple-value-p* "values" "pv") - (mapcar #'ls-compile args)) - ", ") - ")")) + (js!selfcall + "var f = " (ls-compile func) ";" *newline* + "return (typeof f === 'function'? f: f.fvalue)(" + (join (cons (if *multiple-value-p* "values" "pv") + (mapcar #'ls-compile args)) + ", ") + ")")) (define-raw-builtin apply (func &rest args) (if (null args) - (concat "(" (ls-compile func) ")()") + (code "(" (ls-compile func) ")()") (let ((args (butlast args)) (last (car (last args)))) (js!selfcall @@ -1906,7 +2646,7 @@ function mv(){ " args.push(tail.car);" *newline* " tail = tail.cdr;" *newline* "}" *newline* - "return f.apply(this, args);" *newline*)))) + "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*)))) (define-builtin js-eval (string) (type-check (("string" "string" string)) @@ -1926,7 +2666,7 @@ function mv(){ (define-builtin new () "{}") (define-builtin objectp (x) - (js!bool (concat "(typeof (" x ") === 'object')"))) + (js!bool (code "(typeof (" x ") === 'object')"))) (define-builtin oget (object key) (js!selfcall @@ -1934,13 +2674,13 @@ function mv(){ "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*)) (define-builtin oset (object key value) - (concat "((" object ")[" key "] = " value ")")) + (code "((" object ")[" key "] = " value ")")) (define-builtin in (key object) - (js!bool (concat "((" key ") in (" object "))"))) + (js!bool (code "((" key ") in (" object "))"))) (define-builtin functionp (x) - (js!bool (concat "(typeof " x " == 'function')"))) + (js!bool (code "(typeof " x " == 'function')"))) (define-builtin write-string (x) (type-check (("x" "string" x)) @@ -1973,23 +2713,30 @@ function mv(){ "return x[i] = " value ";" *newline*)) (define-builtin get-unix-time () - (concat "(Math.round(new Date() / 1000))")) + (code "(Math.round(new Date() / 1000))")) (define-builtin values-array (array) (if *multiple-value-p* - (concat "values.apply(this, " array ")") - (concat "pv.apply(this, " array ")"))) + (code "values.apply(this, " array ")") + (code "pv.apply(this, " array ")"))) (define-raw-builtin values (&rest args) (if *multiple-value-p* - (concat "values(" (join (mapcar #'ls-compile args) ", ") ")") - (concat "pv(" (join (mapcar #'ls-compile args) ", ") ")"))) + (code "values(" (join (mapcar #'ls-compile args) ", ") ")") + (code "pv(" (join (mapcar #'ls-compile args) ", ") ")"))) + +;; Receives the JS function as first argument as a literal string. The +;; second argument is compiled and should evaluate to a vector of +;; values to apply to the the function. The result returned. +(define-builtin %js-call (fun args) + (code fun ".apply(this, " args ")")) (defun macro (x) (and (symbolp x) (let ((b (lookup-in-lexenv x *environment* 'function))) - (and (eq (binding-type b) 'macro) - b)))) + (if (and b (eq (binding-type b) 'macro)) + b + nil)))) (defun ls-macroexpand-1 (form) (let ((macro-binding (macro (car form)))) @@ -2004,28 +2751,28 @@ function mv(){ ;; us replace the list representation version of the ;; function with the compiled one. ;; - #+ecmalisp (set-binding-value macro-binding compiled) + #+ecmalisp (setf (binding-value macro-binding) compiled) (setq expander compiled))) (apply expander (cdr form))) form))) (defun compile-funcall (function args) - (let ((values-funcs (if *multiple-value-p* "values" "pv"))) - (if (and (symbolp function) - (claimp function 'function 'non-overridable)) - (concat (ls-compile `',function) ".fvalue(" - (join (cons values-funcs (mapcar #'ls-compile args)) - ", ") - ")") - (concat (ls-compile `#',function) "(" - (join (cons values-funcs (mapcar #'ls-compile args)) - ", ") - ")")))) + (let* ((values-funcs (if *multiple-value-p* "values" "pv")) + (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")"))) + (cond + ((translate-function function) + (concat (translate-function function) arglist)) + ((and (symbolp function) + #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP")) + #+common-lisp t) + (code (ls-compile `',function) ".fvalue" arglist)) + (t + (code (ls-compile `#',function) arglist))))) (defun ls-compile-block (sexps &optional return-last-p) (if return-last-p - (concat (ls-compile-block (butlast sexps)) - "return "(ls-compile (car (last sexps)) *multiple-value-p*) ";") + (code (ls-compile-block (butlast sexps)) + "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";") (join-trailing (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps)) (concat ";" *newline*)))) @@ -2039,12 +2786,12 @@ function mv(){ ((and b (not (member 'special (binding-declarations b)))) (binding-value b)) ((or (keywordp sexp) - (member 'constant (binding-declarations b))) - (concat (ls-compile `',sexp) ".value")) + (and b (member 'constant (binding-declarations b)))) + (code (ls-compile `',sexp) ".value")) (t (ls-compile `(symbol-value ',sexp)))))) ((integerp sexp) (integer-to-string sexp)) - ((stringp sexp) (concat "\"" (escape-string sexp) "\"")) + ((stringp sexp) (code "\"" (escape-string sexp) "\"")) ((arrayp sexp) (literal sexp)) ((listp sexp) (let ((name (car sexp)) @@ -2064,7 +2811,15 @@ function mv(){ (ls-compile (ls-macroexpand-1 sexp) multiple-value-p) (compile-funcall name args)))))) (t - (error "How should I compile this?"))))) + (error (concat "How should I compile " (prin1-to-string sexp) "?")))))) + + +(defvar *compile-print-toplevels* nil) + +(defun truncate-string (string &optional (width 60)) + (let ((n (or (position #\newline string) + (min width (length string))))) + (subseq string 0 n))) (defun ls-compile-toplevel (sexp &optional multiple-value-p) (let ((*toplevel-compilations* nil)) @@ -2075,12 +2830,17 @@ function mv(){ (cdr sexp)))) (join (remove-if #'null-or-empty-p subs)))) (t + (when *compile-print-toplevels* + (let ((form-string (prin1-to-string sexp))) + (write-string "Compiling ") + (write-string (truncate-string form-string)) + (write-line "..."))) + (let ((code (ls-compile sexp multiple-value-p))) - (concat (join-trailing (get-toplevel-compilations) - (concat ";" *newline*)) - (if code - (concat code ";" *newline*) - ""))))))) + (code (join-trailing (get-toplevel-compilations) + (code ";" *newline*)) + (when code + (code code ";" *newline*)))))))) ;;; Once we have the compiler, we define the runtime environment and @@ -2092,48 +2852,52 @@ function mv(){ (defun eval (x) (js-eval (ls-compile-toplevel x t))) - (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= = - = > >= and append apply aref arrayp aset assoc atom block boundp + (export '(&rest &key &optional &body * *gensym-counter* *package* + - / 1+ 1- < + <= = = > >= and append apply aref arrayp assoc atom block boundp boundp butlast caar cadddr caddr cadr car car case catch cdar cdddr - cddr cdr cdr char char-code char= code-char cond cons consp copy-list - decf declaim defparameter defun defmacro defvar digit-char-p - disassemble documentation dolist dotimes ecase eq eql equal error eval - every export fdefinition find-package find-symbol first fourth fset - funcall function functionp gensym get-universal-time go identity if - in-package incf integerp integerp intern keywordp lambda last length - let let* list-all-packages list listp make-array make-package - make-symbol mapcar member minusp mod multiple-value-bind - multiple-value-call multiple-value-list multiple-value-prog1 nil not + cddr cdr cdr char char-code fdefinition find-package find-symbol first + flet fourth fset funcall function functionp gensym get-setf-expansion + get-universal-time go identity if in-package incf integerp integerp + intern keywordp labels lambda last length let let* char= code-char + cond cons consp constantly copy-list decf declaim define-setf-expander + defconstant defparameter defun defmacro defvar digit-char digit-char-p + disassemble do do* documentation dolist dotimes ecase eq eql equal + error eval every export list-all-packages list list* listp loop make-array + make-package make-symbol mapcar member minusp mod multiple-value-bind + multiple-value-call multiple-value-list multiple-value-prog1 nconc nil not nth nthcdr null numberp or package-name package-use-list packagep - plusp prin1-to-string print proclaim prog1 prog2 progn psetq push - quote remove remove-if remove-if-not return return-from revappend - reverse second set setq some string-upcase string string= stringp - subseq symbol-function symbol-name symbol-package symbol-plist - symbol-value symbolp t tagbody third throw truncate unless - unwind-protect values values-list variable warn when write-line - write-string zerop)) + parse-integer plusp prin1-to-string print proclaim prog1 prog2 progn + psetq push quote nreconc remove remove-if remove-if-not return return-from + revappend reverse rplaca rplacd second set setf setq some + string-upcase string string= stringp subseq symbol-function + symbol-name symbol-package symbol-plist symbol-value symbolp t tagbody + third throw truncate unless unwind-protect values values-list variable + warn when write-line write-string zerop)) (setq *package* *user-package*) (js-eval "var lisp") - (js-vset "lisp" (new)) - (js-vset "lisp.read" #'ls-read-from-string) - (js-vset "lisp.print" #'prin1-to-string) - (js-vset "lisp.eval" #'eval) - (js-vset "lisp.compile" (lambda (s) (ls-compile-toplevel s t))) - (js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str)))) - (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t))) + (%js-vset "lisp" (new)) + (%js-vset "lisp.read" #'ls-read-from-string) + (%js-vset "lisp.print" #'prin1-to-string) + (%js-vset "lisp.eval" #'eval) + (%js-vset "lisp.compile" (lambda (s) (ls-compile-toplevel s t))) + (%js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str)))) + (%js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t))) ;; Set the initial global environment to be equal to the host global ;; environment at this point of the compilation. (eval-when-compile (toplevel-compilation + (ls-compile `(setq *environment* ',*environment*)))) + + (eval-when-compile + (toplevel-compilation (ls-compile `(progn - ,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s)))) + ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s)))) *literal-symbols*) (setq *literal-symbols* ',*literal-symbols*) - (setq *environment* ',*environment*) (setq *variable-counter* ,*variable-counter*) (setq *gensym-counter* ,*gensym-counter*) (setq *block-counter* ,*block-counter*))))) @@ -2155,20 +2919,19 @@ function mv(){ (read-sequence seq in) seq))) - (defun ls-compile-file (filename output) - (setq *compilation-unit-checks* nil) - (with-open-file (out output :direction :output :if-exists :supersede) - (let* ((source (read-whole-file filename)) - (in (make-string-stream source))) - (loop - for x = (ls-read in) - until (eq x *eof*) - for compilation = (ls-compile-toplevel x) - when (plusp (length compilation)) - do (write-string compilation out)) - (dolist (check *compilation-unit-checks*) - (funcall check)) - (setq *compilation-unit-checks* nil)))) + (defun ls-compile-file (filename output &key print) + (let ((*compiling-file* t) + (*compile-print-toplevels* print)) + (with-open-file (out output :direction :output :if-exists :supersede) + (write-string (read-whole-file "prelude.js") out) + (let* ((source (read-whole-file filename)) + (in (make-string-stream source))) + (loop + for x = (ls-read in) + until (eq x *eof*) + for compilation = (ls-compile-toplevel x) + when (plusp (length compilation)) + do (write-string compilation out)))))) (defun bootstrap () (setq *environment* (make-lexenv)) @@ -2177,4 +2940,4 @@ function mv(){ *gensym-counter* 0 *literal-counter* 0 *block-counter* 0) - (ls-compile-file "ecmalisp.lisp" "ecmalisp.js"))) + (ls-compile-file "ecmalisp.lisp" "ecmalisp.js" :print t)))