September 2004 - small-cl-src@common-lisp.net

[Small-cl-src] What would var+++ be in CL?
by Ingvar 06 Jul '05

06 Jul '05

;;; 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))))))

2 1

[Small-cl-src] with-carry
by Peter Lewerin 28 Sep '04

28 Sep '04

#| 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))) ,@body))) ;; (with-carry x ((+ 2 3) (* x 10)) (print x)) ;; => 50 ;; expands to: (LET* ((X (+ 2 3)) (X (* X 10))) (PRINT X))

1 0

[Small-cl-src] with-static-types
by Peter Wilson 22 Sep '04

22 Sep '04

;;;; 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)))

1 0

[Small-cl-src] tracing setf
by Pascal J.Bourguignon 09 Sep '04

09 Sep '04

;; 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.

1 0

[Small-cl-src] Haven't you always wanted to clean sequences out?
by Ingvar 03 Sep '04

03 Sep '04

;;; 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)))

2 1