From 04e662cf427aa7d3bf156efc3da82a661024c343 Mon Sep 17 00:00:00 2001 From: Bart Botta <00003b@gmail.com> Date: Wed, 26 Nov 2008 23:29:30 -0600 Subject: [PATCH] fix/add more CONS stuff use swf-defmemfun instead of swf-defun (which doesn't work atm) add NULL, LAST, NCONC, NTHCDR, REST, 1+ minimal implemention of AREF, SETF --- compile/special-forms.lisp | 13 ++++- lib/cl-conses.lisp | 140 +++++++++++++++++++++++++++------------------ lib/cl-conses2.lisp | 54 ++++++++++++++++- lib/cl.lisp | 4 +- 4 files changed, 151 insertions(+), 60 deletions(-) diff --git a/compile/special-forms.lisp b/compile/special-forms.lisp index 6a7c728..9137b18 100644 --- a/compile/special-forms.lisp +++ b/compile/special-forms.lisp @@ -448,8 +448,17 @@ call with %flet-call, which sets up hidden return label arg (error "not enough arguments to LIST*")) (scompile (expand-rest rest)))) -(define-special* nconc (rest) -) +;;; partial implementation of aref, handles single dimensional flash::Array +(define-special aref (array index) + `(,@(scompile array) + ,@(scompile index) + (:get-property (:multiname-l "" "")))) + +;; partial implementation of setf, handles setting 1 local var +;; so we can start using it while waiting on real implementation +(swf-defmacro setf (var value) + `(%set-local ,var ,value)) + ;;(scompile '(list* 1 2 3 4 5)) ;;(scompile '(list* 1)) diff --git a/lib/cl-conses.lisp b/lib/cl-conses.lisp index 207a780..786796f 100644 --- a/lib/cl-conses.lisp +++ b/lib/cl-conses.lisp @@ -48,10 +48,10 @@ (swf-defmemfun consp (a) (%typep a cons-type)) - (swf-defun atom (object) + (swf-defmemfun atom (object) (not (consp object))) - (swf-defun %type-error (fun arg) + (swf-defmemfun %type-error (fun arg) (%error (+ "type-error: unknown type in " fun ":" (%type-of arg)))) #+nil(swf-defmemfun car (a) @@ -101,37 +101,37 @@ ,temp)))) - (swf-defun caar (x) (car (car x))) - (swf-defun cadr (x) (car (cdr x))) - (swf-defun cdar (x) (cdr (car x))) - (swf-defun cddr (x) (cdr (cdr x))) - (swf-defun caaar (x) (car (car (car x)))) - (swf-defun caadr (x) (car (car (cdr x)))) - (swf-defun cadar (x) (car (cdr (car x)))) - (swf-defun caddr (x) (car (cdr (cdr x)))) - (swf-defun cdaar (x) (cdr (car (car x)))) - (swf-defun cdadr (x) (cdr (car (cdr x)))) - (swf-defun cddar (x) (cdr (cdr (car x)))) - (swf-defun cdddr (x) (cdr (cdr (cdr x)))) - (swf-defun caaaar (x) (car (car (car (car x))))) - (swf-defun caaadr (x) (car (car (car (cdr x))))) - (swf-defun caadar (x) (car (car (cdr (car x))))) - (swf-defun caaddr (x) (car (car (cdr (cdr x))))) - (swf-defun cadaar (x) (car (cdr (car (car x))))) - (swf-defun cadadr (x) (car (cdr (car (cdr x))))) - (swf-defun caddar (x) (car (cdr (cdr (car x))))) - (swf-defun cadddr (x) (car (cdr (cdr (cdr x))))) - (swf-defun cdaaar (x) (cdr (car (car (car x))))) - (swf-defun cdaadr (x) (cdr (car (car (cdr x))))) - (swf-defun cdadar (x) (cdr (car (cdr (car x))))) - (swf-defun cdaddr (x) (cdr (car (cdr (cdr x))))) - (swf-defun cddaar (x) (cdr (cdr (car (car x))))) - (swf-defun cddadr (x) (cdr (cdr (car (cdr x))))) - (swf-defun cdddar (x) (cdr (cdr (cdr (car x))))) - (swf-defun cddddr (x) (cdr (cdr (cdr (cdr x))))) - - - (swf-defun copy-tree (tree) + (swf-defmemfun caar (x) (car (car x))) + (swf-defmemfun cadr (x) (car (cdr x))) + (swf-defmemfun cdar (x) (cdr (car x))) + (swf-defmemfun cddr (x) (cdr (cdr x))) + (swf-defmemfun caaar (x) (car (car (car x)))) + (swf-defmemfun caadr (x) (car (car (cdr x)))) + (swf-defmemfun cadar (x) (car (cdr (car x)))) + (swf-defmemfun caddr (x) (car (cdr (cdr x)))) + (swf-defmemfun cdaar (x) (cdr (car (car x)))) + (swf-defmemfun cdadr (x) (cdr (car (cdr x)))) + (swf-defmemfun cddar (x) (cdr (cdr (car x)))) + (swf-defmemfun cdddr (x) (cdr (cdr (cdr x)))) + (swf-defmemfun caaaar (x) (car (car (car (car x))))) + (swf-defmemfun caaadr (x) (car (car (car (cdr x))))) + (swf-defmemfun caadar (x) (car (car (cdr (car x))))) + (swf-defmemfun caaddr (x) (car (car (cdr (cdr x))))) + (swf-defmemfun cadaar (x) (car (cdr (car (car x))))) + (swf-defmemfun cadadr (x) (car (cdr (car (cdr x))))) + (swf-defmemfun caddar (x) (car (cdr (cdr (car x))))) + (swf-defmemfun cadddr (x) (car (cdr (cdr (cdr x))))) + (swf-defmemfun cdaaar (x) (cdr (car (car (car x))))) + (swf-defmemfun cdaadr (x) (cdr (car (car (cdr x))))) + (swf-defmemfun cdadar (x) (cdr (car (cdr (car x))))) + (swf-defmemfun cdaddr (x) (cdr (car (cdr (cdr x))))) + (swf-defmemfun cddaar (x) (cdr (cdr (car (car x))))) + (swf-defmemfun cddadr (x) (cdr (cdr (car (cdr x))))) + (swf-defmemfun cdddar (x) (cdr (cdr (cdr (car x))))) + (swf-defmemfun cddddr (x) (cdr (cdr (cdr (cdr x))))) + + + (swf-defmemfun copy-tree (tree) (if (consp tree) (cons (copy-tree (car tree)) (copy-tree (cdr tree))) tree)) @@ -139,13 +139,6 @@ (swf-defmemfun listp (a) (or (%typep a cons-type) (eq a nil))) - (swf-defmemfun endp (a) - (if (eq a nil) - t - (if (consp a) - nil - (%type-error "ENDP" a)))) - ;; fixme: implement pop according to spec (swf-defmacro pop (a) (let ((temp (gensym "POP-TEMP-"))) @@ -154,25 +147,62 @@ (let ((,temp ,a)) (prog1 (car ,temp) - (%set-local ,a (cdr ,temp))))))) + (setf ,a (cdr ,temp))))))) ;; fixme: implement PUSH according to spec (swf-defmacro push (item place) (let ((temp (gensym "PUSH-TEMP-"))) `(progn (let ((,temp ,place)) - (%set-local ,place (cons ,item ,temp)))))) - - - (swf-defun first (list) (car list)) - (swf-defun second (list) (car (cdr list))) - (swf-defun third (list) (car (cddr list))) - (swf-defun fourth (list) (car (cdddr list))) - (swf-defun fifth (list) (car (cddddr list))) - (swf-defun sixth (list) (car (cdr (cddddr list)))) - (swf-defun seventh (list) (car (cddr (cddddr list)))) - (swf-defun eighth (list) (car (cdddr (cddddr list)))) - (swf-defun ninth (list) (car (cddddr (cddddr list)))) - (swf-defun tenth (list) (car (cdr (cddddr (cddddr list))))) + (setf ,place (cons ,item ,temp)))))) + + + (swf-defmemfun first (list) (car list)) + (swf-defmemfun second (list) (car (cdr list))) + (swf-defmemfun third (list) (car (cddr list))) + (swf-defmemfun fourth (list) (car (cdddr list))) + (swf-defmemfun fifth (list) (car (cddddr list))) + (swf-defmemfun sixth (list) (car (cdr (cddddr list)))) + (swf-defmemfun seventh (list) (car (cddr (cddddr list)))) + (swf-defmemfun eighth (list) (car (cdddr (cddddr list)))) + (swf-defmemfun ninth (list) (car (cddddr (cddddr list)))) + (swf-defmemfun tenth (list) (car (cdr (cddddr (cddddr list))))) + + + (swf-defmemfun endp (a) + (if (eq a nil) + t + (if (consp a) + nil + (%type-error "ENDP" a)))) + + (swf-defmemfun null (a) + (eq a nil)) + + ;; fixme: add optional count arg + (swf-defmemfun last (a) + (if (endp a) + nil + (tagbody + :start + (unless (consp (cdr a)) + (return a)) + (setf a (cdr a)) + (go :start)))) + + (swf-defmemfun nconc (&arest lists) + (let* ((a (if (zerop (:length lists)) + nil + (aref lists 0))) + (end (last a))) + (dotimes (i (1- (:length lists)) a) + (let ((next (%aref lists (1+ i)))) + (rplacd (last end) next) + (setf end next))))) -) \ No newline at end of file + +) + +#+nil +(dump-defun-asm () + (nconc (cons 1 2) (cons 3 4))) \ No newline at end of file diff --git a/lib/cl-conses2.lisp b/lib/cl-conses2.lisp index 21410bf..0117f76 100644 --- a/lib/cl-conses2.lisp +++ b/lib/cl-conses2.lisp @@ -47,6 +47,56 @@ (%set-local list (cdr list))))) ;; ENDP, NULL, NCONC in cl-conses - -) \ No newline at end of file + ;;Function APPEND + + ;;Function REVAPPEND, NRECONC + + ;;Function BUTLAST, NBUTLAST + + ;; LAST in cl-conses + + ;;Function LDIFF, TAILP + + ;;Function NTHCDR + (swf-defmemfun nthcdr (n list) + (dotimes (a n list) + (setf list (cdr list)))) + + (swf-defmemfun rest (a) + (cdr a)) + + ;;Function MEMBER, MEMBER-IF, MEMBER-IF-NOT + + ;;Function MAPC, MAPCAR, MAPCAN, MAPL, MAPLIST, MAPCON + + ;;Function ACONS + + ;;Function ASSOC, ASSOC-IF, ASSOC-IF-NOT + + ;;Function COPY-ALIST + + ;;Function PAIRLIS + + ;;Function RASSOC, RASSOC-IF, RASSOC-IF-NOT + + ;;Function GET-PROPERTIES + + ;;Accessor GETF + + ;;Macro REMF + + ;;Function INTERSECTION, NINTERSECTION + + ;;Function ADJOIN + + ;;Macro PUSHNEW + + ;;Function SET-DIFFERENCE, NSET-DIFFERENCE + + ;;Function SET-EXCLUSIVE-OR, NSET-EXCLUSIVE-OR + + ;;Function SUBSETP + + ;;Function UNION, NUNION +) diff --git a/lib/cl.lisp b/lib/cl.lisp index 32340c4..02adb60 100644 --- a/lib/cl.lisp +++ b/lib/cl.lisp @@ -13,6 +13,8 @@ (swf-defmemfun 1- (a) (- a 1)) + (swf-defmemfun 1+ (a) + (+ a 1)) (swf-defmemfun floor (number) ;; todo implement optional divisor arg (need multiple values) @@ -72,6 +74,6 @@ (swf-defmacro incf (place &optional (delta 1)) `(%set-local ,place (+ ,place ,delta))) - (swf-defun zerop (x) + (swf-defmemfun zerop (x) (eql x 0)) ) \ No newline at end of file -- 2.11.4.GIT