`(%define-symbol-macro ',name ',expansion))
+
+;;; Report functions which are called but not defined
+
+(defvar *fn-info* '())
+
+(def!struct fn-info
+ symbol
+ defined
+ called)
+
+(defun find-fn-info (symbol)
+ (let ((entry (find symbol *fn-info* :key #'fn-info-symbol)))
+ (unless entry
+ (setq entry (make-fn-info :symbol symbol))
+ (push entry *fn-info*))
+ entry))
+
+(defun fn-info (symbol &key defined called)
+ (let ((info (find-fn-info symbol)))
+ (when defined
+ (setf (fn-info-defined info) defined))
+ (when called
+ (setf (fn-info-called info) called))))
+
+(defun report-undefined-functions ()
+ (dolist (info *fn-info*)
+ (let ((symbol (fn-info-symbol info)))
+ (when (and (fn-info-called info)
+ (not (fn-info-defined info)))
+ (warn "The function `~a' is undefined.~%" symbol))))
+ (setq *fn-info* nil))
+
+
+
;;; Special forms
(defvar *compilations* nil)
(defun setq-pair (var val)
+ (unless (symbolp var)
+ (error "~a is not a symbol" var))
(let ((b (lookup-in-lexenv var *environment* 'variable)))
(cond
((and b
- (eq (binding-type b) 'variable)
- (not (member 'special (binding-declarations b)))
- (not (member 'constant (binding-declarations b))))
+ (eq (binding-type b) 'variable)
+ (not (member 'special (binding-declarations b)))
+ (not (member 'constant (binding-declarations b))))
`(= ,(binding-value b) ,(convert val)))
((and b (eq (binding-type b) 'macro))
(convert `(setf ,var ,val)))
(push (cons sexp jsvar) *literal-table*)
(toplevel-compilation `(var (,jsvar ,dumped)))
(when (keywordp sexp)
- (toplevel-compilation `(= ,(get jsvar "value") ,jsvar)))
+ (toplevel-compilation `(= (get ,jsvar "value") ,jsvar)))
jsvar)))))))
(when (find :compile-toplevel situations)
(eval (cons 'progn body)))
;; `load-toplevel' is given, then just compile the subforms as usual.
- (if (find :load-toplevel situations)
- (convert `(progn ,@body))))
+ (when (find :load-toplevel situations)
+ (convert-toplevel `(progn ,@body) *multiple-value-p*)))
((find :execute situations)
(convert `(progn ,@body) *multiple-value-p*))
(t
(convert nil))))
-(define-compilation eval-when-compile (&rest body)
- (if *compiling-file*
- (progn
- (eval (cons 'progn body))
- (convert 0))
- (convert `(progn ,@body))))
-
(defmacro define-transformation (name args form)
`(define-compilation ,name ,args
(convert ,form)))
(var (,idvar #()))
,cbody)
(catch (cf)
- (if (and (== (get cf "type") "block")
- (== (get cf "id") ,idvar))
+ (if (and (instanceof cf |BlockNLX|) (== (get cf "id") ,idvar))
,(if *multiple-value-p*
`(return (method-call |values| "apply" this (call |forcemv| (get cf "values"))))
`(return (get cf "values")))
;; capture it in a closure.
`(selfcall
,(when multiple-value-p `(var (|values| |mv|)))
- (throw
- (object
- "type" "block"
- "id" ,(binding-value b)
- "values" ,(convert value multiple-value-p)
- "message" ,(concat "Return from unknown block '" (symbol-name name) "'."))))))
+ (throw (new (call |BlockNLX|
+ ,(binding-value b)
+ ,(convert value multiple-value-p)
+ ,(symbol-name name)))))))
(define-compilation catch (id &rest body)
- `(selfcall
- (var (id ,(convert id)))
- (try
- ,(convert-block body t))
- (catch (|cf|)
- (if (and (== (get |cf| "type") "catch")
- (== (get |cf| "id") id))
- ,(if *multiple-value-p*
- `(return (method-call |values| "apply" this (call |forcemv| (get |cf| "values"))))
- `(return (method-call |pv| "apply" this (call |forcemv| (get |cf| "values")))))
- (throw |cf|)))))
+ (let ((values (if *multiple-value-p* '|values| '|pv|)))
+ `(selfcall
+ (var (id ,(convert id)))
+ (try
+ ,(convert-block body t))
+ (catch (cf)
+ (if (and (instanceof cf |CatchNLX|) (== (get cf "id") id))
+ (return (method-call ,values "apply" this (call |forcemv| (get cf "values"))))
+ (throw cf))))))
(define-compilation throw (id value)
`(selfcall
(var (|values| |mv|))
- (throw (object
- "type" "catch"
- "id" ,(convert id)
- "values" ,(convert value t)
- "message" "Throw uncatched."))))
+ (throw (new (call |CatchNLX| ,(convert id) ,(convert value t))))))
+
(defun go-tag-p (x)
(or (integerp x) (symbolp x)))
default
(break tbloop)))
(catch (jump)
- (if (and (== (get jump "type") "tagbody")
- (== (get jump "id") ,tbidx))
+ (if (and (instanceof jump |TagNLX|) (== (get jump "id") ,tbidx))
(= ,branch (get jump "label"))
(throw jump)))))
(return ,(convert nil))))))
(define-compilation go (label)
- (let ((b (lookup-in-lexenv label *environment* 'gotag))
- (n (cond
- ((symbolp label) (symbol-name label))
- ((integerp label) (integer-to-string label)))))
+ (let ((b (lookup-in-lexenv label *environment* 'gotag)))
(when (null b)
(error "Unknown tag `~S'" label))
`(selfcall
- (throw
- (object
- "type" "tagbody"
- "id" ,(first (binding-value b))
- "label" ,(second (binding-value b))
- "message" ,(concat "Attempt to GO to non-existing tag " n))))))
+ (throw (new (call |TagNLX|
+ ,(first (binding-value b))
+ ,(second (binding-value b))))))))
(define-compilation unwind-protect (form &rest clean-up)
`(selfcall
(throw (+ "Function `" (call |xstring| (get symbol "name")) "' is undefined.")))
(return func)))
-(define-builtin symbol-plist (x)
- `(or (get ,x "plist") ,(convert nil)))
-
(define-builtin lambda-code (x)
`(call |make_lisp_string| (method-call ,x "toString")))
(define-builtin functionp (x)
`(bool (=== (typeof ,x) "function")))
-(define-builtin %write-string (x)
- `(method-call |lisp| "write" ,x))
-
(define-builtin /debug (x)
`(method-call |console| "log" (call |xstring| ,x)))
,@(mapcar (lambda (key)
`(progn
(= obj (property obj (call |xstring| ,(convert key))))
- (if (=== object undefined)
+ (if (=== obj undefined)
(throw "Impossible to set object property."))))
(butlast keys))
(var (tmp
(define-builtin in (key object)
`(bool (in (call |xstring| ,key) ,object)))
+(define-builtin delete-property (key object)
+ `(selfcall
+ (delete (property ,object (call |xstring| ,key)))))
+
(define-builtin map-for-in (function object)
`(selfcall
(var (f ,function)
((and (symbolp function)
#+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
#-jscl t)
+ (fn-info function :called t)
`(method-call ,(convert `',function) "fvalue" ,@arglist))
- #+jscl((symbolp function)
- `(call ,(convert `#',function) ,@arglist))
- ((and (consp function) (eq (car function) 'lambda))
+ #+jscl
+ ((symbolp function)
`(call ,(convert `#',function) ,@arglist))
+ ((and (consp function) (eq (car function) 'lambda))
+ `(call ,(convert `(function ,function)) ,@arglist))
((and (consp function) (eq (car function) 'oget))
`(call |js_to_lisp|
(call ,(reduce (lambda (obj p)
`(property ,obj (call |xstring| ,p)))
(mapcar #'convert (cdr function)))
,@(mapcar (lambda (s)
- `(call |lisp_to_js| ,s))
+ `(call |lisp_to_js| ,(convert s)))
args))))
(t
(error "Bad function descriptor")))))
(subseq string 0 n)))
(defun convert-toplevel (sexp &optional multiple-value-p)
- (let ((*toplevel-compilations* nil))
+ ;; Macroexpand sexp as much as possible
+ (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
+ (when expandedp
+ (return-from convert-toplevel (convert-toplevel sexp multiple-value-p))))
+ ;; Process as toplevel
+ (let ((*convert-level* -1)
+ (*toplevel-compilations* nil))
(cond
;; Non-empty toplevel progn
((and (consp sexp)
projects / jscl.git / blobdiff