X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=2e75d2487f0b3b7fe3b03a2672f7fe37b57bd139;hb=3d6b319c5c78eb53616e162f79ac01c13fbd3db2;hp=2064ee16ef93891245f1ea56263dbeda5e239ff2;hpb=3c5f2f88672d5d6ec865f4b52331e2d154ef80ba;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 2064ee1..2e75d24 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,6 +457,9 @@ (defvar *package-list* nil) + (defun list-all-packages () + *package-list*) + (defun make-package (name &optional use) (let ((package (new)) (use (mapcar #'find-package-or-fail use))) @@ -503,6 +507,12 @@ (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) @@ -531,14 +541,18 @@ (car (%find-symbol name package))) (defun intern (name &optional (package *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) - (oset symbols name symbol)))))) + (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) @@ -674,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) @@ -844,7 +866,7 @@ (setq package (find-package package)) ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an ;; external symbol from PACKAGE. - (if internalp + (if (or internalp (eq package (find-package "KEYWORD"))) (intern name package) (find-symbol name package)))) @@ -979,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))) @@ -1159,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))) @@ -1200,43 +1228,48 @@ (define-compilation progn (&rest body) (js!selfcall (ls-compile-block body t))) + +(defun restoring-dynamic-binding (bindings body) + (concat + "try {" *newline* + (indent 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 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*))) - + (restoring-dynamic-binding + bindings + (concat "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*)))) (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))) + (*environment* + (extend-local-env (remove-if (lambda (v)(claimp v 'variable 'special)) + variables))) (dynamic-bindings)) (concat "(function(" (join (mapcar (lambda (x) - (if (boundp x) + (if (claimp x 'variable 'special) (let ((v (gvarname x))) (push (cons x v) dynamic-bindings) v) @@ -1249,6 +1282,29 @@ "})(" (join cvalues ",") ")"))))) +(defun let*-initialize (x) + (let ((var (first x)) + (value (second x))) + (if (claimp var 'variable 'special) + (ls-compile `(setq ,var ,value)) + (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))))))) + +(define-compilation let* (bindings &rest body) + (let ((bindings (mapcar #'ensure-list bindings)) + (*environment* (copy-lexenv *environment*))) + (js!selfcall + (let ((body + (concat (mapconcat #'let*-initialize bindings) + (ls-compile-block body t)))) + (if (some (lambda (b) (claimp (car b) 'variable 'special)) bindings) + (restoring-dynamic-binding bindings body) + body))))) + + + (defvar *block-counter* 0) (define-compilation block (name &rest body) @@ -1693,9 +1749,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)))))) @@ -1762,17 +1819,18 @@ 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 - in-package incf integerp integerp intern lambda-code last - length let 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)) + in-package incf integerp integerp intern keywordp + lambda-code 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*)