X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=46b92932bca175ecddedabad07b1eb37f57dfad3;hb=ea250a1c0f5e0bc48a43fba2cdcaea1a7932cf0f;hp=231787200a1add5ca299f33629a208ff2fcf524b;hpb=dff35513bb966fbf11c5aa67deb2c1b727e5e06a;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 2317872..46b9293 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -40,7 +40,7 @@ `(eval-when-compile ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls))) - (declaim (constant nil t)) + (declaim (constant nil t) (special t nil)) (setq nil 'nil) (setq t 't) @@ -52,6 +52,7 @@ (defmacro defvar (name value &optional docstring) `(progn + (declaim (special ,name)) (unless (boundp ',name) (setq ,name ,value)) ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring))) ',name)) @@ -456,10 +457,16 @@ (defvar *package-list* nil) - (defun make-package (name) - (let ((package (new))) + (defun list-all-packages () + *package-list*) + + (defun make-package (name &optional use) + (let ((package (new)) + (use (mapcar #'find-package-or-fail use))) (oset package "packageName" name) (oset package "symbols" (new)) + (oset package "exports" (new)) + (oset package "use" use) (push package *package-list*) package)) @@ -486,25 +493,76 @@ (let ((package (find-package-or-fail package-designator))) (oget package "symbols"))) - (defvar *package* + (defun package-use-list (package-designator) + (let ((package (find-package-or-fail package-designator))) + (oget package "use"))) + + (defun %package-external-symbols (package-designator) + (let ((package (find-package-or-fail package-designator))) + (oget package "exports"))) + + (defvar *common-lisp-package* (make-package "CL")) + (defvar *user-package* + (make-package "CL-USER" (list *common-lisp-package*))) + + (defvar *keyword-package* + (make-package "KEYWORD")) + + (defun keywordp (x) + (and (symbolp x) (eq (symbol-package x) *keyword-package*))) + + (defvar *package* *common-lisp-package*) + + (defmacro in-package (package-designator) + `(eval-when-compile + (setq *package* (find-package-or-fail ,package-designator)))) + ;; This function is used internally to initialize the CL package ;; with the symbols built during bootstrap. (defun %intern-symbol (symbol) - (let ((symbols (%package-symbols *package*))) + (let ((symbols (%package-symbols *common-lisp-package*))) + (oset symbol "package" *common-lisp-package*) (oset symbols (symbol-name symbol) symbol))) - (defun intern (name &optional (package *package*)) - (let ((symbols (%package-symbols package))) - (if (in name symbols) - (oget symbols name) - (oset symbols name (make-symbol name))))) + (defun %find-symbol (name package) + (let ((package (find-package-or-fail package))) + (let ((symbols (%package-symbols package))) + (if (in name symbols) + (cons (oget symbols name) t) + (dolist (used (package-use-list package) (cons nil nil)) + (let ((exports (%package-external-symbols used))) + (when (in name exports) + (return-from %find-symbol + (cons (oget exports name) t))))))))) (defun find-symbol (name &optional (package *package*)) - (let ((symbols (%package-symbols package))) - (oget *package* name)))) + (car (%find-symbol name package))) + (defun intern (name &optional (package *package*)) + (let ((package (find-package-or-fail package))) + (let ((result (%find-symbol name package))) + (if (cdr result) + (car result) + (let ((symbols (%package-symbols package))) + (oget symbols name) + (let ((symbol (make-symbol name))) + (oset symbol "package" package) + (when (eq package *keyword-package*) + (oset symbol "value" symbol) + (export (list symbol) package)) + (oset symbols name symbol))))))) + + (defun symbol-package (symbol) + (unless (symbolp symbol) + (error "it is not a symbol")) + (oget symbol "package")) + + (defun export (symbols &optional (package *package*)) + (let ((exports (%package-external-symbols package))) + (dolist (symb symbols t) + (oset exports (symbol-name symb) symb))))) ;;; The compiler offers some primitives and special forms which are @@ -630,7 +688,15 @@ (progn (defun prin1-to-string (form) (cond - ((symbolp form) (symbol-name form)) + ((symbolp form) + (if (cdr (%find-symbol (symbol-name form) *package*)) + (symbol-name form) + (let ((package (symbol-package form)) + (name (symbol-name form))) + (concat (if (eq package (find-package "KEYWORD")) + "" + (package-name package)) + ":" name)))) ((integerp form) (integer-to-string form)) ((stringp form) (concat "\"" (escape-string form) "\"")) ((functionp form) @@ -768,12 +834,48 @@ (t (error "Unknown reader form."))))))) -(defvar *eof* (make-symbol "EOF")) +;;; Parse a string of the form NAME, PACKAGE:NAME or +;;; PACKAGE::NAME and return the name. If the string is of the +;;; form 1) or 3), but the symbol does not exist, it will be created +;;; and interned in that package. +(defun read-symbol (string) + (let ((size (length string)) + package name internalp index) + (setq index 0) + (while (and (< index size) + (not (char= (char string index) #\:))) + (incf index)) + (cond + ;; No package prefix + ((= index size) + (setq name string) + (setq package *package*) + (setq internalp t)) + (t + ;; Package prefix + (if (zerop index) + (setq package "KEYWORD") + (setq package (string-upcase (subseq string 0 index)))) + (incf index) + (when (char= (char string index) #\:) + (setq internalp t) + (incf index)) + (setq name (subseq string index)))) + ;; Canonalize symbol name and package + (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"))) + (intern name package) + (find-symbol name package)))) + +(defvar *eof* (gensym)) (defun ls-read (stream) (skip-whitespaces-and-comments stream) (let ((ch (%peek-char stream))) (cond - ((null ch) + ((or (null ch) (char= ch #\))) *eof*) ((char= ch #\() (%read-char stream) @@ -798,7 +900,7 @@ (let ((string (read-until stream #'terminalp))) (if (every #'digit-char-p string) (parse-integer string) - (intern (string-upcase string)))))))) + (read-symbol string))))))) (defun ls-read-from-string (string) (ls-read (make-string-stream string))) @@ -899,6 +1001,10 @@ (defun !proclaim (decl) (case (car decl) + (special + (dolist (name (cdr decl)) + (let ((b (global-binding name 'variable 'variable))) + (push-binding-declaration 'special b)))) (notinline (dolist (name (cdr decl)) (let ((b (global-binding name 'function 'function))) @@ -912,6 +1018,8 @@ (let ((b (global-binding name 'function 'function))) (push-binding-declaration 'non-overridable b)))))) +#+ecmalisp +(fset 'proclaim #'!proclaim) ;;; Special forms @@ -1077,7 +1185,9 @@ (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))))) + #+ecmalisp (ls-compile + `(intern ,(symbol-name sexp) + ,(package-name (symbol-package sexp)))))) (push (cons sexp v) *literal-symbols*) (toplevel-compilation (concat "var " v " = " s)) v))) @@ -1118,43 +1228,46 @@ (define-compilation progn (&rest body) (js!selfcall (ls-compile-block body t))) -(defun dynamic-binding-wrapper (bindings body) - (if (null bindings) - body - (concat - "try {" *newline* - (indent - "var tmp;" *newline* - (join - (mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - (concat "tmp = " s ".value;" *newline* - s ".value = " (cdr b) ";" *newline* - (cdr b) " = tmp;" *newline*))) - bindings)) - body) - "}" *newline* - "finally {" *newline* - (indent - (join-trailing - (mapcar (lambda (b) - (let ((s (ls-compile `(quote ,(car b))))) - (concat s ".value" " = " (cdr b)))) - bindings) - (concat ";" *newline*))) - "}" *newline*))) - +(defun special-variable-p (x) + (claimp x 'variable 'special)) + +;;; Wrap CODE to restore the symbol values of the dynamic +;;; bindings. BINDINGS is a list of pairs of the form +;;; (SYMBOL . PLACE), where PLACE is a Javascript variable +;;; name to initialize the symbol value and where to stored +;;; the old value. +(defun let-binding-wrapper (bindings body) + (when (null bindings) + (return-from let-binding-wrapper body)) + (concat + "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*))) + bindings) + body *newline*) + "}" *newline* + "finally {" *newline* + (indent + (mapconcat (lambda (b) + (let ((s (ls-compile `(quote ,(car b))))) + (concat s ".value" " = " (cdr b) ";" *newline*))) + bindings)) + "}" *newline*)) (define-compilation let (bindings &rest body) (let ((bindings (mapcar #'ensure-list bindings))) - (let ((variables (mapcar #'first bindings)) - (values (mapcar #'second bindings))) - (let ((cvalues (mapcar #'ls-compile values)) - (*environment* (extend-local-env (remove-if #'boundp variables))) + (let ((variables (mapcar #'first bindings))) + (let ((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 (boundp x) + (if (special-variable-p x) (let ((v (gvarname x))) (push (cons x v) dynamic-bindings) v) @@ -1163,10 +1276,58 @@ ",") "){" *newline* (let ((body (ls-compile-block body t))) - (indent (dynamic-binding-wrapper dynamic-bindings body))) + (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. +(defun let*-initialize-value (binding) + (let ((var (first binding)) + (value (second binding))) + (if (special-variable-p var) + (concat (ls-compile `(setq ,var ,value)) ";" *newline*) + (let ((v (gvarname var))) + (let ((b (make-binding var 'variable v))) + (prog1 (concat "var " v " = " (ls-compile value) ";" *newline*) + (push-to-lexenv b *environment* 'variable))))))) + +;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It +;;; DOES NOT generate code to initialize the value of the symbols, +;;; unlike let-binding-wrapper. +(defun let*-binding-wrapper (symbols body) + (when (null symbols) + (return-from let*-binding-wrapper body)) + (let ((store (mapcar (lambda (s) (cons s (gvarname s))) + (remove-if-not #'special-variable-p symbols)))) + (concat + "try {" *newline* + (indent + (mapconcat (lambda (b) + (let ((s (ls-compile `(quote ,(car b))))) + (concat "var " (cdr b) " = " s ".value;" *newline*))) + store) + body) + "}" *newline* + "finally {" *newline* + (indent + (mapconcat (lambda (b) + (let ((s (ls-compile `(quote ,(car b))))) + (concat s ".value" " = " (cdr b) ";" *newline*))) + store)) + "}" *newline*))) + + +(define-compilation let* (bindings &rest body) + (let ((bindings (mapcar #'ensure-list bindings)) + (*environment* (copy-lexenv *environment*))) + (js!selfcall + (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings))) + (body (concat (mapconcat #'let*-initialize-value bindings) + (ls-compile-block body t)))) + (let*-binding-wrapper specials body))))) + + (defvar *block-counter* 0) (define-compilation block (name &rest body) @@ -1211,7 +1372,7 @@ " throw cf;" *newline* "}" *newline*)) -(define-compilation throw (id &optional value) +(define-compilation throw (id value) (js!selfcall "throw ({" "type: 'catch', " @@ -1611,9 +1772,10 @@ ((symbolp sexp) (let ((b (lookup-in-lexenv sexp *environment* 'variable))) (cond - ((eq (binding-type b) 'lexical-variable) + ((and b (not (member 'special (binding-declarations b)))) (binding-value b)) - ((claimp sexp 'variable 'constant) + ((or (keywordp sexp) + (member 'constant (binding-declarations b))) (concat (ls-compile `',sexp) ".value")) (t (ls-compile `(symbol-value ',sexp)))))) @@ -1672,6 +1834,26 @@ (ls-compile-toplevel x)))) (js-eval code))) + (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= = += > >= and append apply 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-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 pron 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*) + (js-eval "var lisp") (js-vset "lisp" (new)) (js-vset "lisp.read" #'ls-read-from-string)