From ingvar at cathouse.bofh.se Fri Sep 3 19:04:10 2004 From: ingvar at cathouse.bofh.se (Ingvar) Date: Fri, 03 Sep 2004 20:04:10 +0100 Subject: [Small-cl-src] Haven't you always wanted to clean sequences out? Message-ID: ;;; Haven't we all felt the need to sanitize your sequences and making each ;;; element "unique"? I haven't, but I had some spare minutes waiting for ;;; a friend over lunch and since I'd been running the unix command uniq(1) ;;; and been irritated at its shortcomings, this came to be: (defun unique (data &key (test #'eql) (key #'identity)) (let ((acc nil) (type (typecase data (vector 'vector) (string 'string) (list 'list)))) (flet ((frob (data) (unless (member (funcall key data) acc :test test :key key) (push data acc)))) (map nil #'frob data)) (coerce (nreverse acc) type))) From pjb at informatimago.com Fri Sep 3 21:27:19 2004 From: pjb at informatimago.com (Pascal J.Bourguignon) Date: Fri, 3 Sep 2004 23:27:19 +0200 Subject: [Small-cl-src] Haven't you always wanted to clean sequences out? In-Reply-To: References: Message-ID: <16696.57783.949540.496981@thalassa.informatimago.com> Ingvar writes: > ;;; Haven't we all felt the need to sanitize your sequences and making each > ;;; element "unique"? I haven't, but I had some spare minutes waiting for > ;;; a friend over lunch and since I'd been running the unix command uniq(1) > ;;; and been irritated at its shortcomings, this came to be: > > (defun unique (data &key (test #'eql) (key #'identity)) > (let ((acc nil) > (type (typecase data (vector 'vector) (string 'string) (list 'list)))) > (flet ((frob (data) > (unless (member (funcall key data) acc :test test :key key) > (push data acc)))) > (map nil #'frob data)) > (coerce (nreverse acc) type))) (defun unique (data &key (test #'eql) (key #'identity)) (remove-duplicates data :test test :key key)) -- __Pascal Bourguignon__ http://www.informatimago.com/ Our enemies are innovative and resourceful, and so are we. They never stop thinking about new ways to harm our country and our people, and neither do we. From pjb at informatimago.com Fri Sep 10 02:17:39 2004 From: pjb at informatimago.com (Pascal J.Bourguignon) Date: Fri, 10 Sep 2004 04:17:39 +0200 (CEST) Subject: [Small-cl-src] tracing setf Message-ID: <20040910021739.4A7BB483E6@thalassa.informatimago.com> ;; TRACE cannot be applied on "built-ins", and in any case, not on a ;; special operator! So, here is a SETF* macro that will "trace" ;; the assignments. (defmacro setf* (&rest args) `(progn ,@(do ((var args (cddr var)) (body '())) ((null var) (nreverse body)) (push `(setf ,(car var) ,(cadr var)) body) (push `(format *trace-output* "~20:A := (THE ~S ~S) ~%" ',(car var) (type-of ,(car var)) ,(car var)) body))));;setf* ;; [144]> (decode-span-lex-word "*a\rguen~as#") ;; LINE := (THE (SIMPLE-BASE-STRING 9) "arguen~as") ;; (AREF NEW J) := (THE BASE-CHAR #\a) ;; J := (THE BIT 1) ;; I := (THE BIT 1) ;; (AREF NEW J) := (THE BASE-CHAR #\r) ;; J := (THE (INTEGER 0 16777215) 2) ;; I := (THE (INTEGER 0 16777215) 2) ;; (AREF NEW J) := (THE BASE-CHAR #\g) ;; J := (THE (INTEGER 0 16777215) 3) ;; I := (THE (INTEGER 0 16777215) 3) ;; (AREF NEW J) := (THE BASE-CHAR #\u) ;; J := (THE (INTEGER 0 16777215) 4) ;; I := (THE (INTEGER 0 16777215) 4) ;; (AREF NEW J) := (THE BASE-CHAR #\e) ;; J := (THE (INTEGER 0 16777215) 5) ;; I := (THE (INTEGER 0 16777215) 5) ;; (AREF NEW J) := (THE BASE-CHAR #\LATIN_SMALL_LETTER_N_WITH_TILDE) ;; J := (THE (INTEGER 0 16777215) 6) ;; I := (THE (INTEGER 0 16777215) 7) ;; (AREF NEW J) := (THE BASE-CHAR #\a) ;; J := (THE (INTEGER 0 16777215) 7) ;; I := (THE (INTEGER 0 16777215) 8) ;; (AREF NEW J) := (THE BASE-CHAR #\s) ;; J := (THE (INTEGER 0 16777215) 8) ;; I := (THE (INTEGER 0 16777215) 9) ;; LINE := (THE (SIMPLE-BASE-STRING 8) "argue?as") ;; "argue?as" ;; [145]> -- __Pascal Bourguignon__ http://www.informatimago.com/ Our enemies are innovative and resourceful, and so are we. They never stop thinking about new ways to harm our country and our people, and neither do we. From pabw00 at gmail.com Thu Sep 23 01:53:46 2004 From: pabw00 at gmail.com (Peter Wilson) Date: Wed, 22 Sep 2004 18:53:46 -0700 Subject: [Small-cl-src] with-static-types Message-ID: <272abcf7040922185368635a6a@mail.gmail.com> ;;;; WITH-STATIC-TYPES macro ;;; A shorthand macro for specifying inline static types (the type x) without ;;; cluttering the code. As usual for static typing, avoid using it until ;;; fairly late in the optimization phase of your coding. ;;; ;;; This code has not been used anywhere besides the examples below and may ;;; still have undiscovered bugs. ;;; ;;; Be aware of name collisions between functions and variables. The macro ;;; currently only supports one namespace. ;;; ;;; TODO: Handle special forms in the body. Or at least LET. ;;; TODO: When handling LET, insert declarations for variables. ;;; TODO: Handle macros in the body. Probably just macroexpand them. ;;; TODO: Remove compile-time dependency on ITERATE package. ;;; (defpackage #:with-static-types (:use #:cl) (:export #:with-static-types)) (eval-when (:compile-toplevel :load-toplevel :execute) (in-package #:with-static-types) (require "iterate") (use-package '#:iterate)) (defun make-ring (x) "Create a circular list containing x." (let ((c (cons x nil))) (setf (cdr c) c))) (defun lookup-type (typed-functions sym) "Deduce the type of sym using the typed-functions alist. Returns: t value-or-return-type argument-types" (flet ((assert-length=2 (x) (unless (eq (cddr x) nil) (error "WITH-STATIC-TYPES: Not expecting more than one argument after ~S" (car x))))) (let ((found (assoc sym typed-functions))) (if found (destructuring-bind (found return-type . args) found (let ((arg-types (if args (case (car args) ((:argument-types :args) (assert-length=2 args) (cadr args)) ((:all-arguments-type :arg) (assert-length=2 args) (make-ring (cadr args))) (t (if (> (list-length args) 1) args (make-ring (car args))))) (make-ring return-type)))) (return-from lookup-type (values found return-type arg-types)))) nil)))) (defun apply-arg-types (typed-functions arg-types form) "Construct (the)'s for the arguments in form using the typespecs in arg-types." (flet ((recurse (form) (list 'with-static-types typed-functions form))) (list* (car form) (iter (for (arg . a-rest) on (cdr form)) (for (type . t-rest) on arg-types) (collect (list 'the type (recurse arg))) (when (and (null t-rest) (not (null a-rest))) (warn "WITH-STATIC-TYPES: More arguments than types for~& form: ~S~& types: ~S" form arg-types) (dolist (a a-rest) (collect (recurse a)))))))) (defun with-types-helper (typed-functions body) (flet ((recurse (form) (list 'with-static-types typed-functions form))) (iter (for form in body) (if (consp form) (multiple-value-bind (found return-type arg-types) (lookup-type typed-functions (car form)) (if found (collect (list 'the return-type (apply-arg-types typed-functions arg-types form))) ;TODO handle specials and macros here (collect (list* (car form) (mapcar #'recurse (cdr form)))))) (multiple-value-bind (found return-type) (lookup-type typed-functions form) (if found (collect (list 'the return-type form)) (collect form))))))) (defmacro with-static-types (function-typespecs &body body) "Insert type declarations around calls to specific functions. Also happens to work with variables. Usage: WITH-STATIC-TYPES ( spec ... ) body-form ... spec => ( sym result-and-arg-type ) | ( sym result-type all-arg-type ) | ( sym result-type arg-type-1 arg-type-2 ... ) | ( sym result-type :ALL-ARGUMENTS-TYPE all-arg-type ) | ( sym result-type :ARG all-arg-type ) | ( sym result-type :ARGUMENT-TYPES ( arg-type-1 arg-type-2 ... ) ) | ( sym result-type :ARGS ( arg-type-1 arg-type-2 ... ) ) Examples: (WITH-STATIC-TYPES ((+ FIXNUM)) (+ 1 2)) --> (PROGN (THE FIXNUM (+ (THE FIXNUM 1) (THE FIXNUM 2)))) ==> 3 (WITH-STATIC-TYPES ((+ FIXNUM) (/ RATIONAL FIXNUM)) (/ 3 (+ 2 2))) --> (PROGN (THE RATIONAL (/ (THE FIXNUM 3) (THE FIXNUM (THE FIXNUM (+ (THE FIXNUM 1) (THE FIXNUM 2))))))) ==> 3/4 (WITH-STATIC-TYPES ((+ FIXNUM) (/ RATIONAL FIXNUM FIXNUM)) (/ 3 (+ 2 2) 17)) WARNING: WITH-STATIC-TYPES: More arguments than types for form: (/ 3 (+ 2 2) 17) types: (FIXNUM FIXNUM) --> (PROGN (THE RATIONAL (/ (THE FIXNUM 3) (THE FIXNUM (THE FIXNUM (+ (THE FIXNUM 1) (THE FIXNUM 2)))) 17))) ==> 3/68 (WITH-STATIC-TYPES ((x FIXNUM)) x) --> (PROGN (THE FIXNUM x)) ==> Undefined variable x " (if body (list* 'progn (with-types-helper function-typespecs body)) (warn "WITH-STATIC-TYPES: Null body. types: ~S" function-typespecs))) From ingvar at cathouse.bofh.se Thu Sep 23 15:05:50 2004 From: ingvar at cathouse.bofh.se (Ingvar) Date: Thu, 23 Sep 2004 16:05:50 +0100 Subject: [Small-cl-src] What would var+++ be in CL? Message-ID: ;;; Possibly a tad naive, but... (defmacro post-incf (form &optional (increment 1)) (let ((value (gensym "POST-INCF"))) `(let ((,value ,form)) (prog1 ,value (setf ,form (+ ,value ,increment)))))) From peter.lewerin at swipnet.se Tue Sep 28 09:12:47 2004 From: peter.lewerin at swipnet.se (Peter Lewerin) Date: Tue, 28 Sep 2004 11:12:47 +0200 Subject: [Small-cl-src] with-carry Message-ID: <6.0.1.1.0.20040928105942.01a69ec0@pop.swip.net> #| In a reply to me in c.l.l., Adam Warner suggested a control structure for the cases when a computation is made in stages, with the result of each stage used somewhere in the next stage. The following is basically his code; I added a SYMBOL-MACROLET wrapper to be able to name the carry-over variable. See c.l.l. thread "Which style do you prefer?" |# (defmacro with-carry (c stages &body body) (symbol-macrolet ((_ c)) `(let* (,@(loop for item in stages collect (list _ item))) , at body))) ;; (with-carry x ((+ 2 3) (* x 10)) (print x)) ;; => 50 ;; expands to: (LET* ((X (+ 2 3)) (X (* X 10))) (PRINT X))