X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=4ed550d0535010c7a52c1c67a7cea42b4170149b;hb=074ea419432183745005ee18871b55bfc167dd5b;hp=adb316227d83c23ef5208d62cd261aedba00474f;hpb=111577f84281dc235f260f66548cedd41e9acf58;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index adb3162..4ed550d 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -36,6 +36,11 @@ args) ,@body)))))) + (defmacro declaim (&rest decls) + `(eval-when-compile + ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls))) + + (declaim (constant nil t)) (setq nil 'nil) (setq t 't) @@ -47,8 +52,7 @@ (defmacro defvar (name value &optional docstring) `(progn - (unless (boundp ',name) - (setq ,name ,value)) + (unless (boundp ',name) (setq ,name ,value)) ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring))) ',name)) @@ -66,6 +70,7 @@ (defmacro defun (name args &rest body) `(progn + (declaim (non-overridable ,name)) (fset ',name (named-lambda ,(symbol-name name) ,args ,@(if (and (stringp (car body)) (not (null (cdr body)))) @@ -73,8 +78,6 @@ `((block ,name ,@body))))) ',name)) - (defvar *package* (new)) - (defun null (x) (eq x nil)) @@ -84,17 +87,6 @@ (defmacro while (condition &body body) `(block nil (%while ,condition ,@body))) - (defun internp (name) - (in name *package*)) - - (defun intern (name) - (if (internp name) - (oget *package* name) - (oset *package* name (make-symbol name)))) - - (defun find-symbol (name) - (oget *package* name)) - (defvar *gensym-counter* 0) (defun gensym (&optional (prefix "G")) (setq *gensym-counter* (+ *gensym-counter* 1)) @@ -237,7 +229,6 @@ `(prog1 (progn ,form1 ,result) ,@body))) - ;;; This couple of helper functions will be defined in both Common ;;; Lisp and in Ecmalisp. (defun ensure-list (x) @@ -429,6 +420,11 @@ (setq alist (cdr alist)))) (car alist)) + (defun string (x) + (cond ((stringp x) x) + ((symbolp x) (symbol-name x)) + (t (char-to-string x)))) + (defun string= (s1 s2) (equal s1 s2)) @@ -455,7 +451,69 @@ (unless (symbolp x) (error "Wrong argument type! it should be a symbol")) (oget x "vardoc")))) - ) + + ;; Packages + + (defvar *package-list* nil) + + (defun make-package (name) + (let ((package (new))) + (oset package "packageName" name) + (oset package "symbols" (new)) + (push package *package-list*) + package)) + + (defun packagep (x) + (and (objectp x) (in "symbols" x))) + + (defun find-package (package-designator) + (when (packagep package-designator) + (return-from find-package package-designator)) + (let ((name (string package-designator))) + (dolist (package *package-list*) + (when (string= (package-name package) name) + (return package))))) + + (defun find-package-or-fail (package-designator) + (or (find-package package-designator) + (error "Package unknown."))) + + (defun package-name (package-designator) + (let ((package (find-package-or-fail package-designator))) + (oget package "packageName"))) + + (defun %package-symbols (package-designator) + (let ((package (find-package-or-fail package-designator))) + (oget package "symbols"))) + + (defvar *package* + (make-package "CL")) + + ;; 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*))) + (oset symbol "package" *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) + (let ((symbol (make-symbol name))) + (oset symbol "package" package) + (oset symbols name symbol))))) + + (defun find-symbol (name &optional (package *package*)) + (let ((symbols (%package-symbols package))) + (oget *package* name))) + + (defun symbol-package (symbol) + (unless (symbolp symbol) + (error "it is not a symbol")) + (oget symbol "package"))) + + ;;; The compiler offers some primitives and special forms which are ;;; not found in Common Lisp, for instance, while. So, we grow Common @@ -595,7 +653,9 @@ (if (null (cdr last)) (prin1-to-string (car last)) (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last))))) - ")")))) + ")")) + ((packagep form) + (concat "#")))) (defun write-line (x) (write-string x) @@ -841,18 +901,27 @@ (push-to-lexenv b *environment* namespace) b))) -(defun claims (symbol namespace) - (lookup-in-lexenv symbol *environment* namespace)) +(defun claimp (symbol namespace claim) + (let ((b (lookup-in-lexenv symbol *environment* namespace))) + (and b (member claim (binding-declarations b))))) (defun !proclaim (decl) - (unless (consp decl) - (error "Declaration must be a list")) (case (car decl) (notinline - (dolist (fname (cdr decl)) - (let ((b (global-binding fname 'function 'function))) - (push-binding-declaration 'notinline b)))))) + (dolist (name (cdr decl)) + (let ((b (global-binding name 'function 'function))) + (push-binding-declaration 'notinline 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)))))) +#+ecmalisp +(fset 'proclaim #'!proclaim) ;;; Special forms @@ -1415,7 +1484,7 @@ (define-builtin eq (x y) (js!bool (concat "(" x " === " y ")"))) (define-builtin equal (x y) (js!bool (concat "(" x " == " y ")"))) -(define-builtin string (x) +(define-builtin char-to-string (x) (type-check (("x" "number" x)) "String.fromCharCode(x)")) @@ -1482,6 +1551,9 @@ (define-builtin new () "{}") +(define-builtin objectp (x) + (js!bool (concat "(typeof (" x ") === 'object')"))) + (define-builtin oget (object key) (js!selfcall "var tmp = " "(" object ")[" key "];" *newline* @@ -1525,10 +1597,16 @@ form))) (defun compile-funcall (function args) - (concat (ls-compile `#',function) "(" - (join (mapcar #'ls-compile args) - ", ") - ")")) + (if (and (symbolp function) + (claimp function 'function 'non-overridable)) + (concat (ls-compile `',function) ".function(" + (join (mapcar #'ls-compile args) + ", ") + ")") + (concat (ls-compile `#',function) "(" + (join (mapcar #'ls-compile args) + ", ") + ")"))) (defun ls-compile-block (sexps &optional return-last-p) (if return-last-p @@ -1542,9 +1620,13 @@ (cond ((symbolp sexp) (let ((b (lookup-in-lexenv sexp *environment* 'variable))) - (if (eq (binding-type b) 'lexical-variable) - (binding-value b) - (ls-compile `(symbol-value ',sexp))))) + (cond + ((eq (binding-type b) 'lexical-variable) + (binding-value b)) + ((claimp sexp 'variable 'constant) + (concat (ls-compile `',sexp) ".value")) + (t + (ls-compile `(symbol-value ',sexp)))))) ((integerp sexp) (integer-to-string sexp)) ((stringp sexp) (concat "\"" (escape-string sexp) "\"")) ((listp sexp) @@ -1557,8 +1639,7 @@ (apply comp args))) ;; Built-in functions ((and (assoc name *builtins*) - (or (not (lookup-in-lexenv name *environment* 'function)) - (member 'notinline (claims name 'function)))) + (not (claimp name 'function 'notinline))) (let ((comp (second (assoc name *builtins*)))) (apply comp args))) (t @@ -1616,9 +1697,7 @@ (toplevel-compilation (ls-compile `(progn - ,@(mapcar (lambda (s) - `(oset *package* ,(symbol-name (car s)) - (js-vref ,(cdr s)))) + ,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s)))) *literal-symbols*) (setq *literal-symbols* ',*literal-symbols*) (setq *environment* ',*environment*)