X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=1f960b6457659ad32a6551f3309e78bbcb47e1cc;hb=ad19ec082d2d9aa6877cc0bbae9ec3fe3094f489;hp=9ab908e988916133c0a9ecce394ee92c96d9d320;hpb=74fe25c38e66e2583071bb43295c6c0c11bcbd95;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 9ab908e..1f960b6 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -163,7 +163,14 @@ `(setq ,x (- ,x ,delta))) (defmacro push (x place) - `(setq ,place (cons ,x ,place))) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place) + (let ((g (gensym))) + `(let* ((,g ,x) + ,@(mapcar #'list dummies vals) + (,(car newval) (cons ,g ,getter)) + ,@(cdr newval)) + ,setter)))) (defmacro dolist (iter &body body) (let ((var (first iter)) @@ -376,6 +383,43 @@ ,@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 @@ -466,6 +510,7 @@ ((funcall func (car list)) (remove-if func (cdr list))) (t + ;; (cons (car list) (remove-if func (cdr list)))))) (defun remove-if-not (func list) @@ -495,39 +540,43 @@ (t (error "Unsupported argument.")))) + (defmacro do-sequence (iteration &body body) + (let ((seq (gensym)) + (index (gensym))) + `(let ((,seq ,(second iteration))) + (cond + ;; Strings + ((stringp ,seq) + (let ((,index 0)) + (dotimes (,index (length ,seq)) + (let ((,(first iteration) + (char ,seq ,index))) + ,@body)))) + ;; Lists + ((listp ,seq) + (dolist (,(first iteration) ,seq) + ,@body)) + (t + (error "type-error!")))))) + (defun some (function seq) - (cond - ((stringp seq) - (let ((index 0) - (size (length seq))) - (while (< index size) - (when (funcall function (char seq index)) - (return-from some t)) - (incf index)) - nil)) - ((listp seq) - (dolist (x seq nil) - (when (funcall function x) - (return t)))) - (t - (error "Unknown sequence.")))) + (do-sequence (elt seq) + (when (funcall function elt) + (return-from some t)))) (defun every (function seq) - (cond - ((stringp seq) - (let ((index 0) - (size (length seq))) - (while (< index size) - (unless (funcall function (char seq index)) - (return-from every nil)) - (incf index)) - t)) - ((listp seq) - (dolist (x seq t) - (unless (funcall function x) - (return)))) - (t - (error "Unknown sequence.")))) + (do-sequence (elt seq) + (unless (funcall function elt) + (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 @@ -645,16 +694,6 @@ `(progn (rplacd ,cons ,new-value) ,new-value) `(car ,cons)))) - (defmacro push (x place) - (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place) - (let ((g (gensym))) - `(let* ((,g ,x) - ,@(mapcar #'list dummies vals) - (,(car newval) (cons ,g ,getter)) - ,@(cdr newval)) - ,setter)))) - ;; Incorrect typecase, but used in NCONC. (defmacro typecase (x &rest clausules) (let ((value (gensym))) @@ -704,8 +743,8 @@ (defun nreconc (x y) (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st))) - (2nd x 1st) ; 2nd follows first down the list. - (3rd y 2nd)) ;3rd follows 2nd down the list. + (2nd x 1st) ; 2nd follows first down the list. + (3rd y 2nd)) ;3rd follows 2nd down the list. ((atom 2nd) 3rd) (rplacd 2nd 3rd))) @@ -960,9 +999,13 @@ (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last))))) ")")) ((arrayp form) - (concat "#" (prin1-to-string (vector-to-list form)))) + (concat "#" (if (zerop (length form)) + "()" + (prin1-to-string (vector-to-list form))))) ((packagep form) - (concat "#")))) + (concat "#")) + (t + (concat "#")))) (defun write-line (x) (write-string x) @@ -2716,6 +2759,14 @@ (t (error (concat "How should I compile " (prin1-to-string sexp) "?")))))) + +(defvar *compile-print-toplevels* nil) + +(defun truncate-string (string &optional (width 60)) + (let ((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 @@ -2725,6 +2776,12 @@ (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*)) @@ -2808,8 +2865,9 @@ (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)) @@ -2828,4 +2886,4 @@ *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)))