X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=0801df4f45a88266e40c01ab26aa684da8b56243;hb=ad28d0c42e2a8b37c0213a37f5966f7198fe8b02;hp=e145a74cfc6041fe723be4d02ba9b1905319f964;hpb=0e25a1125a032c1a90f4b5cd375c874461aa5f62;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index e145a74..0801df4 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -23,6 +23,9 @@ ;;; language to the compiler to be able to run. #+ecmalisp +(js-eval "function pv (x) { return typeof x === 'object' && 'car' in x ? x.car : x; }") + +#+ecmalisp (progn (eval-when-compile (%compile-defmacro 'defmacro @@ -278,7 +281,7 @@ (revappend list '())) (defmacro psetq (&rest pairs) - (let (;; For each pair, we store here a list of the form + (let ( ;; For each pair, we store here a list of the form ;; (VARIABLE GENSYM VALUE). (assignments '())) (while t @@ -292,7 +295,7 @@ (push `(,variable ,(gensym) ,value) assignments) (setq pairs (cddr pairs)))))) (setq assignments (reverse assignments)) - ;; + ;; `(let ,(mapcar #'cdr assignments) (setq ,@(!reduce #'append (mapcar #'butlast assignments) '()))))) @@ -595,7 +598,10 @@ (defun export (symbols &optional (package *package*)) (let ((exports (%package-external-symbols package))) (dolist (symb symbols t) - (oset exports (symbol-name symb) symb))))) + (oset exports (symbol-name symb) symb)))) + + (defun get-universal-time () + (+ (get-unix-time) 2208988800))) ;;; The compiler offers some primitives and special forms which are @@ -669,6 +675,15 @@ (aset v i x) (incf i)))) +#+ecmalisp +(progn + (defun values-list (list) + (values-array (list-to-vector list))) + + (defun values (&rest args) + (values-list args))) + + ;;; Like CONCAT, 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. @@ -742,9 +757,10 @@ (symbol-name form) (let ((package (symbol-package form)) (name (symbol-name form))) - (concat (if (eq package (find-package "KEYWORD")) - "" - (package-name package)) + (concat (cond + ((null package) "#") + ((eq package (find-package "KEYWORD")) "") + (t (package-name package))) ":" name)))) ((integerp form) (integer-to-string form)) ((stringp form) (concat "\"" (escape-string form) "\"")) @@ -866,6 +882,7 @@ (#\' (list 'function (ls-read stream))) (#\( (list-to-vector (%read-list stream))) + (#\: (make-symbol (string-upcase (read-until stream #'terminalp)))) (#\\ (let ((cname (concat (string (%read-char stream)) @@ -1121,10 +1138,14 @@ "return func;" *newline*) (join strs))) + +(defvar *compiling-lambda-p* nil) + (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)) + (*compiling-lambda-p* t) documentation) ;; Get the documentation string for the lambda function (when (and (stringp (car body)) @@ -1140,24 +1161,25 @@ (lambda-docstring-wrapper documentation "(function (" - (join (mapcar #'translate-variable - (append required-arguments optional-arguments)) + (join (cons "values" + (mapcar #'translate-variable + (append required-arguments optional-arguments))) ",") "){" *newline* ;; Check number of arguments (indent (if required-arguments - (concat "if (arguments.length < " (integer-to-string n-required-arguments) + (concat "if (arguments.length < " (integer-to-string (1+ n-required-arguments)) ") throw 'too few arguments';" *newline*) "") (if (not rest-argument) (concat "if (arguments.length > " - (integer-to-string (+ n-required-arguments n-optional-arguments)) + (integer-to-string (+ 1 n-required-arguments n-optional-arguments)) ") throw 'too many arguments';" *newline*) "") ;; Optional arguments (if optional-arguments - (concat "switch(arguments.length){" *newline* + (concat "switch(arguments.length-1){" *newline* (let ((optional-and-defaults (lambda-list-optional-arguments-with-default lambda-list)) (cases nil) @@ -1182,7 +1204,7 @@ (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 (+ n-required-arguments n-optional-arguments)) + (integer-to-string (+ 1 n-required-arguments n-optional-arguments)) "; i--)" *newline* (indent js!rest " = " "{car: arguments[i], cdr: ") js!rest "};" @@ -1221,6 +1243,7 @@ (concat "(" var " = " (ls-compile val) ")")) + ;;; Literals (defun escape-string (string) (let ((output "") @@ -1252,9 +1275,11 @@ (or (cdr (assoc sexp *literal-symbols*)) (let ((v (genlit)) (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}") - #+ecmalisp (ls-compile - `(intern ,(symbol-name sexp) - ,(package-name (symbol-package 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))))))) (push (cons sexp v) *literal-symbols*) (toplevel-compilation (concat "var " v " = " s)) v))) @@ -1304,7 +1329,7 @@ (js!selfcall (ls-compile-block body t))) (defun special-variable-p (x) - (claimp x 'variable 'special)) + (and (claimp x 'variable 'special) t)) ;;; Wrap CODE to restore the symbol values of the dynamic ;;; bindings. BINDINGS is a list of pairs of the form @@ -1528,7 +1553,6 @@ "})" *newline*) (error (concat "Unknown tag `" n "'."))))) - (define-compilation unwind-protect (form &rest clean-up) (js!selfcall "var ret = " (ls-compile nil) ";" *newline* @@ -1539,6 +1563,21 @@ "}" *newline* "return ret;" *newline*)) +(define-compilation multiple-value-call (func-form &rest forms) + (let ((func (ls-compile func-form))) + (js!selfcall + "var args = [values];" *newline* + "function values(){" *newline* + (indent "var result = [];" *newline* + "for (var i=0; i= x.length) throw 'Out of range';" *newline* "return x[i] = " value ";" *newline*)) +(define-builtin get-unix-time () + (concat "(Math.round(new Date() / 1000))")) + +(define-builtin values-array (array) + (concat "values.apply(this, " array ")")) + +(define-raw-builtin values (&rest args) + (if *compiling-lambda-p* + (concat "values(" (join (mapcar #'ls-compile args) ", ") ")") + (compile-funcall 'values args))) + (defun macro (x) (and (symbolp x) @@ -1919,12 +1969,12 @@ (defun compile-funcall (function args) (if (and (symbolp function) (claimp function 'function 'non-overridable)) - (concat (ls-compile `',function) ".function(" - (join (mapcar #'ls-compile args) + (concat (ls-compile `',function) ".fvalue(" + (join (cons "pv" (mapcar #'ls-compile args)) ", ") ")") (concat (ls-compile `#',function) "(" - (join (mapcar #'ls-compile args) + (join (cons "pv" (mapcar #'ls-compile args)) ", ") ")"))) @@ -2006,27 +2056,24 @@ (ls-compile-toplevel x)))) (js-eval code))) - (export '(&rest &optional &body * *gensym-counter* *package* + - / - 1+ 1- < <= = = > >= and append apply aref arrayp aset - 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 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 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 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 variable warn when write-line write-string - zerop)) + (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= = + = > >= and append apply aref arrayp aset 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 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 variable warn when + write-line write-string zerop)) (setq *package* *user-package*)