(eq (binding-type b) 'variable)
(not (member 'special (binding-declarations b)))
(not (member 'constant (binding-declarations b))))
- `(code ,(binding-value b) " = " ,(ls-compile val)))
+ ;; TODO: Unnecesary make-symbol when codegen migration is
+ ;; finished.
+ `(= ,(make-symbol (binding-value b)) ,(ls-compile val)))
((and b (eq (binding-type b) 'macro))
(ls-compile `(setf ,var ,val)))
(t
((null (cdr pairs))
(error "Odd pairs in SETQ"))
(t
- (push `(code ,(setq-pair (car pairs) (cadr pairs))
- ,(if (null (cddr pairs)) "" ", "))
- result)
+ (push `,(setq-pair (car pairs) (cadr pairs)) result)
(setq pairs (cddr pairs)))))
- `(code "(" ,@(reverse result) ")")))
+ `(progn ,@(reverse result))))
;;; Compilation of literals an object dumping
#-jscl
(let ((package (symbol-package symbol)))
(if (eq package (find-package "KEYWORD"))
- `(code "(new Symbol(" ,(dump-string (symbol-name symbol)) ", " ,(dump-string (package-name package)) "))")
- `(code "(new Symbol(" ,(dump-string (symbol-name symbol)) "))")))
+ `(new (call |Symbol| ,(dump-string (symbol-name symbol)) ,(dump-string (package-name package))))
+ `(new (call |Symbol| ,(dump-string (symbol-name symbol))))))
#+jscl
(let ((package (symbol-package symbol)))
(if (null package)
- `(code "(new Symbol(" ,(dump-string (symbol-name symbol)) "))")
+ `(new (call |Symbol| ,(dump-string (symbol-name symbol))))
(ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
(defun dump-cons (cons)
(let ((head (butlast cons))
(tail (last cons)))
- `(code "QIList("
- ,@(interleave (mapcar (lambda (x) (literal x t)) head) "," t)
- ,(literal (car tail) t)
- ","
- ,(literal (cdr tail) t)
- ")")))
+ `(call |QIList|
+ ,@(mapcar (lambda (x) `(code ,(literal x t))) head)
+ (code ,(literal (car tail) t))
+ (code ,(literal (cdr tail) t)))))
(defun dump-array (array)
(let ((elements (vector-to-list array)))
0 ; TODO: Force
; braces. Unnecesary when code
; is gone
- (code ,(ls-compile-block body)))
+ ,(ls-compile-block body))
`(return ,(ls-compile nil))))
(define-compilation function (x)
(define-compilation progn (&rest body)
(if (null (cdr body))
(ls-compile (car body) *multiple-value-p*)
- `(code "("
- ,@(interleave
- (append (mapcar #'ls-compile (butlast body))
- (list (ls-compile (car (last body)) t)))
- ",")
- ")")))
+ `(progn
+ ,@(append (mapcar #'ls-compile (butlast body))
+ (list (ls-compile (car (last body)) t))))))
(define-compilation macrolet (definitions &rest body)
(let ((*environment* (copy-lexenv *environment*)))
"})")))
(define-compilation catch (id &rest body)
- (js!selfcall
- "var id = " (ls-compile id) ";"
- "try {"
- `(code ,(ls-compile-block body t))
- "}"
- "catch (cf){"
- " if (cf.type == 'catch' && cf.id == id)"
- (if *multiple-value-p*
- " return values.apply(this, forcemv(cf.values));"
- " return pv.apply(this, forcemv(cf.values));")
-
- " else"
- " throw cf;"
- "}" ))
+ (js!selfcall*
+ `(var (|id| ,(ls-compile id)))
+ `(try
+ ,(ls-compile-block body t))
+ `(catch (|cf|)
+ (if (and (== (get |cf| |type|) "catch")
+ (== (get |cf| |id|) |id|))
+ ,(if *multiple-value-p*
+ `(return (call (get |values| |apply|)
+ this
+ (call |forcemv| (get |cf| |values|))))
+ `(return (call (get |pv| |apply|)
+ this
+ (call |forcemv| (get |cf| |values|)))))
+ (throw |cf|)))))
(define-compilation throw (id value)
- (js!selfcall
- "var values = mv;"
- "throw ({"
- "type: 'catch', "
- "id: " (ls-compile id) ", "
- "values: " (ls-compile value t) ", "
- "message: 'Throw uncatched.'"
- "})"))
+ (js!selfcall*
+ `(var (|values| |mv|))
+ `(throw (object
+ |type| "catch"
+ |id| ,(ls-compile id)
+ |values| ,(ls-compile value t)
+ |message| "Throw uncatched."))))
(defun go-tag-p (x)
(or (integerp x) (symbolp x)))