,@body)
(cdr ,head))))
+ ;; A very simple defstruct built on lists. It supports just slot with
+ ;; an optional default initform, and it will create a constructor,
+ ;; predicate and accessors for you.
+ (defmacro defstruct (name &rest slots)
+ (unless (symbolp name)
+ (error "It is not a full defstruct implementation."))
+ (let* ((name-string (symbol-name name))
+ (slot-descriptions
+ (mapcar (lambda (sd)
+ (cond
+ ((symbolp sd)
+ (list sd))
+ ((and (listp sd) (car sd) (cddr sd))
+ sd)
+ (t
+ (error "Bad slot accessor."))))
+ slots))
+ (predicate (intern (concat name-string "P"))))
+ `(progn
+ ;; Constructor
+ (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
+ (list ',name ,@(mapcar #'car slot-descriptions)))
+ ;; Predicate
+ (defun ,predicate (x)
+ (and (consp x) (eq (car x) ',name)))
+ ;; Slot accessors
+ ,@(with-collect
+ (let ((index 1))
+ (dolist (slot slot-descriptions)
+ (let ((name (car slot)))
+ (collect `(defun ,(intern (concat name-string "-" (string name))) (x)
+ (unless (,predicate x)
+ (error ,(concat "The object is not a type " name-string)))
+ (nth ,index x)))
+ (incf index)))))
+ ',name)))
+
(defun map1 (func list)
(with-collect
(while list
(return-from every nil)))
t)
+ (defun position (elt sequence)
+ (let ((pos 0))
+ (do-sequence (x seq)
+ (when (eq elt x)
+ (return))
+ (incf pos))
+ pos))
+
(defun assoc (x alist)
(while alist
(if (eql x (caar alist))
"()"
(prin1-to-string (vector-to-list form)))))
((packagep form)
- (concat "#<PACKAGE " (package-name form) ">"))))
+ (concat "#<PACKAGE " (package-name form) ">"))
+ (t
+ (concat "#<javascript object>"))))
(defun write-line (x)
(write-string x)
(t
(error (concat "How should I compile " (prin1-to-string sexp) "?"))))))
+
+(defvar *compile-print-toplevels* nil)
+
+(defun truncate-string (string &optional (width 60))
+ (let ((size (length string))
+ (n (or (position #\newline string)
+ (min width (length string)))))
+ (subseq string 0 n)))
+
(defun ls-compile-toplevel (sexp &optional multiple-value-p)
(let ((*toplevel-compilations* nil))
(cond
(cdr sexp))))
(join (remove-if #'null-or-empty-p subs))))
(t
+ (when *compile-print-toplevels*
+ (let ((form-string (prin1-to-string sexp)))
+ (write-string "Compiling ")
+ (write-string (truncate-string form-string))
+ (write-line "...")))
+
(let ((code (ls-compile sexp multiple-value-p)))
(code (join-trailing (get-toplevel-compilations)
(code ";" *newline*))
(read-sequence seq in)
seq)))
- (defun ls-compile-file (filename output)
- (let ((*compiling-file* t))
+ (defun ls-compile-file (filename output &key print)
+ (let ((*compiling-file* t)
+ (*compile-print-toplevels* print))
(with-open-file (out output :direction :output :if-exists :supersede)
(write-string (read-whole-file "prelude.js") out)
(let* ((source (read-whole-file filename))
*gensym-counter* 0
*literal-counter* 0
*block-counter* 0)
- (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))
+ (ls-compile-file "ecmalisp.lisp" "ecmalisp.js" :print t)))