From c2493e3427215081351e8ab6a0e90aebe946c86d Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Mon, 6 May 2013 14:13:33 +0100 Subject: [PATCH] Move sequence functions to sequence.lisp --- jscl.lisp | 1 + src/boot.lisp | 101 ----------------------------------------------- src/sequence.lisp | 114 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 115 insertions(+), 101 deletions(-) create mode 100644 src/sequence.lisp diff --git a/jscl.lisp b/jscl.lisp index e75e959..84fe550 100644 --- a/jscl.lisp +++ b/jscl.lisp @@ -28,6 +28,7 @@ ("utils" :both) ("list" :target) ("string" :target) + ("sequence" :target) ("print" :target) ("package" :target) ("ffi" :target) diff --git a/src/boot.lisp b/src/boot.lisp index a6b08a9..9e9b027 100644 --- a/src/boot.lisp +++ b/src/boot.lisp @@ -384,78 +384,6 @@ (defun atom (x) (not (consp x))) -(defmacro doseq ((elt seq &optional index) &body body) - (let* ((nseq (gensym "seq")) - (i (or index (gensym "i"))) - (list-body (if index - `(let ((,i -1)) - (dolist (,elt ,nseq) - (incf ,i) - ,@body)) - `(dolist (,elt ,nseq) - ,@body)))) - `(let ((,nseq ,seq)) - (if (listp ,nseq) - ,list-body - (dotimes (,i (length ,nseq)) - (let ((,elt (aref ,nseq ,i))) - ,@body)))))) - -(defun find (item seq &key key (test #'eql)) - (if key - (doseq (x seq) - (when (funcall test (funcall key x) item) - (return x))) - (doseq (x seq) - (when (funcall test x item) - (return x))))) - -(defun remove (x seq) - (cond - ((null seq) - nil) - ((listp seq) - (let* ((head (cons nil nil)) - (tail head)) - (doseq (elt seq) - (unless (eql x elt) - (let ((new (list elt))) - (rplacd tail new) - (setq tail new)))) - (cdr head))) - (t - (let (vector) - (doseq (elt seq index) - (if (eql x elt) - ;; Copy the beginning of the vector only when we find an element - ;; that does not match. - (unless vector - (setq vector (make-array 0)) - (dotimes (i index) - (vector-push-extend (aref seq i) vector))) - (when vector - (vector-push-extend elt vector)))) - (or vector seq))))) - -(defun remove-if (func list) - (cond - ((null list) - nil) - ((funcall func (car list)) - (remove-if func (cdr list))) - (t - ;; - (cons (car list) (remove-if func (cdr list)))))) - -(defun remove-if-not (func list) - (cond - ((null list) - nil) - ((funcall func (car list)) - (cons (car list) (remove-if-not func (cdr list)))) - (t - (remove-if-not func (cdr list))))) - (defun alpha-char-p (x) (or (<= (char-code #\a) (char-code x) (char-code #\z)) (<= (char-code #\Z) (char-code x) (char-code #\Z)))) @@ -493,35 +421,6 @@ (t (error "type-error!")))))) -;; (defun find (item sequence &key (key #'identity) (test #'eql)) -;; (do-sequence (x sequence) -;; (when (funcall test (funcall key x) item) -;; (return x)))) - -(defun find-if (predicate sequence &key (key #'identity)) - (do-sequence (x sequence) - (when (funcall predicate (funcall key x)) - (return x)))) - -(defun some (function seq) - (do-sequence (elt seq) - (when (funcall function elt) - (return-from some t)))) - -(defun every (function seq) - (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 equal (x y) (cond ((eql x y) t) diff --git a/src/sequence.lisp b/src/sequence.lisp new file mode 100644 index 0000000..e5e7aca --- /dev/null +++ b/src/sequence.lisp @@ -0,0 +1,114 @@ +;;; sequence.lisp + +;; JSCL is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; JSCL is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with JSCL. If not, see . + +(defmacro doseq ((elt seq &optional index) &body body) + (let* ((nseq (gensym "seq")) + (i (or index (gensym "i"))) + (list-body (if index + `(let ((,i -1)) + (dolist (,elt ,nseq) + (incf ,i) + ,@body)) + `(dolist (,elt ,nseq) + ,@body)))) + `(let ((,nseq ,seq)) + (if (listp ,nseq) + ,list-body + (dotimes (,i (length ,nseq)) + (let ((,elt (aref ,nseq ,i))) + ,@body)))))) + +(defun find (item seq &key key (test #'eql)) + (if key + (doseq (x seq) + (when (funcall test (funcall key x) item) + (return x))) + (doseq (x seq) + (when (funcall test x item) + (return x))))) + +(defun find-if (predicate sequence &key (key #'identity)) + (do-sequence (x sequence) + (when (funcall predicate (funcall key x)) + (return x)))) + +(defun some (function seq) + (do-sequence (elt seq) + (when (funcall function elt) + (return-from some t)))) + +(defun every (function seq) + (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 remove (x seq) + (cond + ((null seq) + nil) + ((listp seq) + (let* ((head (cons nil nil)) + (tail head)) + (doseq (elt seq) + (unless (eql x elt) + (let ((new (list elt))) + (rplacd tail new) + (setq tail new)))) + (cdr head))) + (t + (let (vector) + (doseq (elt seq index) + (if (eql x elt) + ;; Copy the beginning of the vector only when we find an element + ;; that does not match. + (unless vector + (setq vector (make-array 0)) + (dotimes (i index) + (vector-push-extend (aref seq i) vector))) + (when vector + (vector-push-extend elt vector)))) + (or vector seq))))) + + +;;; TODO: Support vectors + +(defun remove-if (func list) + (cond + ((null list) + nil) + ((funcall func (car list)) + (remove-if func (cdr list))) + (t + ;; + (cons (car list) (remove-if func (cdr list)))))) + +(defun remove-if-not (func list) + (cond + ((null list) + nil) + ((funcall func (car list)) + (cons (car list) (remove-if-not func (cdr list)))) + (t + (remove-if-not func (cdr list))))) -- 1.7.10.4