May 2004 - small-cl-src@common-lisp.net - mailman3.common-lisp.net

[Small-cl-src] apply in terms of funcall
by Andreas Fuchs 06 Jun '04

06 Jun '04

;;; A few months ago, there was a thread about FUNCALL and APPLY on ;;; c.l.l. I wrote this code to show how APPLY might be defined in ;;; terms of FUNCALL. (defun apply-definer (max-args) `(defun my-apply (f &rest args) (case (length args) ,@(loop for arg-count from 0 to max-args collect `((,arg-count) (funcall f ,@(loop for arg-idx from 0 to (1- arg-count) collect `(nth ,arg-idx args))))) (otherwise (error ,(format nil "Can't apply to more than ~A args" max-args)))))) (defmacro define-apply (max-args) (apply-definer (etypecase max-args (symbol (symbol-value max-args)) (number max-args)))) (apply-definer call-arguments-limit) ;;; License: BSD-sans-advertising. -- Andreas Fuchs, <asf(a)boinkor.net>, asf(a)jabber.at, antifuchs

1 1

[Small-cl-src] Funcallable macros
by Lars Brinkhoff 25 May '04

25 May '04

;;; Lisp apprentice's wet dream: funcallable macros. ;;; Probable newbie usage example: (reduce #`and '(t t t nil t t)) ;;; Two implementations are provided: one trivial using eval, and one ;;; that memoizes compiled functions. (defun funcallable-macro (name) (lambda (&rest args) (eval (cons name args)))) (defun funcallable-macro (name) (let ((table (make-hash-table :test #'eql))) (lambda (&rest args) (let ((n (length args))) (apply (or (gethash n table) (setf (gethash n table) (make-funcallable-macro-function name n))) args))))) (defun make-funcallable-macro-function (name n) (let ((args nil)) (dotimes (i n) (push (gensym) args)) (compile nil `(lambda ,args ,(macroexpand `(,name ,@args)))))) (set-dispatch-macro-character #\# #\` (lambda (s c n) `(funcallable-macro ',(read s t nil t))))

1 0

[Small-cl-src] time-utils.lisp
by Helmut Eller 24 May '04

24 May '04

;;; time-utils.lisp --- libc style time formatting functions ;;; ;;; Written by Helmut Eller in May 2004. ;;; ;;; This file provides a two functions: one to parse time strings and ;;; an another to print time values to strings. The interface is ;;; similar to the Emacs functions `format-time-string' and ;;; `parse-time-string'. ;;; ;;; Not the most lispy implementation but it gets the job done. The ;;; code runs in CMUCL. Porting it to another implementation would be ;;; a major pain. ;;; (defpackage :date-utils (:use :cl :unix :alien :c-call) (:export :format-time-string :parse-time-string)) (in-package :date-utils) ;;;; Alien utilities ;;; ;;; I prefer to work with SAPs (system area pointers) over alien ;;; values. Aliens are only used as convenient way to express ;;; offsets in structures. Aliens are never passed to or returned from ;;; functions (too consy). ;;; (def-alien-type tm (struct unix::tm)) (def-alien-type time-t unix::time-t) (def-alien-type sap system-area-pointer) (defmacro memcpy (to from nbytes) `(kernel:system-area-copy ,from 0 ,to 0 (* ,nbytes vm:byte-bits))) (defun malloc (size) (let ((sap (alien-funcall (extern-alien "malloc" (function sap unsigned)) size))) (when (zerop (sys:sap-int sap)) (unix::unix-get-errno) (error "malloc failed: ~S" (unix:get-unix-error-msg))) sap)) (defun free (sap) (alien-funcall (extern-alien "free" (function void sap)) sap)) (defmacro with-growing-buffer ((buffer size &key (initial-size 1024)) &body body) "Execute BODY repeatedly with BUFFER bound to a sap pointing to a block of memory of size SIZE. SIZE is doubled on each iteration. An implicit block named nil surrounds the entire form; body can be terminated by returning to nil." `(block nil (flet ((try (,buffer ,size) ,@body)) (let ((size ,initial-size)) (with-alien ((buffer (array char ,initial-size))) (try (alien-sap (addr buffer)) ,initial-size)) (loop named #:noname do (setf size (* 2 size)) (let ((buffer (malloc size))) (unwind-protect (try buffer size) (free buffer)))))))) (defun format-time-string (format-string &key time universal unix-epoch) "Use FORMAT-STRING to format the time-value TIME. The return value is a copy of FORMAT-STRING, but with certain constructs replaced by text that describes the specified date and time in TIME. (See strftime(3) for details.) TIME is an integer representing the number of seconds since 1900 (or since 1970 if UNIX-EPOCH is true). TIME defaults to the current time. If UNIVERSAL is true, describe TIME as Universal Time; nil means describe TIME in the local time zone." (with-alien ((utime time-t) (brokentime tm) (c/time (function time-t sap) :extern "time") (c/gmtime_r (function sap (* time-t) (* tm)) :extern "gmtime_r") (c/localtime_r (function sap (* time-t) (* tm)) :extern "localtime_r") (c/strftime (function int sap int c-string (* tm)) :extern "strftime")) ;; Compute the Unixy time value (setf utime (cond ((and time unix-epoch) time) (time (- time #.(encode-universal-time 0 0 0 1 1 1970 0))) (t (let ((time (alien-funcall c/time (sys:int-sap 0)))) (if (= time -1) (error "c/time failed: ~A" (get-unix-error-msg)) time))))) ;; break it up (let ((result (if universal (alien-funcall c/gmtime_r (addr utime) (addr brokentime)) (alien-funcall c/localtime_r (addr utime) (addr brokentime))))) (unless (sys:sap= result (alien-sap (addr brokentime))) (error "format-time-string failed"))) ;; print it (with-growing-buffer (buffer size) (setf (sys:sap-ref-8 buffer 0) 1) (let ((count (alien-funcall c/strftime buffer size format-string (addr brokentime)))) (when (or (plusp count) (and (zerop count) (= (sys:sap-ref-8 buffer 0) 0))) (let ((string (make-string count))) (memcpy (sys:vector-sap string) buffer count) (return string))))))) (defun parse-time-string (format-string string &key junk-allowed time-zone) "Parse the time-string STRING into a universal time value. The return values can be used with decode-universal-time." (declare (type string string format-string)) (with-alien ((tm tm) (c/strptime (function sap c-string c-string (* tm)) :extern "strptime")) (vm::system-area-fill 0 (alien-sap (addr tm)) 0 (alien-size tm :bits)) (sys:without-gcing (let ((result (alien-funcall c/strptime string format-string (addr tm)))) (when (zerop (sys:sap-int result)) (error "parse-time-string failed: ~A ~A" string format-string)) (unless (or junk-allowed (= (length string) (sys:sap- result (sys:vector-sap string)))) (error "There is junk in this string: ~A" string)))) (encode-universal-time (slot tm 'unix::tm-sec) (slot tm 'unix::tm-min) (slot tm 'unix::tm-hour) (slot tm 'unix::tm-mday) (1+ (slot tm 'unix::tm-mon)) (+ 1900 (slot tm 'unix::tm-year)) time-zone))) ;;;; Examples: #| (format-time-string "%a, %d %b %Y %H:%M:%S %Z %z") (parse-time-string "%a, %d %b %Y %H:%M:%S " ; ? why doesn't this fail (format-time-string "%a, %d %b %Y %H:%M:%S")) ;; test print/read consistency (let* ((format "%a, %d %b %Y %H:%M:%S") (string1 (format-time-string format)) (time (parse-time-string format string1)) (string2 (format-time-string format :time time))) (assert (equal string2 string1)) string2) |# ;;; time-utils.lisp ends here.

1 0

[Small-cl-src] format-time.lisp
by Zach Beane 24 May '04

24 May '04

;;; ;;; Usage example: ;;; ;;; (format-time nil "~{Dayname}, ~{Monthname} ~:@{Date}") => ;;; "Monday, May 24th" ;;; (defpackage :format-time (:use :cl) (:export :format-time :time-formatter)) (in-package :format-time) ;;; Errors (define-condition format-time-error (error) ((complaint :reader format-time-error-complaint :initarg :complaint) (control-string :reader format-time-error-control-string :initarg :control-string) (offset :reader format-time-error-offset :initarg :offset)) (:report report-format-time-error)) (define-condition format-time-dumb-error (error) ((complaint :initarg :complaint :reader format-time-dumb-error-complaint)) (:report (lambda (condition stream) (write-string (format-time-dumb-error-complaint condition) stream)))) (defun report-format-time-error (condition stream) (format stream "error in time-format: ~A~% ~A~% ~v@T^~%" (format-time-error-complaint condition) (format-time-error-control-string condition) (format-time-error-offset condition))) ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *day-of-week-names* #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) (defvar *month-names* #("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) (defvar *number-suffixes* #("th" "st" "nd" "rd" "th" "th" "th" "th" "th" "th")) (defvar *decoded-time-values* '(second minute hour date month year day daylight-p zone)) (defvar *date-formatters* (make-hash-table :test 'eq))) (defun number-suffix (number) (svref *number-suffixes* (mod number 10))) (defmacro def-date-formatter (name (directive type) args &body body) "Create a format-time directive processor implemented with a function called NAME that processes a directive of type TYPE (one of :STRING OR :NUMERIC) named by DIRECTIVE. ARGS must only consist of symbols in *DECODED-TIME-VALUES*." (assert (subsetp args *decoded-time-values*)) (assert (member type '(:string :numeric))) (let ((ignore-list (set-difference *decoded-time-values* args))) (setf (gethash directive *date-formatters*) name) (setf (get directive 'strftime-type) type) `(defun ,name (,@*decoded-time-values*) (declare (ignore ,@ignore-list)) ,@body))) (def-date-formatter format-dayname (dayname :string) (day) (svref *day-of-week-names* day)) (def-date-formatter format-monthname (monthname :string) (month) (svref *month-names* (1- month))) (def-date-formatter format-day (day :numeric) (day) day) (def-date-formatter format-date (date :numeric) (date) date) (def-date-formatter format-year (year :numeric) (year) year) (def-date-formatter format-yy (yy :numeric) (year) (mod year 100)) (def-date-formatter format-hh (hh :numeric) (hour) hour) (def-date-formatter format-hh12 (hh12 :numeric) (hour) (let ((12hour (mod hour 12))) (if (zerop 12hour) 12 12hour))) (def-date-formatter format-mm (mm :numeric) (minute) minute) (def-date-formatter format-ss (ss :numeric) (second) second) (def-date-formatter format-am (am :string) (hour) (if (< hour 12) "am" "pm")) ;;; parsing the control string (defun make-directive-printer (directive colonp atp) (ecase (get directive 'strftime-type :error) (:string (cond ((not (or colonp atp)) (lambda (arg stream) (write-string arg stream))) ((not colonp) (lambda (arg stream) (write-string (string-upcase arg) stream))) ((not atp) (lambda (arg stream) (dotimes (i 3) (write-char (schar arg i) stream)))) (t (lambda (arg stream) (dotimes (i 3) (write-char (char-upcase (schar arg i)) stream)))))) (:numeric (cond ((not (or colonp atp)) (lambda (arg stream) (princ arg stream))) ((not colonp) (lambda (arg stream) (format stream "~2,'0D" arg))) ((not atp) (lambda (arg stream) (format stream "~2,' D" arg))) (t (lambda (arg stream) (format stream "~D~A" arg (number-suffix arg)))))) (:error (error 'format-time-dumb-error :complaint "unknown format-time directive")))) (defun make-directive-function (name-string colonp atp) (let* ((name (intern (string-upcase name-string) (find-package "FORMAT-TIME"))) (result-func (gethash name *date-formatters*)) (format-func (make-directive-printer name colonp atp))) (lambda (stream second minute hour date month year day daylight-p zone) (funcall format-func (funcall result-func second minute hour date month year day daylight-p zone) stream)))) (defun tokenize-control-string (string) "Convert the control string STRING to a list of constant strings and printing functions. Signals FORMAT-TIME-ERROR if there is a problem with the control string." (declare (string string)) (let ((pos 0) (end (length string)) (results nil)) (loop (when (>= pos end) (return (nreverse results))) (let ((directive (position #\~ string :start pos))) (cond ((null directive) (push (if (zerop pos) string (subseq string pos)) results) (return (nreverse results))) (t (when (< pos directive) (push (subseq string pos directive) results)) (multiple-value-bind (func new-pos) (parse-directive string directive) (push func results) (setf pos new-pos)))))))) (defun parse-directive (string start) "Convert a single directive from STRING starting at START into a processing function." (declare (string string) (fixnum start)) (let ((colonp nil) (atp nil) (posn (1+ start)) (end (length string))) (labels ((pos-error (message &optional (pos posn)) (error 'format-time-error :complaint message :control-string string :offset (1- pos))) (get-char () (if (= posn end) (pos-error "string ended before directive was found") (prog1 (schar string posn) (incf posn))))) (loop (let ((char (get-char))) (case char ((#\:) (if colonp (pos-error "too many colons supplied") (setf colonp t))) ((#\@) (if atp (pos-error "too many at-signs supplied") (setf atp t))) ((#\{) (let ((name-end (position #\} string :start posn))) (if name-end (return (values (handler-case (make-directive-function (subseq string posn name-end) colonp atp) (format-time-dumb-error (condition) (pos-error (format-time-dumb-error-complaint condition) (1+ posn)))) (1+ name-end))) (pos-error "no corresponding close brace")))))))))) ;;; user interface (defun %format-time (stream control-string tz time) (multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time time tz) (dolist (item (tokenize-control-string control-string)) (etypecase item (string (write-string item stream)) (function (funcall item stream second minute hour date month year day daylight-p zone)))))) (defun format-time (stream-designator control-string &key (tz 0) (time (get-universal-time))) "Format a universal time into a human-readable time." (etypecase stream-designator (null (with-output-to-string (stream) (%format-time stream control-string tz time))) (string (with-output-to-string (stream stream-designator) (%format-time stream control-string tz time))) ((member t) (%format-time *standard-output* control-string tz time)) (stream (%format-time stream-designator control-string tz time)))) (defun time-formatter-form (item) (if (stringp item) `(write-string ,item) `(funcall ,item *standard-output* second minute hour date month year day daylight-p zone))) (defun %time-formatter-body (control-string) (let* ((items (tokenize-control-string control-string)) (forms (mapcar #'time-formatter-form items))) `(lambda (*standard-output* &key (tz 0) (time (get-universal-time))) ,@(if (every #'stringp items) `((declare (ignore tz time)) ,@forms) `((multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time time tz) ,@forms)))))) (defmacro time-formatter (control-string) `#',(%time-formatter-body control-string))

1 0

[Small-cl-src] packet.lisp, version 1
by Luke Gorrie 24 May '04

24 May '04

;;; packet.lisp -- Decode TCP/IP packets (version 1) ;;; Written by Luke Gorrie <luke(a)bluetail.com> in May of 2004. ;;; ;;; A PDF version of this source file can be found at: ;;; http://www.bluetail.com/~luke/misc/lisp/packet.pdf ;;; ;;;# Introduction ;;; ;;; This is a program for decoding the packet headers of some TCP/IP ;;; family protocols. It takes a packet (represented as a vector), ;;; decodes all the headers it can, and returns the results in either ;;; association-lists or strucutres. ;;; ;;; This program is a library; it's not very useful in itself. ;;; ;;; Written for recent snapshots of CMUCL. I've used some minor ;;; non-portable features: `ext:collect', `slot-value' on structures, ;;; and (cons T1 T2) type specifiers. (defpackage :packet (:use :common-lisp)) (in-package :packet) ;;;# Top-level interface ;;; ;;; The input for this program is a `buffer' containing an ethernet ;;; frame. ;;; (deftype buffer () "A network packet represented as a vector of octets." '(array octet (*))) (deftype octet () "An unsigned 8-bit byte." '(unsigned-byte 8)) ;;; The program's output is a list of headers that have been decoded ;;; from a buffer. Headers can be represented either as structures or ;;; as association lists, depending on what you'd like. ;;; (deftype header () "A decoded protocol header." '(or structure-header alist-header)) ;;; The structure definition for each protocol header is defined down ;;; below in the same section of code that does the decoding. ;;; (deftype structure-header () "A decoded protocol header represented as a structure." '(or ethernet-header arp-header ipv4-header udp-header)) (deftype alist-header () "A decoded protocol header with fields in an alist. The format is (TYPE-NAME ALIST). TYPE-NAME is the name of the corresponding structure-header." '(cons symbol cons)) ;;; The function `decode' takes a buffer containing a frame and ;;; returns a list of the headers it was able to decode. ;;; (defun decode (buffer format) "Decode headers from BUFFER and return them in a list. The headers are decoded into FORMAT, which can be either :STRUCTURE or :ALIST. Any remaining undecoded data is included as a vector at the end of the list." (grab-headers buffer format)) ;;;# Low-level data-grabbing machinery (declaim (type (or null buffer) *buffer*)) (defvar *buffer* nil "Buffer containing the packet currently being decoded.") (defvar *buffer-position* nil "Current bit-position in *BUFFER*.") (defmacro with-buffer (buffer &body body) "Execute BODY, grabbing input from the beginning of BUFFER." `(let ((*buffer* ,buffer) (*buffer-position* 0)) ,@body)) (defun bit-octet (bit &optional (check-alignment t)) "Convert from bit position to octet position." (multiple-value-bind (quotient remainder) (truncate bit 8) (when (and check-alignment (plusp remainder)) (error "Bit-position ~S is not octet-aligned." bit)) quotient)) (defun octet-bit (octet) "Convert from octet position to bit position." (* 8 octet)) ;;; "Grab" functions consume input from `*buffer*' and advance ;;; `*buffer-position*'. (defun grab-octets (num) "Grab a vector of NUM octets." (let ((start (bit-octet *buffer-position*))) (incf *buffer-position* (* num 8)) (subseq *buffer* start (+ num start)))) (defun grab-ethernet-address () (make-ethernet-address :octets (grab-octets 6))) (defun grab-ipv4-address () (make-ipv4-address :octets (grab-octets 4))) (defun grab-rest () "Grab the rest of the buffer into an octet vector." (prog1 (subseq *buffer* (bit-octet *buffer-position*)) (setf *buffer-position* (octet-bit (length *buffer*))))) ;;; I've written this function countless times but it always comes out ;;; ugly. What's the right way? (defun grab-bits (bits) "Grab a BITS-long unsigned integer" (let ((accumulator 0) (remaining bits)) (flet ((accumulate-byte () ;; Accumulate the relevant part of the current byte and ;; advance to the next one. (let* ((size (min remaining (- 8 (rem *buffer-position* 8)))) (offset (rem (- 8 (rem (+ *buffer-position* size) 8)) 8)) (value (ldb (byte size offset) (aref *buffer* (bit-octet *buffer-position* nil))))) (decf remaining size) (setf accumulator (dpb value (byte size remaining) accumulator)) (incf *buffer-position* size)))) (loop while (plusp remaining) do (accumulate-byte)) accumulator))) (defun grab-bitflag () "Grab a single bit. Return T if it's 1 and NIL if it's 0." (= (grab-bits 1) 1)) ;;;# Protocol implementations ;;; ;;; The interface to each protocol is `(map-<protocol>-header ;;; FUNCTION)'. Function takes two arguments: a header name and its ;;; value. The function is called for each decoded header. It can ;;; accumulate the values any way it likes. (defvar *resolve-protocols* t "When non-nil protocol numbers are resolved to symbolic names. Unrecognised numbers are left as numbers.") (defvar *verify-checksums* t "When non-nil verify checksums in packets.") (deftype checksum-ok-p () "The status of a packet's checksum. T means the checksum is correct, NIL means it is wrong, and :UNKNOWN means it hasn't been checked." '(member t nil :unknown)) (defun lookup (key alist &key (errorp t) (reversep nil)) "Lookup the value of KEY in ALIST. If the key is not present and ERRORP is true then an error is signalled; if ERRORP is nil then the key itself is returned." (let ((entry (funcall (if reversep #'rassoc #'assoc) key alist))) (cond (entry (funcall (if reversep #'car #'cdr) entry)) (errorp (error "Key ~S is not present in ~A." key alist)) (t key)))) ;;;## Ethernet ;;;### ethernet-address ;;; ;;; This big `eval-when' is needed to define the read-syntax for ;;; `ethernet-address' such that it can be used in this file. ;;; ;;; The read syntax is `#e"ff:00:1:2:3:4'. ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (ethernet-address (:conc-name #:ethernet-address.) (:print-function print-ethernet-address)) "48-bit Ethernet MAC address." (octets (ext:required-argument) :type (array octet (6)))) (defun read-ethernet-address (stream &optional c n) "Read an ethernet address in colon-separated syntax. Example: #e\"1:2:3:4:5:6\"" (declare (ignore c n)) (let ((value-stream (make-string-input-stream (read stream t nil t))) (*readtable* (copy-readtable)) (*read-base* 16)) (set-syntax-from-char #\: #\Space) (let ((vec (make-array '(6) :element-type 'octet))) (dotimes (i 6) (let ((octet (read value-stream t nil t))) (unless *read-suppress* (setf (elt vec i) octet)))) (unless *read-suppress* (make-ethernet-address :octets vec))))) (set-dispatch-macro-character #\# #\e 'read-ethernet-address) (defun print-ethernet-address (address stream depth) "Print ethernet addresses as in #e\"0:ff:1:2:3:4\"." (declare (ignore depth)) (format stream "#e\"~{~16,2,'0R~^:~}\"" (coerce (ethernet-address.octets address) 'list))) (defmethod make-load-form ((s ethernet-address) &optional env) (make-load-form-saving-slots s :environment env))) ;;;### Decoder (defstruct (ethernet-header (:conc-name #:ethernet-header.)) (dest nil :type (or null ethernet-address)) (source nil :type (or null ethernet-address)) (protocol nil :type (or null (unsigned-byte 16) symbol))) (defvar ethernet-protocol-names '((#x0806 . :arp) (#x0800 . :ipv4)) "Mapping from ethernet protocol numbers to symbolic names.") (defun map-ethernet-header (function) "Grab an ethernet header and call FUNCTION with each part." (flet ((header (name value) (funcall function name value))) (header 'dest (grab-ethernet-address)) (header 'source (grab-ethernet-address)) (header 'protocol (ethernet-protocol-name (grab-bits 16))))) (defun ethernet-protocol-name (number) "Return the symbolic protocol name of NUMBER, if appropriate." (if *resolve-protocols* (lookup number ethernet-protocol-names :errorp nil) number)) ;;;## ARP (defstruct (arp-header (:conc-name #:arp-header.)) (hardware-type nil :type (or null (unsigned-byte 16))) (protocol-type nil :type (or null (unsigned-byte 16))) (hardware-length nil :type (or null (unsigned-byte 8))) (protocol-length nil :type (or null (unsigned-byte 8))) (operation nil :type (or null symbol (unsigned-byte 16))) (sender-ha nil :type (or null ethernet-address)) (sender-ip nil :type (or null ipv4-address)) (target-ha nil :type (or null ethernet-address)) (target-ip nil :type (or null ipv4-address))) (defun map-arp-header (function) "Grab an ARP header and call FUNCTION with each part." (flet ((header (name value) (funcall function name value))) (header 'hardware-type (grab-bits 16)) (header 'protocol-type (grab-bits 16)) (header 'hardware-length (grab-bits 8)) (header 'protocol-length (grab-bits 8)) (header 'operation (arp-operation (grab-bits 16))) (header 'sender-ha (grab-ethernet-address)) (header 'sender-ip (grab-ipv4-address)) (header 'target-ha (grab-ethernet-address)) (header 'target-ip (grab-ipv4-address)))) (defvar arp-operation-names '((1 . :request) (2 . :response)) "Mapping between ARP operation numbers and their symbolic names.") (defun arp-operation (operation) "Return the symbolic name for OPERATION, if appropriate." (if *resolve-protocols* (lookup operation arp-operation-names :errorp nil) operation)) ;;;## IPv4 ;;; ;;; The Internet Protocol is described in RFC791. ;;; ;;;### ipv4-address ;;; ;;; IP addresses also have a special read-syntax: `(a)10.0.0.1'. ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (ipv4-address (:conc-name #:ipv4-address.) (:print-function print-ipv4-address)) (octets (ext:required-argument) :type (array octet (4)))) (defun read-ipv4-address (stream &optional c n) "Read an IPv4 address in dotted-quad format. Example: @192.168.0.1" (declare (ignore c n)) (let ((*readtable* (copy-readtable))) (set-syntax-from-char #\. #\Space) (let ((vec (make-array '(4) :element-type 'octet))) (dotimes (i 4) (let ((octet (read stream t nil t))) (unless *read-suppress* (setf (elt vec i) octet)))) (unless *read-suppress* (make-ipv4-address :octets vec))))) (set-macro-character #\@ 'read-ipv4-address t) (defun print-ipv4-address (address stream depth) "Print IPv4 addresses as in @192.168.0.1." (declare (ignore depth)) (format stream "@~{~A~^.~}" (coerce (ipv4-address.octets address) 'list))) (defmethod make-load-form ((s ipv4-address) &optional env) (make-load-form-saving-slots s :environment env))) ;;;### decoder (defstruct (ipv4-header (:conc-name #:ipv4-header.)) (version nil :type (or null (unsigned-byte 4))) (hlen nil :type (or null (unsigned-byte 4))) (tos nil :type (or null (unsigned-byte 8))) (total-len nil :type (or null (unsigned-byte 16))) (id nil :type (or null (unsigned-byte 16))) (flags nil :type (or null (unsigned-byte 3))) (fragment-offset nil :type (or null (unsigned-byte 13))) (ttl nil :type (or null (unsigned-byte 8))) (protocol nil :type (or null symbol (unsigned-byte 8))) (checksum nil :type (or null (unsigned-byte 16))) (source nil :type (or null ipv4-address)) (dest nil :type (or null ipv4-address)) ;; Synthetic: (checksum-ok-p nil :type checksum-ok-p)) (defconstant ipv4-min-hlen 5 "The header length (in 32-bit words) of an IPv4 packet with no options.") (defun map-ipv4-header (function) (flet ((header (name value) (funcall function name value))) (let ((header-start-pos (bit-octet *buffer-position*)) hlen checksum) (header 'version (grab-bits 4)) (header 'hlen (setf hlen (grab-bits 4))) (header 'tos (grab-bits 8)) (header 'total-len (grab-bits 16)) (header 'id (grab-bits 16)) (header 'flags (grab-bits 3)) (header 'fragment-offset (grab-bits 13)) (header 'ttl (grab-bits 8)) (header 'protocol (if *resolve-protocols* (ipv4-protocol (grab-bits 8)) (grab-bits 8))) (header 'checksum (setf checksum (grab-bits 16))) (header 'source (grab-ipv4-address)) (header 'dest (grab-ipv4-address)) ;; FIXME (unless (= hlen ipv4-min-hlen) (error "Can't decode options in IPv4 packets.")) (if *verify-checksums* (let* ((initial (- checksum)) (header-octets (* hlen 4)) (computed-checksum (checksum *buffer* header-start-pos header-octets initial))) (header 'checksum-ok-p (eql checksum computed-checksum))) (header 'checksum-ok-p :unknown))))) (defvar ipv4-protocol-names '((1 . :icmp) (6 . :tcp) (17 . :udp)) "Mapping between IPv4 protocol numbers and their symbolic names.") (defun ipv4-protocol (number) "Return the symbolic name for protocol NUMBER, if appropriate." (if *resolve-protocols* (lookup number ipv4-protocol-names :errorp nil) number)) ;;;## UDP ;;; RFC 768 (defstruct (udp-header (:conc-name #:udp-header.)) (src-port nil :type (or null (unsigned-byte 16))) (dest-port nil :type (or null (unsigned-byte 16))) (length nil :type (or null (unsigned-byte 16))) (checksum nil :type (or null (unsigned-byte 16))) (checksum-ok-p nil :type checksum-ok-p)) (defun map-udp-header (function &optional src-ip dest-ip) "Grab a UDP header and call FUNCTION with each part. The checksum can only be checked if the SRC-IP and DEST-IP fields from the IPv4 header are supplied." (flet ((header (name value) (funcall function name value))) (let ((header-start (bit-octet *buffer-position*)) checksum length) (header 'src-port (grab-bits 16)) (header 'dest-port (grab-bits 16)) (header 'length (setf length (grab-bits 16))) (header 'checksum (setf checksum (grab-bits 16))) (if (and *verify-checksums* src-ip dest-ip) (or (zerop checksum) ; checksum is optional (let ((init (- (udp-pseudo-header-checksum-acc src-ip dest-ip length) checksum))) (header 'checksum-ok-p (= checksum (checksum *buffer* header-start length init))))) (header 'checksum-ok-p :unknown))))) (defun udp-pseudo-header-checksum-acc (src-ip dest-ip udp-length) (+ (checksum-acc-ipv4-address src-ip) (checksum-acc-ipv4-address dest-ip) (lookup :udp ipv4-protocol-names :reversep t) udp-length)) ;;;# Checksum computation ;;; ;;; The TCP/IP protocols use 16-bit ones-complement checksums. See ;;; RFC1071 for details. (defun checksum (buffer &optional (position 0) (length (length buffer)) (initial 0)) "Compute the checksum of a region in BUFFER. POSITION and LENGTH are both in octets. INITIAL is the initial checksum value as a normal integer." (finish-checksum (compute-checksum buffer position length initial))) (defun compute-checksum (buffer &optional (position 0) (length (length buffer)) (initial 0)) "Compute a checksum using normal twos-complement arithmetic. The buffer is treated as a sequence of 16-bit big-endian numbers." (declare (type buffer buffer)) (let ((last-pos (+ position (1- length))) (acc initial)) (do ((msb-pos position (+ msb-pos 2)) (lsb-pos (1+ position) (+ lsb-pos 2))) ((> lsb-pos last-pos) acc) (let ((lsb (aref buffer lsb-pos)) (msb (if (> msb-pos last-pos) 0 (aref buffer msb-pos)))) (incf acc (dpb msb (byte 8 8) lsb)))))) (defun checksum-acc-ipv4-address (address) "Return the partial checksum accumulated from an IPv4 address." (compute-checksum (ipv4-address.octets address))) (defun finish-checksum (n) "Convert N into an unsigned 16-bit ones-complement number. The result is a bit-pattern also represented as an integer." (let* ((acc (+ (ldb (byte 16 16) n) (ldb (byte 16 0) n))) (acc (+ acc (ldb (byte 16 16) acc)))) (logxor #xFFFF (ldb (byte 16 0) acc)))) ;;;# Creating headers (defun grab-header-into-alist (type) "Grab a header of TYPE into an `alist-header'." (ext:collect ((fields)) (funcall (mapping-function type) (lambda (header value) (fields (cons header value)))) (fields))) (defun grab-header-into-structure (type) "Grab a header of TYPE into a `structure-header'." (let ((structure (make-instance type))) (funcall (mapping-function type) (lambda (slot value) (setf (slot-value structure slot) value))) structure)) ;;;# Header-decoding driver (defvar *format* nil "Which format to decode headers in, either :STRUCTURE or :ALIST.") (defvar *previous-header* nil "Bound to the previously decoded header. Some protocols (e.g. UDP) need to retrieve fields from their enclosing protocol's header.") (defun grab-headers (buffer format) "Return a list of decoded headers from BUFFER in FORMAT." (with-buffer buffer (let* ((*format* format) (headers (grab-more-headers (grab-header :ethernet))) (rest (grab-rest))) (if (zerop (length rest)) headers (append headers (list rest)))))) (defun grab-more-headers (header) "Accumulate HEADER and continue decoding the rest." (let ((*previous-header* header)) (if (member (header-type header) '(ethernet-header ipv4-header)) (let ((inner-protocol (get-header-field header 'protocol))) (cons header (grab-more-headers (grab-header inner-protocol)))) ;; This is the last header we know how to decode. (list header)))) (defun grab-header (protocol) "Grab and return the header of PROTOCOL." (let ((type (structure-type-for-protocol protocol))) (ecase *format* (:alist (make-alist-header type (grab-header-into-alist type))) ((:structure) (grab-header-into-structure type))))) (defun make-alist-header (type fields-alist) "Make an `alist-header'." (list type fields-alist)) (defvar protocol-header-types '((:ethernet . ethernet-header) (:ipv4 . ipv4-header) (:arp . arp-header) (:udp . udp-header)) "Association list matching protocol names with their header types.") (defun structure-type-for-protocol (protocol) "Lookup the header type for PROTOCOL." (lookup protocol protocol-header-types)) (defun header-type (header) "Return the type of HEADER. This is the name of the corresponding structure-type, even if the header is in alist format." (etypecase header (alist-header (first header)) (structure-header (type-of header)))) (defun get-header-field (header field) "Return the value of FIELD in HEADER." (declare (type header header)) (etypecase header (alist-header (cdr (assoc field (second header)))) (structure-header (slot-value header field)))) (defun mapping-function (type) "Return the appropriate field-mapping function for TYPE." (ecase type (ethernet-header #'map-ethernet-header) (arp-header #'map-arp-header) (ipv4-header #'map-ipv4-header) (udp-header ;; Pass on the IP addresses for checksum computation. (let ((src-ip (get-header-field *previous-header* 'source)) (dest-ip (get-header-field *previous-header* 'dest))) (lambda (function) (map-udp-header function src-ip dest-ip)))))) ;;;# Sample packets (defvar arp-packet (coerce #(255 255 255 255 255 255 0 8 116 228 110 188 8 6 0 1 8 0 6 4 0 1 0 8 116 228 110 188 192 168 128 44 0 0 0 0 0 0 192 168 128 1) 'buffer) "An ethernet frame containing an ARP request.") (defvar udp-packet (coerce #(255 255 255 255 255 255 0 8 116 228 110 188 8 0 69 0 0 124 0 0 64 0 64 17 183 244 192 168 128 44 192 168 128 255 128 117 0 111 0 104 5 206 20 15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0 2 0 0 0 5 0 0 0 1 0 0 0 24 64 158 126 39 0 0 0 4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0 0 0 12 98 108 117 101 116 97 105 108 46 99 111 109) 'buffer) "An ethernet frame containing a UDP packet.") (defun test () "Test that the sample packets are decoded correctly." (let ((alist-arp (decode arp-packet :alist)) (alist-udp (decode udp-packet :alist)) (struct-arp (decode arp-packet :structure)) (struct-udp (decode udp-packet :structure))) (assert (equalp alist-arp '((ETHERNET-HEADER ((DEST . #e"FF:FF:FF:FF:FF:FF") (SOURCE . #e"00:08:74:E4:6E:BC") (PROTOCOL . :ARP))) (ARP-HEADER ((HARDWARE-TYPE . 1) (PROTOCOL-TYPE . 2048) (HARDWARE-LENGTH . 6) (PROTOCOL-LENGTH . 4) (OPERATION . :REQUEST) (SENDER-HA . #e"00:08:74:E4:6E:BC") (SENDER-IP . @192.168.128.44) (TARGET-HA . #e"00:00:00:00:00:00") (TARGET-IP . @192.168.128.1)))))) (assert (equalp alist-udp `((ETHERNET-HEADER ((DEST . #e"FF:FF:FF:FF:FF:FF") (SOURCE . #e"00:08:74:E4:6E:BC") (PROTOCOL . :IPV4))) (IPV4-HEADER ((VERSION . 4) (HLEN . 5) (TOS . 0) (TOTAL-LEN . 124) (ID . 0) (FLAGS . 2) (FRAGMENT-OFFSET . 0) (TTL . 64) (PROTOCOL . :UDP) (CHECKSUM . 47092) (SOURCE . @192.168.128.44) (DEST . @192.168.128.255) (CHECKSUM-OK-P . T))) (UDP-HEADER ((SRC-PORT . 32885) (DEST-PORT . 111) (LENGTH . 104) (CHECKSUM . 1486) (CHECKSUM-OK-P . T))) ,(coerce #(20 15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0 2 0 0 0 5 0 0 0 1 0 0 0 24 64 158 126 39 0 0 0 4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0 0 0 12 98 108 117 101 116 97 105 108 46 99 111 109) 'buffer)))) (assert (equivalentp alist-arp struct-arp)) (assert (equivalentp alist-udp struct-udp)) t)) (defun equivalentp (alist-headers structure-headers) "Do ALIST-HEADERS and STRUCTURE-HEADERS have the same slot values?" (if (and (null alist-headers) (null structure-headers)) t (destructuring-bind ((ah &rest arest) (sh &rest srest)) (list alist-headers structure-headers) (and (cond ((and (typep ah 'buffer) (typep sh 'buffer)) (equalp ah sh)) ((eq (header-type ah) (header-type sh)) (loop for (key . value) in (second ah) always (equalp (slot-value sh key) value)))) (equivalentp arest srest)))))

1 0

[Small-cl-src] Transforming recursion into dynamic programming
by Darius Bacon 18 May '04

18 May '04

;;; Everyone's seen Lisp code to automatically memoize a function. ;;; This is a bit different: it changes the evaluation order from ;;; top-down to bottom-up. A recursive call turns into a direct ;;; reference into the memo table, with no check for whether that ;;; part of the table has been computed yet. See the discussion at ;;; http://lambda.weblogs.com/discuss/msgReader$6437 defmacro defun-recurrence (name params inits &body body) "Define a recursive function that's evaluated by dynamic programming, bottom-up from the INITS values to the PARAMS values." (let ((tabulate-name (concat-symbol "TABULATE-" name)) (table `(make-array (list ,@(mapcar (lambda (p) `(+ ,p 1)) params)))) (ranges (mapcar (lambda (p init) `(for ,p from ,init to ,p)) params inits))) `(progn (defun ,tabulate-name ,params (tabulate ,name ,table ,ranges ,@body)) (defun ,name ,params (aref (,tabulate-name ,@params) ,@params))))) (defmacro tabulate (name table-exp ranges &body body) "Evaluate a recursive function by dynamic programming, returning the memo-table." (let ((table (gensym)) (vars (mapcar #'second ranges))) `(let ((,table ,table-exp)) ,(nest-loops ranges `(setf (aref ,table ,@vars) (flet ((,name ,vars (aref ,table ,@vars))) ,@body))) ,table))) (defun nest-loops (ranges body-exp) "Build a nested LOOP form." (if (null ranges) body-exp `(loop ,@(car ranges) do ,(nest-loops (cdr ranges) body-exp)))) (defun concat-symbol (&rest parts) "Concatenate symbols or strings to form an interned symbol." (intern (format nil "~{~a~}" parts)))

1 0

[Small-cl-src] serve-event-tricky.lisp
by Luke Gorrie 14 May '04

14 May '04

;;; There was a recent threads on comp.lang.lisp about SERVE-EVENT. I ;;; was having trouble articulating some issues, so I wrote this small ;;; demonstration program to clear my thinking. ;;; ;;; More examples are possible. Post 'em if you find 'em! ;;; serve-event-tricky.lisp -- Tricky examples of SERVE-EVENT ;;; First version, written by Luke Gorrie in May 2004. ;;; ;;; A nice pretty PDF version of this program can be downloaded from: ;;; http://www.bluetail.com/~luke/misc/lisp/serve-event-tricky.pdf ;;; ;;;# Introduction ;;; ;;; This is a small example to show some tricky aspects of using the ;;; `SERVE-EVENT' framework in CMUCL. First we define a simple server ;;; program, then we write some small clients to provoke it into ;;; behaving badly. (in-package :cl-user) (defvar port 10000 "The TCP port for the server.") ;;; We will often want to print short messages, so here is a helpful ;;; little utility: (defun say (format &rest args) "Print a formatted message to standard-output on a fresh line." (format t "~&~?~%" format args) (force-output)) ;;;# The server ;;; ;;; The server binds a listening socket and loops accepting ;;; connections. For each connection it calls READ, prints the result, ;;; and closes the socket. All I/O scheduling is driven by ;;; `SERVE-EVENT'. ;;; ;;; The server reports abnormal exits and unhandled conditions from ;;; handlers. (defun run-server () "Run the server in a loop until aborted." (let ((listen-socket (start-server))) (unwind-protect (server-loop) (stop-server listen-socket)))) (defun start-server () "Start the server." (let ((socket (ext:create-inet-listener port :stream :reuse-address t)) (nr-connections 0)) (sys:add-fd-handler socket :input (lambda (s) (server-accept (incf nr-connections) s))) socket)) (defun server-loop () "Loop serving requests until aborted. If an error is raised then it is printed and the loop continues." (with-simple-restart (stop-server "Stop the example server.") (handler-case (loop (sys:serve-all-events)) (error (err) (say "Continuing after error: ~A" (type-of err)))))) (defun stop-server (socket) (sys:invalidate-descriptor socket) (close-socket socket)) (defun server-accept (nr listen-socket) "Accept new connection number NR from LISTEN-SOCKET. This is a callback for when SERVE-EVENT detects a new connection." (sys:add-fd-handler (accept-tcp-connection listen-socket) :input (lambda (socket) (server-handle-connection nr socket)))) (defun server-handle-connection (number socket) "Handle connection NUMBER on SOCKET. Try to READ one sexp from the socket and print it. Also print a message if we lose control (the stack unwinds) unexpectedly. This is a callback for when SERVE-EVENT detects available data." (let ((stream (sys:make-fd-stream socket :input t)) (successful nil)) (unwind-protect (with-standard-io-syntax (say "Connection #~D read ~A" number (read stream)) (setq successful t)) (close-connection stream) (unless successful (say "Connection #~D aborted!" number))))) (defun close-connection (stream) (sys:invalidate-descriptor (sys:fd-stream-fd stream)) (when (open-stream-p stream) (close stream))) ;;;# The client ;;; ;;; The client part is just a few utilities for opening sockets and ;;; sending strings. (defun make-client () "Connect to the server and return the (unbuffered) output stream." (let ((fd (connect-to-inet-socket "localhost" port))) (sys:make-fd-stream fd :output t :buffering :none))) (defmacro with-clients ((&rest variables) &body body) "Bind VARIABLES to new connections to the server and execute BODY. Ensure the connections are closed before returning." `(let ,(mapcar (lambda (var) (list var '(make-client))) variables) (unwind-protect (progn ,@body) (dolist (client (list ,@variables)) (close-connection client))))) (defun send (client string) "Send STRING to CLIENT and pause a moment to let the server process it." (princ string client) (sleep 0.1)) ;;;# Test cases ;;; ;;; Our task now is to write clients that provoke undesirable ;;; behaviour from the server. To test the programs you should start ;;; two Lisp systems and load this file in both. Then in one you do ;;; `(run-server)' and in the other you can call the exploit functions ;;; defined below. ;;; ;;; An important tool is being able to make the server enter calls to ;;; `READ' and choosing when to allow them to exit. We can do this by ;;; sending a SEXP in two parts -- the first causes the server to ;;; start reading, and it can't finish until we send the rest. (defparameter first-half "(foo" "The first half of a SEXP.") (defparameter second-half "bar)" "The other half of the SEXP.") ;;;## Delay exploit ;;; ;;; Clients can case delays for each other. Here is a case with two ;;; clients, A and B, where A must wait for B to finish a request ;;; before being able to proceed, even though all of A's data is ;;; available to the server. (defun delay () (with-clients (a b) (send a first-half) (send b first-half) (send a second-half) (sleep 5) (send b second-half))) ;;; The expected output is for the server to say nothing for a few ;;; seconds, and then print: ;; Connection #2 read (FOOBAR) ;; Connection #1 read (FOOBAR) ;;; Here's why: ;;; ;;; Both clients connect and send half of a request, with A sending ;;; first. The server enters "blocking" `READ's, first for A and then ;;; for B, and awaits more input. The relevant parts of the server's ;;; Lisp stack look like this: ;;; ;; (SERVE-EVENT) ;; (READ B) ;; (SERVE-EVENT) ;; (READ A) ;; (SERVE-EVENT) ;; (SERVER-LOOP) ;;; ;;; Next A sends the rest of his request. But what can we do with it? ;;; Nothing yet: we cannot return from `(READ A)' without first ;;; returning from `(READ B)', and B is still blocking. A must wait ;;; for B's request to complete. In the test case this takes a few ;;; seconds. ;;; ;;; This case can occur if the network fails between client and ;;; server, and it's easy to trigger deliberately (maliciously). A ;;; timeout of some kind is required to break out of the problem. ;;;## Error propagation exploit ;;; ;;; Another issue presents itself from looking at the previous stack ;;; diagram. What if an unhandled condition is signalled in the `READ' ;;; of B? With our server it will propagate right up the stack and be ;;; handled by `SERVER-LOOP'. That means that an error triggered by ;;; client B will cause client A's handler to be unwound from the ;;; stack, aborting his connection in the process. (defun error-propagation () (with-clients (a b) (send a first-half) (send b "#@ <- illegal read syntax: will trigger an error.") (ignore-errors (send a second-half)))) ;;; The expected output on the server is: ;; Connection #2 aborted! ;; Connection #1 aborted! ;; Continuing after error: READER-ERROR ;;;# Conclusion ;;; ;;; `SERVE-EVENT' presents a simple interface and makes it easy to ;;; write common server programs. However, you have to be thoughtful ;;; about how you use it, and be aware of what's on the ;;; stack. Otherwise you could be eaten alive on the big bad internet.

1 0

[Small-cl-src] sparse-set.lisp
by Nathan Froyd 14 May '04

14 May '04

;;;; sparse-set.lisp -- yet another set abstraction ;;; ;;; Written by Nathan Froyd <froydnj(a)cs.rice.edu>. ;;; ;;; Sparse sets handle sets of integers over the universe { 0, 1, ... , ;;; N-1 } where N is specified when the set is created. "Great," you ;;; say, "why not use bit vectors?" Many common set operations on bit ;;; vectors are O(N), whereas common set operations on sparse sets are ;;; O(n), where n is the number of elements actually in the set, rather ;;; than the size of the universe. In particular, iterating over the ;;; elements of a sparse set is O(n). In addition, several useful ;;; operations only take constant time, such as clearing the set, ;;; determining whether an element is a member of the set, adding and ;;; deleting members, and choosing an arbitrary element from the set. ;;; ;;; The one downside is that sparse sets are heavyweight objects, ;;; requiring O(N) space per set--the constant is fairly large, eight ;;; bytes or so. ;;; ;;; This implementation is based off of the paper "An Efficient ;;; Representation for Sparse Sets" by Preston Briggs and Linda Torczon. ;;; The maximum number of elements allowed in a sparse set is ;;; MOST-POSITIVE-FIXNUM. (defpackage #:sparse-set (:use :cl) (:export #:make-sset #:dosset #:memberp #:add-member #:delete-member #:clear #:copy #:pick #:size #:union #:intersection #:difference #:complement) (:shadow cl:intersection cl:union cl:complement)) (in-package #:sparse-set) (deftype sparse-set-element () '(integer 0 #.most-positive-fixnum)) (deftype sparse-set-array () '(simple-array sparse-set-element (*))) (defstruct (sset (:constructor %make-sset (universe-size sparse dense)) (:print-function %print-sset)) (sparse (error "A required argument was not provided.") :type sparse-set-array :read-only t) (dense (error "A required argument was not provided.") :type sparse-set-array :read-only t) (universe-size (error "A required argument was not provided.") :type sparse-set-element :read-only t) (size 0 :type sparse-set-element)) (defun %print-sset (sset stream depth) (declare (ignore depth)) (print-unreadable-object (sset stream) (format stream "Sparse-Set ~A/~A" (sset-size sset) (sset-universe-size sset)))) (defun make-sset (size) "Creates a new, empy sparse set holding SIZE elements." (declare (type sparse-set-element size)) (let ((sparse (make-array size :element-type 'sparse-set-element)) (dense (make-array size :element-type 'sparse-set-element))) (%make-sset size sparse dense))) (eval-when (:load-toplevel :compile-toplevel :execute) (defmacro dosset ((elem sset &optional result) &body body) (let ((index (gensym)) (dense (gensym)) (set (gensym))) `(let* ((,set ,sset) (,dense (sset-dense ,set))) (declare (type sparse-set-array ,dense)) (dotimes (,index (sset-size ,set) ,result) (declare (type fixnum ,index)) (let ((,elem (aref ,dense ,index))) ,@body))))) ) ; EVAL-WHEN ;;; consistency checks (defun check-inside-universe (sset k) (unless (<= 0 k (1- (sset-universe-size sset))) (error 'type-error :datum k :expected-type `(integer 0 ,(1- (sset-universe-size sset)))))) (defun check-compatible-universes (sset1 sset2) (unless (= (sset-universe-size sset1) (sset-universe-size sset2)) (error "~A and ~A do not have the same universe size." sset1 sset2))) ;;; the safe exported versions (defun memberp (sset k) "Determines whether K is a member of SSET." (check-inside-universe sset k) (%memberp sset k)) (defun add-member (sset k) "Adds K to SSET." (check-inside-universe sset k) (%add-member sset k)) (defun delete-member (sset k) "Deletes K from SSET." (check-inside-universe sset k) (%delete-member sset k)) ;;; unsafe internal functions without argument checking (defun %memberp (sset k) (let ((a (aref (sset-sparse sset) k))) (and (< a (sset-size sset)) (= (aref (sset-dense sset) a) k)))) (defun %add-member (sset k) (let ((a (aref (sset-sparse sset) k)) (n (sset-size sset))) (when (or (>= a n) (not (= (aref (sset-dense sset) a) k))) (setf (aref (sset-sparse sset) k) n (aref (sset-dense sset) n) k (sset-size sset) (1+ n))))) (defun %delete-member (sset k) (let ((a (aref (sset-sparse sset) k)) (n (1- (sset-size sset)))) (when (and (<= a n) (= (aref (sset-dense sset) a) k)) (let ((e (aref (sset-dense sset) n))) (setf (sset-size sset) n (aref (sset-dense sset) a) e (aref (sset-sparse sset) e) a))))) (defun clear (sset) "Removes all elements from SSET." (setf (sset-size sset) 0)) (defun size (sset) "Returns the number of elements in SSET." (sset-size sset)) (defun pick (sset) "Returns an arbitrary member of the set, NIL if the set has no members." (if (zerop (sset-size sset)) nil (aref (sset-dense sset) 0))) (defun copy (sset) "Creates a duplicate of the given SSET." (let ((sset-copy (%make-sset (sset-universe-size sset) (copy-seq (sset-sparse sset)) (copy-seq (sset-dense sset))))) (setf (sset-size sset-copy) (sset-size sset)) sset-copy)) ;;; set operations (defun union (sset1 sset2 &optional sset3) (cond ((eq sset3 t) (sset-union sset1 sset2 sset1)) ((eq sset3 nil) (sset-union sset1 sset2 (make-sset (sset-universe-size sset1)))) (t (sset-union sset1 sset2 sset3)))) (defun sset-union (sset1 sset2 sset-dst) (check-compatible-universes sset1 sset-dst) (check-compatible-universes sset2 sset-dst) (when (and (not (eq sset1 sset-dst)) (not (eq sset2 sset-dst))) (clear sset-dst)) (unless (eq sset1 sset-dst) (dosset (x sset1) (%add-member sset-dst x))) (unless (eq sset2 sset-dst) (dosset (x sset2) (%add-member sset-dst x))) sset-dst) (defun intersection (sset1 sset2 &optional sset3) (cond ((eq sset3 t) (sset-intersection sset1 sset2 sset1)) ((eq sset3 nil) (sset-intersection sset1 sset2 (make-sset (sset-universe-size sset1)))) (t (sset-intersection sset1 sset2 sset3)))) (defun sset-intersection (sset1 sset2 sset-dst) (check-compatible-universes sset1 sset-dst) (check-compatible-universes sset2 sset-dst) (cond ((eq sset1 sset-dst) (dosset (x sset2 sset-dst) (unless (%memberp sset-dst x) (%delete-member sset-dst x)))) ((eq sset2 sset-dst) (dosset (x sset1 sset-dst) (unless (%memberp sset-dst x) (%delete-member sset-dst x)))) (t (clear sset-dst) (dosset (x sset1 sset-dst) (when (%memberp sset2 x) (%add-member sset-dst x)))))) (defun difference (sset1 sset2 &optional sset3) (cond ((eq sset3 t) (sset-difference sset1 sset2 sset1)) ((eq sset3 nil) (sset-difference sset1 sset2 (make-sset (sset-universe-size sset1)))) (t (sset-difference sset1 sset2 sset3)))) (defun sset-difference (sset1 sset2 sset-dst) (check-compatible-universes sset1 sset-dst) (check-compatible-universes sset2 sset-dst) (cond ((eq sset1 sset-dst) (dosset (x sset2 sset-dst) (when (%memberp sset-dst x) (%delete-member sset-dst x)))) ((eq sset2 sset-dst) ;; kinda ugly, but to maintain reasonable time bounds, this is ;; necessary. generational GC should handle this nicely (let ((temp-set (copy sset-dst))) (sset-difference sset1 temp-set sset2))) (t (clear sset-dst) (dosset (x sset1 sset-dst) (unless (%memberp sset2 x) (%add-member sset-dst x)))))) (defun complement (sset1 &optional sset2) (cond ((eq sset2 t) (sset-complement sset1 sset1)) ((eq sset2 nil) (sset-complement sset1 (make-sset (sset-universe-size sset1)))) (t (sset-complement sset1 sset2)))) (defun sset-complement (sset1 sset2) (check-compatible-universes sset1 sset2) (if (eq sset1 sset2) (dotimes (i (sset-universe-size sset1) sset2) (if (%memberp sset1 i) (%delete-member sset1 i) (%add-member sset1 i))) (dotimes (i (sset-universe-size sset1) sset2) (unless (%memberp sset1 i) (%add-member sset2 i))))) ;;; not sure what to call this function when exported (defun sset-equal (sset1 sset2) (and (= (sset-universe-size sset1) (sset-universe-size sset2)) (= (sset-size sset1) (sset-size sset2)) (dosset (x sset1 t) (unless (%memberp sset2 x) (return-from nil nil))))) -- Nathan | From Man's effeminate slackness it begins. --Paradise Lost

1 0

[Small-cl-src] nines.lisp
by Luke Gorrie 14 May '04

14 May '04

;;; nines.lisp --- Program to solve the "Nine Nines" problem. ;;; Spec at http://www.itasoftware.com/careers/programmers-archive.php ;;; Written by Luke Gorrie <luke(a)bluetail.com> on April 26, 2002. ;;; Hacked by Darius Bacon <darius(a)accesscom.com> to fit on one screen. ;; The possible results of an expression containing one nine are just ;; 9 and -9. Any expression with N (> 1) nines can be seen as a ;; combination of two smaller subexpressions by some operator, ;; resulting in any combination of the subexpressions' possible ;; results. The full solution for nine nines is constructed ;; efficiently from smaller results using dynamic programming. ;; ;; Note: Because unary minus can be applied at any time (including the ;; very end), the internal representation only explicitly deals with ;; absolute values, which are understood to be +/-. (defvar *solutions* nil "Array of sets of possible absolute values for <index>-nine expressions.") (defun run (n) "Return the solution to the N Nines problem." (let ((*solutions* (make-array (1+ n) :initial-element nil))) (setf (aref *solutions* 1) '(9)) (loop for k from 2 to n do (setf (aref *solutions* k) (solve k))) (find-missing (aref *solutions* n)))) (defun solve (n) "Calculate the possible values for an expression of N nines." (let ((table (make-hash-table :test 'eql))) (do ((x (1- n) (1- x)) (y 1 (1+ y))) ((> y x) (hash-table-keys table)) (add-combinations table x y)))) (defun add-combinations (table i j) "Add to TABLE the absolute values that can result from combining expressions of I nines and J nines using any operator, with either on the left hand side." (labels ((add-answer (x) (setf (gethash x table) t))) (dolist (x (aref *solutions* i)) (dolist (y (aref *solutions* j)) (add-answer (+ x y)) (add-answer (abs (- x y))) (add-answer (* x y)) (unless (zerop y) (add-answer (/ x y))) (unless (zerop x) (add-answer (/ y x))))))) (defun find-missing (list) "Find the first 'missing' integer in the (sorted) LIST, starting from 0." (loop for x in (sort (remove-if-not #'integerp list) #'<) for n from 0 when (/= x n) return n)) (defun hash-table-keys (hashtable) "Return a list of the keys of HASHTABLE." (let ((keys '())) (maphash (lambda (key value) (push key keys)) hashtable) keys))

1 0

[Small-cl-src] root.lisp
by Luke Gorrie 14 May '04

14 May '04

;;; root.lisp -- superuser-when-it-suits-me privilege managemenet (for CMUCL) ;;; Written by Luke Gorrie <luke(a)bluetail.com>, July 2003. ;; ;; This package implements a convenient security loophole: it allows ;; you to become root temporarily, whenever you please. This is useful ;; if you sometimes need to do privileged operations but don't want ;; Lisp to always run as root (mucking up your file permissions, etc). ;; ;; WARNING: Only use this package if you understand how it works, ;; and/or don't mind users of your machine becoming root at will! To ;; understand how it works, refer to Stevens' _Advanced Programming in ;; the Unix Environment_, or ask your local Unix guru. ;; ;; To setup: ;; ;; Compile this package, and either add it to your image or load it ;; in your init file. ;; ;; Add the following line to your init file: ;; #+root (root:condescend) ;; ;; Make your 'lisp' process setuid-root: ;; chown root `which lisp` ;; chmod u+s `which lisp` ;; ;; Now your Lisp system will start as root, but quickly switch to your ;; real user. Whenever you want to run some code as root, you need ;; only write: ;; ;; (root:as-superuser ...naughty code...) ;; ;; You can test by writing (list (root::geteuid) ;; (root:as-superuser (root::geteuid))) ;; ;; which should return (<your-real-uid> 0). (defpackage :root (:use :common-lisp :unix :alien :c-call) (:export :condescend :as-superuser)) (in-package :root) (defun condescend () "Switch down from the superuser, with the option to switch back. \(Sets the effective user to the real user, and the real user to root.) Returns T on success, or NIL if we weren't the superuser." (values (unix-setreuid 0 (unix-getuid)))) (defmacro as-superuser (&body forms) "Execute FORMS as the superuser." `(let ((old-euid (geteuid))) (unwind-protect (if (unix-setreuid 0 0) (progn ,@forms) (error "Failed to become superuser")) (unix-setreuid 0 old-euid)))) ;; CMUCL 18e's unix-glibc2.lisp has this #+NIL'd out, so here it is. (def-alien-routine ("geteuid" geteuid) int "Get the effective user ID of the calling process.") (pushnew :root *features*)

1 0