From c38b7035616ea03b35706e2f180d78955b3b3b38 Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Fri, 30 Aug 2013 21:16:30 +0200 Subject: [PATCH] Tidy basic setf-macros --- src/boot.lisp | 142 ++++++++++++++++++++++------------------------------- src/list.lisp | 37 +++++++++----- src/sequence.lisp | 9 ++++ 3 files changed, 93 insertions(+), 95 deletions(-) diff --git a/src/boot.lisp b/src/boot.lisp index edfc576..cb964e4 100644 --- a/src/boot.lisp +++ b/src/boot.lisp @@ -103,50 +103,6 @@ (defun not (x) (if x nil t)) ;; Basic macros -(defmacro incf (place &optional (delta 1)) - (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place) - (let ((d (gensym))) - `(let* (,@(mapcar #'list dummies vals) - (,d ,delta) - (,(car newval) (+ ,getter ,d)) - ,@(cdr newval)) - ,setter)))) - -(defmacro decf (place &optional (delta 1)) - (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place) - (let ((d (gensym))) - `(let* (,@(mapcar #'list dummies vals) - (,d ,delta) - (,(car newval) (- ,getter ,d)) - ,@(cdr newval)) - ,setter)))) - -(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)))) - -(defmacro pushnew (x place &rest keys &key key test test-not) - (declare (ignore key test test-not)) - (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place) - (let ((g (gensym)) - (v (gensym))) - `(let* ((,g ,x) - ,@(mapcar #'list dummies vals) - ,@(cdr newval) - (,v ,getter)) - (if (member ,g ,v ,@keys) - ,v - (let ((,(car newval) (cons ,g ,getter))) - ,setter)))))) (defmacro dolist ((var list &optional result) &body body) (let ((g!list (gensym))) @@ -250,28 +206,6 @@ ,@decls (tagbody ,@forms))))) - -;;; Go on growing the Lisp language in Ecmalisp, with more high level -;;; utilities as well as correct versions of other constructions. - -(defun append-two (list1 list2) - (if (null list1) - list2 - (cons (car list1) - (append (cdr list1) list2)))) - -(defun append (&rest lists) - (!reduce #'append-two lists nil)) - -(defun revappend (list1 list2) - (while list1 - (push (car list1) list2) - (setq list1 (cdr list1))) - list2) - -(defun reverse (list) - (revappend list '())) - (defmacro psetq (&rest pairs) (let (;; For each pair, we store here a list of the form ;; (VARIABLE GENSYM VALUE). @@ -325,22 +259,6 @@ (list (first v) (third v)))) varlist))))))) -(defun list-length (list) - (let ((l 0)) - (while (not (null list)) - (incf l) - (setq list (cdr list))) - l)) - -(defun length (seq) - (cond - ((stringp seq) - (string-length seq)) - ((arrayp seq) - (oget seq "length")) - ((listp seq) - (list-length seq)))) - (defmacro with-collect (&body body) (let ((head (gensym)) (tail (gensym))) @@ -479,6 +397,64 @@ ((null pairs) (reverse result))))))) +(defmacro incf (place &optional (delta 1)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place) + (let ((d (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (+ ,getter ,d)) + ,@(cdr newval)) + ,setter)))) + +(defmacro decf (place &optional (delta 1)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place) + (let ((d (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (- ,getter ,d)) + ,@(cdr newval)) + ,setter)))) + +(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)))) + +(defmacro pop (place) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place) + (let ((head (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,head ,getter) + (,(car newval) (cdr ,head)) + ,@(cdr newval)) + ,setter + (car ,head))))) + +(defmacro pushnew (x place &rest keys &key key test test-not) + (declare (ignore key test test-not)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place) + (let ((g (gensym)) + (v (gensym))) + `(let* ((,g ,x) + ,@(mapcar #'list dummies vals) + ,@(cdr newval) + (,v ,getter)) + (if (member ,g ,v ,@keys) + ,v + (let ((,(car newval) (cons ,g ,getter))) + ,setter)))))) + + + ;; Incorrect typecase, but used in NCONC. (defmacro typecase (x &rest clausules) (let ((value (gensym))) @@ -517,7 +493,7 @@ (defun notany (fn seq) (not (some fn seq))) -(defconstant internal-time-units-per-second 1000) +(defconstant internal-time-units-per-second 1000) (defun get-internal-real-time () (get-internal-real-time)) diff --git a/src/list.lisp b/src/list.lisp index 36adc0e..b974cd0 100644 --- a/src/list.lisp +++ b/src/list.lisp @@ -61,6 +61,13 @@ ((null (cddr x)) (rplacd x (cadr x)))) (cons arg others)))) +(defun list-length (list) + (let ((l 0)) + (while (not (null list)) + (incf l) + (setq list (cdr list))) + l)) + (defun nthcdr (n list) (while (and (plusp n) list) (setq n (1- n)) @@ -111,6 +118,24 @@ (defun cdddar (x) (cdr (cddar x))) (defun cddddr (x) (cdr (cdddr x))) +(defun append-two (list1 list2) + (if (null list1) + list2 + (cons (car list1) + (append (cdr list1) list2)))) + +(defun append (&rest lists) + (!reduce #'append-two lists nil)) + +(defun revappend (list1 list2) + (while list1 + (push (car list1) list2) + (setq list1 (cdr list1))) + list2) + +(defun reverse (list) + (revappend list '())) + (defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p)) (when (and testp test-not-p) (error "Both test and test-not are set")) @@ -166,18 +191,6 @@ (when (eql tail object) (return-from tailp t)))) -(defmacro pop (place) - (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place) - (let ((head (gensym))) - `(let* (,@(mapcar #'list dummies vals) - (,head ,getter) - (,(car newval) (cdr ,head)) - ,@(cdr newval)) - ,setter - (car ,head))))) - - (defun map1 (func list) (with-collect (while list diff --git a/src/sequence.lisp b/src/sequence.lisp index 880f7fd..62b075e 100644 --- a/src/sequence.lisp +++ b/src/sequence.lisp @@ -15,6 +15,15 @@ (/debug "loading sequence.lisp!") +(defun length (seq) + (cond + ((stringp seq) + (string-length seq)) + ((arrayp seq) + (oget seq "length")) + ((listp seq) + (list-length seq)))) + (defun sequencep (thing) (or (listp thing) (vectorp thing))) -- 1.7.10.4