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)
(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))
(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))))
`((block ,name ,@body)))))
',name))
- (defvar *package* (new))
-
(defun null (x)
(eq x nil))
(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))
`(prog1 (progn ,form1 ,result) ,@body)))
-
;;; This couple of helper functions will be defined in both Common
;;; Lisp and in Ecmalisp.
(defun ensure-list (x)
(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))
(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 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 &optional (package *package*))
+ (let ((symbols (%package-symbols package)))
+ (oget *package* name))))
+
+
;;; The compiler offers some primitives and special forms which are
;;; not found in Common Lisp, for instance, while. So, we grow Common
(if (null (cdr last))
(prin1-to-string (car last))
(concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
- ")"))))
+ ")"))
+ ((packagep form)
+ (concat "#<PACKAGE " (package-name form) ">"))))
(defun write-line (x)
(write-string x)
(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
(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)"))
(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*
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
(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)
(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
(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*)
projects / jscl.git / blobdiff