[cells-cvs] CVS kennysarc2

[ktilton]

Update of /project/cells/cvsroot/kennysarc2
In directory clnet:/tmp/cvs-serv13489

Added Files:
	defun.lisp extensions.lisp struct.lisp 
Log Message:
implemented keyword params for defun


--- /project/cells/cvsroot/kennysarc2/defun.lisp	2008/02/03 22:09:14	NONE
+++ /project/cells/cvsroot/kennysarc2/defun.lisp	2008/02/03 22:09:14	1.1
;;
;; copyright 2008 by Kenny Tilton
;;
;; Same license as Arc
;;
;;

;; The following is Arc, or is meant to be.
;; The Lisp file extension is for my IDE.

;; n.b. Requires extensions.lisp



(mac defun (name params . body)
  (w/uniq (rtargs)
    `(def ,name ,rtargs
       (withs ,(with (reqs nil key? nil opt? nil keys nil opts nil without)
                (each p params
                  (if (is p '&o) (do (assert (no opt?) "Duplicate &o:" ',params)
                                     (assert (no key?) "&k cannot precede &o:" ',params)
                                   (= opt? t))
                    (is p '&k) (do (assert (no key?) "Duplicate &k:" ',params)
                                   (= key? t))
                    key? (push-end p keys)
                    opt? (push-end p opts)
                    (do (assert (~acons p) "Reqd parameters need not be defaulted:" p)
                        (push-end p reqs))))
                (with (n -1 kvs (uniq))
                  (+ (mappend [list _ `(nth ,(++ n) ,rtargs)] reqs)
                    (mappend [list (carif _) `(or (nth ,(++ n) ,rtargs)
                                                ,(cadrif _))] opts)
                    (list kvs `(pair (nthcdr ,(++ n) ,rtargs)))
                    (mappend [list (carif _)
                               `(or (alref ,kvs ',(carif _))
                                       ,(cadrif _))] keys)
                    )))
         , at body))))

(defun tabc (a b c) ; &opt o1 &key o2)
  (list a b c))

(prs "test" (tabc 'dog 'cat 3))(prn)

(defun tabc-od (a b c &o (d 42))
  (list a b c d))

(prs "dog cat 3 nil" (tabc-od 'dog 'cat 3 nil))(prn)
(prs "dog cat 3 4" (tabc-od 'dog 'cat 3 4))(prn)
(prs "dog cat 3 42" (tabc-od 'dog 'cat 3))(prn)

;;; --- &k feature not yet implemented ------------

(prn (macex '(defun tabc-od-kef (a b c &o (d 42) &k e (f 'go-giants)) (list a b c d e f))))

(defun tabc-od-kef (a b c &o (d 'def-d) &k e (f 'go-giants))
  (list a b c d e f))

(prs "dog cat 3 dee nil go-giants"
  (tabc-od-kef 'dog 'cat 3 'dee))(prn)

(prs "dog cat 3 dee rt-eee go-giants"
  (tabc-od-kef 'dog 'cat 3 'dee 'e 'rt-eee))(prn)

(prs "dog cat 3 dee nil ft-ffff"
  (tabc-od-kef 'dog 'cat 3 'dee 'f 'rt-fff))(prn)

;;;(prn)
;;;(prs "dog cat 3 dee 42"
;;;  (tabc-od-ke 'dog 'cat 3 'dee 'e 42))
;;;(prn)
;;;(prs "dog cat 3 dee go-giants"
;;;  (tabc-od-ke 'dog 'cat 3 'dee))
;;;(prn)
;;;(prs "dog cat 3 def-d go-giants"
;;;  (tabc-od-ke 'dog 'cat 3))
;;;(prn)


--- /project/cells/cvsroot/kennysarc2/extensions.lisp	2008/02/03 22:09:14	NONE
+++ /project/cells/cvsroot/kennysarc2/extensions.lisp	2008/02/03 22:09:14	1.1
;;
;; copyright 2008 by Kenny Tilton
;;
;; Same license as Arc
;;
;;

;; The following is Arc, or is meant to be.
;; The Lisp file extension is for my IDE.

(def lastcons (seq)
  (when (acons seq)
    (if (no (cdr seq))
        seq
      (lastcons (cdr seq)))))

(mac push-end (x place)
  `(if (no ,place)
       (= ,place (list ,x))
     (aif (lastcons ,place)
       (do (= (cdr it) (cons ,x nil))
           ,place))))

(mac assert (c . msg)
  `(unless ,c
     (prs "Assert NG:" ',c 'deets: , at msg)
     (ero "See console for assert failure deets")))

(def cdrif (x) (when (acons x) (cdr x)))
(def cadrif (x) (when (acons x) (cadr x)))

(def nth (i lst)
  "Indexed list access but returns NIL if index out of bounds"
  (let x -1
    (some [when (is (++ x) i) _] lst)))--- /project/cells/cvsroot/kennysarc2/struct.lisp	2008/02/03 22:09:14	NONE
+++ /project/cells/cvsroot/kennysarc2/struct.lisp	2008/02/03 22:09:14	1.1
;;
;; copyright 2008 by Kenny Tilton
;;
;; Same license as Arc
;;
;;

;; The following is Arc, or is meant to be.
;; The Lisp file extension is for my IDE.


(mac struct ((name (o pfx (string name "-"))) . slot-defs)
  (with (maker (coerce (+ "mk-" (string name)) 'sym)
          defmaker (coerce (+ "mk-def-" (string name)) 'sym)
          ;typdef (cons 'typ name)
          )
    `(do
         (def ,defmaker ()
           ;(prn 'defmakersees ',(keep acons slot-defs))
           (listtab ',(cons (list 'typ name) (keep acons slot-defs))))

         (def ,maker initargs
           (aif (keep [~find _ ',(map carif slot-defs)] (map car (pair initargs)))
             (do (ero "Invalid initargs to " ',maker " supplied: " it ". Allowed are " ',slot-defs) nil)
             (let self (,defmaker)
               (map [= (self (car _)) (cadr _)] (pair initargs))
               self)))

         ,@(map (fn (sd)
                  `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (self)
                     (unless (is (self 'typ) ',name)
                       (prn "This " self " is not a " ',name)
                       (ero "Wrong struct for accessor")) ;; this was a wild guess and acts weird
                     (self ',sd))) (map carif slot-defs)))))

;;; debug by viewing the macro-expansion...

;;; (prn (macex '(struct (cell c-) awake rule (pulse 0))))

;;; now actually try it..

(struct (cell c-) ;; the c- gets prefixed to all accessor names
 awake
 rule
 (pulse 0)) ;; that zero is a default value

;;;(prn (mk-def-cell))

(= c123 (mk-cell 'awake 1 'rule 2 'pulse 3)) ;; keywords are not prefixed

(prn "(1 2 3)? " (map [_ c123] (list c-awake c-rule c-pulse)))

(prn "(1 2 0)? " (map [_ (mk-cell 'awake 1 'rule 2)] (list c-awake c-rule c-pulse)))

;;;(struct (cell2) ;; no prefix supplied means you auto-get cell2-
;;;  (pulse 0)
;;;  awake
;;;  rule
;;;  )
;;; 
;;;(= c2 (mk-cell2 'awake 3 'rule 4))
;;;
;;;(prn "(3 4 0)? " (map [_ c2] (list cell2-awake cell2-rule cell2-pulse)))
;;;            
;;;(prn "please fail on wrong type...")
;;;
;;;(prn (c-pulse c2))