- bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2229 - branches/trunk-reorg/projects/scrabble/src
by bknr＠bknr.net 07 Oct '07

07 Oct '07

Author: hhubner Date: 2007-10-07 18:04:17 -0400 (Sun, 07 Oct 2007) New Revision: 2229 Added: branches/trunk-reorg/projects/scrabble/src/test-store.lisp Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/rules.lisp branches/trunk-reorg/projects/scrabble/src/web.lisp Log: make-game works now, and some xml can be generated. snapshot and restore works, but I found a very embarrasing problem with anonymous transactions and make-object. In a nutshell, one would expect to be able to group a number of make-object calls using an (anonymous) transaction in order to create a few interdependent objets. In practice, this does not work. The order of the objects as they appear in the transaction log is wrong when using an anonymous transaction, and snapshots don't work with either anonymous or named transactions. This is very embarrasing and I will need to find time to fix this soon, as it makes the store useless for many real world application scenarios. Modified: branches/trunk-reorg/projects/scrabble/src/game.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -24,7 +24,7 @@ (random-index (random (fill-pointer tiles)))) (setf (aref tiles i) (aref tiles random-index)) (setf (aref tiles random-index) tmp))) - (make-instance 'tile-bag :tiles tiles))) + (make-object 'tile-bag :tiles tiles))) (define-condition no-tiles-remaining (simple-error) ()) @@ -54,17 +54,45 @@ ((games :initform nil :accessor games-of)) (:metaclass persistent-class)) +(defclass participant (store-object) + ((player :initarg :player :reader player-of) + (tray :initarg :tray :accessor tray-of)) + (:metaclass persistent-class)) + +(defmethod tray-size ((participant participant)) + (length (tray-of participant))) + (defclass game (store-object) ((language :initarg :language :reader language-of) - (players :initarg :players - :reader players-of - :documentation "List of players in this game") - (board :accessor board-of) - (tile-bag :accessor tile-bag-of)) + (board :initarg :board + :accessor board-of) + (tile-bag :initarg :tile-bag + :accessor tile-bag-of) + (participants :initarg :participants + :reader participants-of + :documentation "List of participants in this game")) (:metaclass persistent-class)) -(defmethod initialize-persistent-instance :after ((game game)) - (setf (board-of game) (make-instance 'board)) - (setf (tile-bag-of game) (make-tile-bag (language-of game))) - game) \ No newline at end of file +(defun make-game (language players) + ;; Because of a serious deficiency in the BKNR datastore, we need to create all the parts of a game in seperate transactions. + ;; Only when all components have been created in the right order, restoring from either the transaction log or a snapshot + ;; will work. A real fix would involve ordering object creations in transactions so that when restoring, all objects are + ;; created before they are referenced. + (let* ((board (make-object 'board)) + (tile-bag (make-tile-bag language)) + (trays (mapcar (lambda (player) + (declare (ignore player)) + (loop for i from 0 below 7 + collect (draw-tile tile-bag))) + players)) + (participants (loop for player in players + for tray in trays + collect (make-object 'participant + :player player + :tray tray)))) + (make-object 'game + :language language + :board board + :tile-bag tile-bag + :participants participants))) Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -21,12 +21,18 @@ "REMAINING-TILE-COUNT" "PLAYER" + "GAMES-OF" + "PARTICIPANT" + "PLAYER-OF" + "TRAY-OF" + "GAME" "LANGUAGE-OF" - "PLAYERS-OF" + "PARTICIPANTS-OF" "BOARD-OF" - "TILE-BAG-OF")) + "TILE-BAG-OF" + "MAKE-GAME")) (defpackage :scrabble.graphics (:use :cl Modified: branches/trunk-reorg/projects/scrabble/src/rules.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -66,7 +66,7 @@ (defmethod at-placement ((board board) tile-placement) (at-xy board (x-of tile-placement) (y-of tile-placement))) -(defmethod put-letter ((board board) tile x y) +(deftransaction put-letter (board tile x y) (setf (aref (placed-tiles-of board) x y) tile)) (defclass tile (store-object) Added: branches/trunk-reorg/projects/scrabble/src/test-store.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/test-store.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/test-store.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -0,0 +1,9 @@ +(in-package :scrabble) + +(defun test-store () + (ignore-errors (close-store)) + (sb-ext:run-program "/bin/rm" '("-rf" "/tmp/scrabble-store/") :environment nil) + (make-instance 'mp-store :directory "/tmp/scrabble-store/") + (let ((user1 (make-user "user1" :class 'player :full-name "User Eins")) + (user2 (make-user "user2" :class 'player :full-name "User Zwei"))) + (make-game :de (list user1 user2)))) \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/src/web.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-06 23:09:39 UTC (rev 2228) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-07 22:04:17 UTC (rev 2229) @@ -2,23 +2,24 @@ (defmethod as-xml ((board board)) (with-element "board" - (dotimes (x 15) - (dotimes (y 15) - (awhen (at-xy board x y) - (with-element "tile" - (attribute "x" x) - (attribute "y" y) - (attribute "letter" (char-of it)) - (attribute "value" (value-of it)))))))) + (dotimes (x 15) + (dotimes (y 15) + (awhen (at-xy board x y) + (with-element "tile" + (attribute "x" x) + (attribute "y" y) + (attribute "letter" (princ-to-string (char-of it))) + (attribute "value" (value-of it)))))))) -(defmethod as-xml ((player player)) - (with-element "player" - (attribute "name" (user-full-name player)))) +(defmethod as-xml ((participant participant)) + (with-element "participant" + (attribute "name" (user-full-name (player-of participant))) + (attribute "tiles" (length (tray-of participant))))) (defmethod as-xml ((game game)) (with-element "game" (attribute "language" (princ-to-string (language-of game))) (attribute "remaining-tiles" (remaining-tile-count (tile-bag-of game))) - (dolist (player (players-of game)) - (as-xml player)) + (dolist (participant (participants-of game)) + (as-xml participant)) (as-xml (board-of game))))

1 0

[bknr-cvs] r2228 - in branches/trunk-reorg/projects/scrabble: src website website/en
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 19:09:39 -0400 (Sat, 06 Oct 2007) New Revision: 2228 Added: branches/trunk-reorg/projects/scrabble/src/game-constants.lisp branches/trunk-reorg/projects/scrabble/src/game.lisp branches/trunk-reorg/projects/scrabble/src/rules.lisp branches/trunk-reorg/projects/scrabble/src/web.lisp branches/trunk-reorg/projects/scrabble/website/en/ branches/trunk-reorg/projects/scrabble/website/en/A.png branches/trunk-reorg/projects/scrabble/website/en/B.png branches/trunk-reorg/projects/scrabble/website/en/C.png branches/trunk-reorg/projects/scrabble/website/en/D.png branches/trunk-reorg/projects/scrabble/website/en/E.png branches/trunk-reorg/projects/scrabble/website/en/F.png branches/trunk-reorg/projects/scrabble/website/en/G.png branches/trunk-reorg/projects/scrabble/website/en/H.png branches/trunk-reorg/projects/scrabble/website/en/I.png branches/trunk-reorg/projects/scrabble/website/en/J.png branches/trunk-reorg/projects/scrabble/website/en/K.png branches/trunk-reorg/projects/scrabble/website/en/L.png branches/trunk-reorg/projects/scrabble/website/en/M.png branches/trunk-reorg/projects/scrabble/website/en/N.png branches/trunk-reorg/projects/scrabble/website/en/NIL.png branches/trunk-reorg/projects/scrabble/website/en/O.png branches/trunk-reorg/projects/scrabble/website/en/P.png branches/trunk-reorg/projects/scrabble/website/en/Q.png branches/trunk-reorg/projects/scrabble/website/en/R.png branches/trunk-reorg/projects/scrabble/website/en/S.png branches/trunk-reorg/projects/scrabble/website/en/T.png branches/trunk-reorg/projects/scrabble/website/en/U.png branches/trunk-reorg/projects/scrabble/website/en/V.png branches/trunk-reorg/projects/scrabble/website/en/W.png branches/trunk-reorg/projects/scrabble/website/en/X.png branches/trunk-reorg/projects/scrabble/website/en/Y.png branches/trunk-reorg/projects/scrabble/website/en/Z.png branches/trunk-reorg/projects/scrabble/website/en/charmap.xml branches/trunk-reorg/projects/scrabble/website/en/double-letter.png branches/trunk-reorg/projects/scrabble/website/en/double-word.png branches/trunk-reorg/projects/scrabble/website/en/scrabble.css branches/trunk-reorg/projects/scrabble/website/en/scrabble.html branches/trunk-reorg/projects/scrabble/website/en/scrabble.js branches/trunk-reorg/projects/scrabble/website/en/standard.png branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png branches/trunk-reorg/projects/scrabble/website/en/triple-word.png Removed: branches/trunk-reorg/projects/scrabble/src/scrabble.lisp Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/scrabble.asd Log: Snapshot - Modularized a little, made most game objects persistent, add XML generation function for games. Added: branches/trunk-reorg/projects/scrabble/src/game-constants.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game-constants.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/game-constants.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,29 @@ +(in-package :scrabble) + +(defparameter *board-scoring* + #2A((:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word) + (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil) + (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil) + (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter) + (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) + (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) + (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) + (:triple-word nil nil :double-letter nil nil nil :double-word nil nil nil :double-letter nil nil :triple-word) + (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) + (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) + (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) + (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter) + (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil) + (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil) + (:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word))) + +(defparameter *tile-sets* '(:de ((#\A 1 5) (#\B 3 2) (#\C 4 2) (#\D 1 4) (#\E 1 15) (#\F 4 2) (#\G 2 3) (#\H 2 4) (#\I 1 6) + (#\J 6 1) (#\K 4 2) (#\L 2 3) (#\M 3 4) (#\N 1 9) (#\O 2 3) (#\P 4 1) (#\Q 10 1) (#\R 1 6) + (#\S 1 7) (#\T 1 6) (#\U 1 6) (#\V 6 1) (#\W 3 1) (#\X 8 1) (#\Y 10 1) (#\Z 3 1) + (#\LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS 6 1) + (#\LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS 8 1) + (#\LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS 6 1) + (nil 0 2)) + :en '((#\A 1 9) (#\B 3 2) (#\C 3 2) (#\D 2 4) (#\E 1 12) (#\F 4 2) (#\G 2 3) (#\H 4 2) (#\I 1 9) + (#\J 8 1) (#\K 5 1) (#\L 1 4) (#\M 3 2) (#\N 1 6) (#\O 1 8) (#\P 3 2) (#\Q 10 1) (#\R 1 6) + (#\S 1 4) (#\T 1 6) (#\U 1 4) (#\V 4 2) (#\W 4 2) (#\X 8 1) (#\Y 4 2) (#\Z 10 1) (nil 0 2)))) \ No newline at end of file Added: branches/trunk-reorg/projects/scrabble/src/game.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/game.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,70 @@ +(in-package :scrabble) + +(defclass tile-bag (store-object) + ((tiles :initarg :tiles :accessor tiles-of)) + (:metaclass persistent-class)) + +(defmethod remaining-tile-count ((tile-bag tile-bag)) + (fill-pointer (tiles-of tile-bag))) + +(defmethod print-object ((tile-bag tile-bag) stream) + (print-unreadable-object (tile-bag stream :type t :identity t) + (format stream "~A letters remaining" (remaining-tile-count tile-bag)))) + +(defun make-tile-bag (language) + (let ((tiles (make-array 102 :adjustable t :fill-pointer 0))) + (mapcar (lambda (entry) + (destructuring-bind (char value count) entry + (dotimes (i count) + (vector-push-extend (make-tile char value) tiles)))) + (or (getf *tile-sets* language) + (error "language ~A not defined" language))) + (dotimes (i (fill-pointer tiles)) + (let ((tmp (aref tiles i)) + (random-index (random (fill-pointer tiles)))) + (setf (aref tiles i) (aref tiles random-index)) + (setf (aref tiles random-index) tmp))) + (make-instance 'tile-bag :tiles tiles))) + +(define-condition no-tiles-remaining (simple-error) + ()) + +(defmethod draw-tile ((tile-bag tile-bag)) + (unless (plusp (remaining-tile-count tile-bag)) + (error 'no-tiles-remaining)) + (with-slots (tiles) tile-bag + (prog1 + (aref tiles (1- (fill-pointer tiles))) + (decf (fill-pointer tiles))))) + +(defun make-move (board placed-tiles) + "Actually perform a move. BOARD contains the already placed tiles, +PLACED-TILES contains the letters for the move to make. BOARD is +modified to include the tiles placed. Returns the two values that +CALCULATE-SCORE returns for the move." + (check-move-legality board placed-tiles) + (prog1 + (mapcar (lambda (word-result) + (list (word-text word-result) (word-score word-result))) + (words-formed board placed-tiles)) + (dolist (placed-tile placed-tiles) + (put-letter board (tile-of placed-tile) (x-of placed-tile) (y-of placed-tile))))) + +(defclass player (user) + ((games :initform nil :accessor games-of)) + (:metaclass persistent-class)) + +(defclass game (store-object) + ((language :initarg :language + :reader language-of) + (players :initarg :players + :reader players-of + :documentation "List of players in this game") + (board :accessor board-of) + (tile-bag :accessor tile-bag-of)) + (:metaclass persistent-class)) + +(defmethod initialize-persistent-instance :after ((game game)) + (setf (board-of game) (make-instance 'board)) + (setf (tile-bag-of game) (make-tile-bag (language-of game))) + game) \ No newline at end of file Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -1,14 +1,47 @@ - -(defpackage :scrabble - (:use :cl :alexandria :anaphora :bknr.datastore) - (:export "*BOARD-SCORING*" - "*TILE-SETS*" - "FIELD-TYPE")) - -(defpackage :scrabble.graphics - (:use :cl :alexandria :vecto :scrabble) - (:shadowing-import-from :vecto "ROTATE")) - -(defpackage :scrabble.web - (:use :cl :alexandria :hunchentoot :scrabble)) + +(defpackage :scrabble + (:use :cl + :alexandria + :anaphora + :bknr.datastore + :bknr.user) + (:export "*BOARD-SCORING*" + "*TILE-SETS*" + + "FIELD-TYPE" + + "TILE" + "CHAR-OF" + "VALUE-OF" + + "BOARD" + "AT-XY" + + "TILE-BAG" + "REMAINING-TILE-COUNT" + + "PLAYER" + + "GAME" + "LANGUAGE-OF" + "PLAYERS-OF" + "BOARD-OF" + "TILE-BAG-OF")) + +(defpackage :scrabble.graphics + (:use :cl + :alexandria + :vecto + :scrabble) + (:shadowing-import-from :vecto "ROTATE")) + +(defpackage :scrabble.web + (:use :cl + :alexandria + :anaphora + :hunchentoot + :bknr.datastore + :bknr.user + :cxml + :scrabble)) \ No newline at end of file Added: branches/trunk-reorg/projects/scrabble/src/rules.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/rules.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,197 @@ +(in-package :scrabble) + +(defun field-type (x y) + (or (aref *board-scoring* x y) + :standard)) + +(define-condition invalid-move (simple-error) + () + (:report (lambda (c stream) + (format stream "Invalid move: ~A" (type-of c))))) + +(defun seq (from to) + (loop for i from from upto to + collect i)) + +(defun positions-between (start-position end-position) + (if (= (first start-position) + (first end-position)) + (mapcar (lambda (y) (list (first start-position) y)) + (seq (second start-position) (second end-position))) + (mapcar (lambda (x) (list x (second start-position))) + (seq (first start-position) (first end-position))))) + +(defclass tile-placement () + ((x :reader x-of :initarg :x) + (y :reader y-of :initarg :y) + (tile :reader tile-of :initarg :tile)) + (:documentation "Represents placement of a letter tile on the board")) + +(defun make-tile-placement (x y tile) + (make-instance 'tile-placement :x x :y y :tile tile)) + +(defun make-tile-placements (list-of-moves) + (mapcar (curry #'apply 'make-tile-placement) list-of-moves)) + +(defmethod equal-position ((tile-placement-1 tile-placement) (tile-placement-2 tile-placement)) + (and (= (x-of tile-placement-1) (x-of tile-placement-2)) + (= (y-of tile-placement-1) (y-of tile-placement-2)))) + +(defmethod position-equal ((position list) (tile-placement tile-placement)) + "Return non-nil if the given POSITION is at the position of PLACED-TILE" + (and (= (first position) (x-of tile-placement)) + (= (second position) (y-of tile-placement)))) + +(defmethod position-< ((a tile-placement) (b tile-placement)) + "Compare positions of placements, for sorting" + (or (< (x-of a) (x-of b)) + (< (y-of a) (y-of b)))) + +(defclass board (store-object) + ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil))) + (:metaclass persistent-class)) + +(defmethod print-object ((board board) stream) + (print-unreadable-object (board stream :type t :identity t) + (terpri stream) + (dotimes (x 15) + (dotimes (y 15) + (format stream "~C " (aif (at-xy board x y) (char-of it) #\.))) + (terpri stream)))) + + +(defmethod at-xy ((board board) x y) + (aref (placed-tiles-of board) x y)) + +(defmethod at-placement ((board board) tile-placement) + (at-xy board (x-of tile-placement) (y-of tile-placement))) + +(defmethod put-letter ((board board) tile x y) + (setf (aref (placed-tiles-of board) x y) tile)) + +(defclass tile (store-object) + ((char :reader char-of :initarg :char) + (value :reader value-of :initarg :value)) + (:metaclass persistent-class)) + +(defmethod print-object ((tile tile) stream) + (print-unreadable-object (tile stream :type t :identity nil) + (with-slots (char value) tile + (format stream "~A (~A)" char value)))) + +(defun make-tile (char value) + (make-object 'tile :char char :value value)) + +(defmethod placed-tile-adjacent ((board board) (tile-placement tile-placement)) + "Check whether the given TILE-PLACEMENT on the board is adjacent to +another tile or if it is the start position." + (with-accessors ((x x-of) (y y-of)) + tile-placement + (or (and (eql x 7) + (eql y 7)) + (and (plusp x) + (at-xy board (1- x) y)) + (and (plusp y) + (at-xy board x (1- y))) + (and (< x 14) + (at-xy board (1+ x) y)) + (and (< y 14) + (at-xy board x (1+ y)))))) + +(defun placed-or-being-placed (board placed-tiles position) + (or (at-xy board (first position) (second position)) + (awhen (find position placed-tiles :test #'position-equal) + (values (tile-of it) t)))) + +(define-condition not-touching-other-tile (invalid-move) ()) +(define-condition not-in-a-row (invalid-move) ()) +(define-condition placed-on-occupied-field (invalid-move) ()) +(define-condition no-tile-placed (invalid-move) ()) +(define-condition multiple-letters-placed-on-one-field (invalid-move) ()) +(define-condition placement-with-holes (invalid-move) ()) + +(defun check-move-legality (board placed-tiles) + "Verify that placing the PLACED-TILES on BOARD is a legal Scrabble +move. If the move is not valid, a specific INVALID-MOVE condition is +signalled. Otherwise, t is returned." + (unless placed-tiles + (error 'no-tile-placed)) + + (unless (or (apply #'= (mapcar #'x-of placed-tiles)) + (apply #'= (mapcar #'y-of placed-tiles))) + (error 'not-in-a-row)) + + (when (some (curry #'at-placement board) placed-tiles) + (error 'tile-placed-on-occupied-field)) + + (unless (equal placed-tiles + (remove-duplicates placed-tiles :test #'equal-position)) + (error 'multiple-letters-placed-on-one-field)) + + (let* ((placed-tiles (sort (copy-list placed-tiles) #'position-<)) + (start-of-placement (first placed-tiles)) + (end-of-placement (first (last placed-tiles)))) + (unless (every (curry 'placed-or-being-placed board placed-tiles) + (positions-between (list (x-of start-of-placement) (y-of start-of-placement)) + (list (x-of end-of-placement) (y-of end-of-placement)))) + (error 'placement-with-holes))) + + (unless (or (find '(7 7) placed-tiles :test #'position-equal) + (some (curry #'placed-tile-adjacent board) placed-tiles)) + (error 'not-touching-other-tile)) + + t) + +(defun words-formed% (board placed-tiles verticalp) + "Scan for words that would be formed by placing PLACED-TILES on +BOARD. VERTICALP determines the scan order, if nil, the board is +scanned horizontally, else vertically. This is called by WORDS-FORMED +below, see there for a description of the return value format." + (let (words) + (dotimes (x 15) + (when (find x placed-tiles :key (if verticalp #'y-of #'x-of) :test #'=) + (let (word is-new-word) + (dotimes (y 15) + (multiple-value-bind (placed-tile being-placed) (placed-or-being-placed board placed-tiles (if verticalp (list y x) (list x y))) + (when (and word (null placed-tile)) + (when (and (cdr word) is-new-word) + (push (nreverse word) words)) + (setf word nil is-new-word nil)) + (when placed-tile + (push (list placed-tile (and being-placed (field-type x y))) word) + (when being-placed + (setf is-new-word t))))) + (when (and (cdr word) is-new-word) + (push (nreverse word) words))))) + (nreverse words))) + +(defun words-formed (board placed-tiles) + "Return list of all words formed by placing the tiles in +PLACED-TILES on the BOARD. Returns each word as a list, with each +letter of the word represented by a list (TILE FIELD-TYPE). TILE is +the tile for the letter, FIELD-TYPE is either the field type of the +field that the letter has been placed on, or NIL if the tile was +already on the board." + (append (words-formed% board placed-tiles nil) + (words-formed% board placed-tiles t))) + +(defun word-score (word-result) + "Process one word result from WORDS-FORMED and calculate the score +for the word." + (let ((factor 1) + (value 0)) + (dolist (entry word-result) + (destructuring-bind (tile field-type) entry + (incf value (value-of tile)) + (case field-type + ((:double-letter) (incf value (value-of tile))) + ((:triple-letter) (incf value (* 2 (value-of tile)))) + ((:double-word) (setf factor (* factor 2))) + ((:triple-word) (setf factor (* factor 3)))))) + (* value factor))) + +(defun word-text (word-result) + "Convert the letter in a word result returned by WORDS-FORMED to a +string." + (coerce (mapcar (compose #'char-of #'car) word-result) 'string)) + Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.asd =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.asd 2007-10-06 23:09:39 UTC (rev 2228) @@ -10,9 +10,18 @@ (defsystem :scrabble :name "Scrabble" :licence "BSD" - :depends-on (:bknr-datastore :hunchentoot :cxml :vecto :alexandria :anaphora) + :depends-on (:bknr-datastore + :bknr-web + :hunchentoot + :cxml + :vecto + :alexandria + :anaphora) :serial t :components ((:file "package") - (:file "scrabble") + (:file "game-constants") + (:file "rules") + (:file "game") + (:file "web") (:file "make-html") (:file "make-letters"))) Deleted: branches/trunk-reorg/projects/scrabble/src/scrabble.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -1,277 +0,0 @@ -(in-package :scrabble) - -(defparameter *board-scoring* - #2A((:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word) - (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil) - (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil) - (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter) - (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) - (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) - (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) - (:triple-word nil nil :double-letter nil nil nil :double-word nil nil nil :double-letter nil nil :triple-word) - (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) - (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) - (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) - (:double-letter nil nil :double-word nil nil nil :double-letter nil nil nil :double-word nil nil :double-letter) - (nil nil :double-word nil nil nil :double-letter nil :double-letter nil nil nil :double-word nil nil) - (nil :double-word nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :double-word nil) - (:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word))) - -(defun field-type (x y) - (or (aref *board-scoring* x y) - :standard)) - -(defparameter *tile-sets* (make-hash-table)) - -(setf (gethash :de *tile-sets*) - '((#\A 1 5) (#\B 3 2) (#\C 4 2) (#\D 1 4) (#\E 1 15) (#\F 4 2) (#\G 2 3) (#\H 2 4) (#\I 1 6) - (#\J 6 1) (#\K 4 2) (#\L 2 3) (#\M 3 4) (#\N 1 9) (#\O 2 3) (#\P 4 1) (#\Q 10 1) (#\R 1 6) - (#\S 1 7) (#\T 1 6) (#\U 1 6) (#\V 6 1) (#\W 3 1) (#\X 8 1) (#\Y 10 1) (#\Z 3 1) - (#\LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS 6 1) - (#\LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS 8 1) - (#\LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS 6 1) - (nil 0 2))) -(setf (gethash :en *tile-sets*) - '((#\A 1 9) (#\B 3 2) (#\C 3 2) (#\D 2 4) (#\E 1 12) (#\F 4 2) (#\G 2 3) (#\H 4 2) (#\I 1 9) - (#\J 8 1) (#\K 5 1) (#\L 1 4) (#\M 3 2) (#\N 1 6) (#\O 1 8) (#\P 3 2) (#\Q 10 1) (#\R 1 6) - (#\S 1 4) (#\T 1 6) (#\U 1 4) (#\V 4 2) (#\W 4 2) (#\X 8 1) (#\Y 4 2) (#\Z 10 1) (nil 0 2))) - -(define-condition invalid-move (simple-error) - () - (:report (lambda (c stream) - (format stream "Invalid move: ~A" (type-of c))))) - -(defun seq (from to) - (loop for i from from upto to - collect i)) - -(defun positions-between (start-position end-position) - (if (= (first start-position) - (first end-position)) - (mapcar (lambda (y) (list (first start-position) y)) - (seq (second start-position) (second end-position))) - (mapcar (lambda (x) (list x (second start-position))) - (seq (first start-position) (first end-position))))) - -(defclass tile-placement () - ((x :reader x-of :initarg :x) - (y :reader y-of :initarg :y) - (tile :reader tile-of :initarg :tile)) - (:documentation "Represents placement of a letter tile on the board")) - -(defun make-tile-placement (x y tile) - (make-instance 'tile-placement :x x :y y :tile tile)) - -(defun make-tile-placements (list-of-moves) - (mapcar (curry #'apply 'make-tile-placement) list-of-moves)) - -(defmethod equal-position ((tile-placement-1 tile-placement) (tile-placement-2 tile-placement)) - (and (= (x-of tile-placement-1) (x-of tile-placement-2)) - (= (y-of tile-placement-1) (y-of tile-placement-2)))) - -(defmethod position-equal ((position list) (tile-placement tile-placement)) - "Return non-nil if the given POSITION is at the position of PLACED-TILE" - (and (= (first position) (x-of tile-placement)) - (= (second position) (y-of tile-placement)))) - -(defmethod position-< ((a tile-placement) (b tile-placement)) - "Compare positions of placements, for sorting" - (or (< (x-of a) (x-of b)) - (< (y-of a) (y-of b)))) - -(defclass board (store-object) - ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil))) - (:metaclass persistent-class)) - -(defmethod print-object ((board board) stream) - (print-unreadable-object (board stream :type t :identity t) - (terpri stream) - (dotimes (x 15) - (dotimes (y 15) - (format stream "~C " (aif (at-xy board x y) (char-of it) #\.))) - (terpri stream)))) - -(defmethod at-xy ((board board) x y) - (aref (placed-tiles-of board) x y)) - -(defmethod at-placement ((board board) tile-placement) - (at-xy board (x-of tile-placement) (y-of tile-placement))) - -(defmethod put-letter ((board board) tile x y) - (setf (aref (placed-tiles-of board) x y) tile)) - -(defclass tile (store-object) - ((char :reader char-of :initarg :char) - (value :reader value-of :initarg :value)) - (:metaclass persistent-class)) - -(defmethod print-object ((tile tile) stream) - (print-unreadable-object (tile stream :type t :identity nil) - (with-slots (char value) tile - (format stream "~A (~A)" char value)))) - -(defun make-tile (char value) - (make-object 'tile :char char :value value)) - -(defclass tile-bag (store-object) - ((tiles :initarg :tiles :accessor tiles-of)) - (:metaclass persistent-class)) - -(defmethod remaining-tile-count ((tile-bag tile-bag)) - (fill-pointer (tiles-of tile-bag))) - -(defmethod print-object ((tile-bag tile-bag) stream) - (print-unreadable-object (tile-bag stream :type t :identity t) - (format stream "~A letters remaining" (remaining-tile-count tile-bag)))) - -(defun make-tile-bag (language) - (let ((tiles (make-array 102 :adjustable t :fill-pointer 0))) - (mapcar (lambda (entry) - (destructuring-bind (char value count) entry - (dotimes (i count) - (vector-push-extend (make-tile char value) tiles)))) - (or (gethash language *tile-sets*) - (error "language ~A not defined" language))) - (dotimes (i (fill-pointer tiles)) - (let ((tmp (aref tiles i)) - (random-index (random (fill-pointer tiles)))) - (setf (aref tiles i) (aref tiles random-index)) - (setf (aref tiles random-index) tmp))) - (make-instance 'tile-bag :tiles tiles))) - -(define-condition no-tiles-remaining (simple-error) - ()) - -(defmethod draw-tile ((tile-bag tile-bag)) - (unless (plusp (remaining-tile-count tile-bag)) - (error 'no-tiles-remaining)) - (with-slots (tiles) tile-bag - (prog1 - (aref tiles (1- (fill-pointer tiles))) - (decf (fill-pointer tiles))))) - -(defmethod placed-tile-adjacent ((board board) (tile-placement tile-placement)) - "Check whether the given TILE-PLACEMENT on the board is adjacent to -another tile or if it is the start position." - (with-accessors ((x x-of) (y y-of)) - tile-placement - (or (and (eql x 7) - (eql y 7)) - (and (plusp x) - (at-xy board (1- x) y)) - (and (plusp y) - (at-xy board x (1- y))) - (and (< x 14) - (at-xy board (1+ x) y)) - (and (< y 14) - (at-xy board x (1+ y)))))) - -(defun placed-or-being-placed (board placed-tiles position) - (or (at-xy board (first position) (second position)) - (awhen (find position placed-tiles :test #'position-equal) - (values (tile-of it) t)))) - -(define-condition not-touching-other-tile (invalid-move) ()) -(define-condition not-in-a-row (invalid-move) ()) -(define-condition placed-on-occupied-field (invalid-move) ()) -(define-condition no-tile-placed (invalid-move) ()) -(define-condition multiple-letters-placed-on-one-field (invalid-move) ()) -(define-condition placement-with-holes (invalid-move) ()) - -(defun check-move-legality (board placed-tiles) - "Verify that placing the PLACED-TILES on BOARD is a legal Scrabble -move. If the move is not valid, a specific INVALID-MOVE condition is -signalled. Otherwise, t is returned." - (unless placed-tiles - (error 'no-tile-placed)) - - (unless (or (apply #'= (mapcar #'x-of placed-tiles)) - (apply #'= (mapcar #'y-of placed-tiles))) - (error 'not-in-a-row)) - - (when (some (curry #'at-placement board) placed-tiles) - (error 'tile-placed-on-occupied-field)) - - (unless (equal placed-tiles - (remove-duplicates placed-tiles :test #'equal-position)) - (error 'multiple-letters-placed-on-one-field)) - - (let* ((placed-tiles (sort (copy-list placed-tiles) #'position-<)) - (start-of-placement (first placed-tiles)) - (end-of-placement (first (last placed-tiles)))) - (unless (every (curry 'placed-or-being-placed board placed-tiles) - (positions-between (list (x-of start-of-placement) (y-of start-of-placement)) - (list (x-of end-of-placement) (y-of end-of-placement)))) - (error 'placement-with-holes))) - - (unless (or (find '(7 7) placed-tiles :test #'position-equal) - (some (curry #'placed-tile-adjacent board) placed-tiles)) - (error 'not-touching-other-tile)) - - t) - -(defun words-formed% (board placed-tiles verticalp) - "Scan for words that would be formed by placing PLACED-TILES on -BOARD. VERTICALP determines the scan order, if nil, the board is -scanned horizontally, else vertically. This is called by WORDS-FORMED -below, see there for a description of the return value format." - (let (words) - (dotimes (x 15) - (when (find x placed-tiles :key (if verticalp #'y-of #'x-of) :test #'=) - (let (word is-new-word) - (dotimes (y 15) - (multiple-value-bind (placed-tile being-placed) (placed-or-being-placed board placed-tiles (if verticalp (list y x) (list x y))) - (when (and word (null placed-tile)) - (when (and (cdr word) is-new-word) - (push (nreverse word) words)) - (setf word nil is-new-word nil)) - (when placed-tile - (push (list placed-tile (and being-placed (field-type x y))) word) - (when being-placed - (setf is-new-word t))))) - (when (and (cdr word) is-new-word) - (push (nreverse word) words))))) - (nreverse words))) - -(defun words-formed (board placed-tiles) - "Return list of all words formed by placing the tiles in -PLACED-TILES on the BOARD. Returns each word as a list, with each -letter of the word represented by a list (TILE FIELD-TYPE). TILE is -the tile for the letter, FIELD-TYPE is either the field type of the -field that the letter has been placed on, or NIL if the tile was -already on the board." - (append (words-formed% board placed-tiles nil) - (words-formed% board placed-tiles t))) - -(defun word-score (word-result) - "Process one word result from WORDS-FORMED and calculate the score -for the word." - (let ((factor 1) - (value 0)) - (dolist (entry word-result) - (destructuring-bind (tile field-type) entry - (incf value (value-of tile)) - (case field-type - ((:double-letter) (incf value (value-of tile))) - ((:triple-letter) (incf value (* 2 (value-of tile)))) - ((:double-word) (setf factor (* factor 2))) - ((:triple-word) (setf factor (* factor 3)))))) - (* value factor))) - -(defun word-text (word-result) - "Convert the letter in a word result returned by WORDS-FORMED to a -string." - (coerce (mapcar (compose #'char-of #'car) word-result) 'string)) - -(defun make-move (board placed-tiles) - "Actually perform a move. BOARD contains the already placed tiles, -PLACED-TILES contains the letters for the move to make. BOARD is -modified to include the tiles placed. Returns the two values that -CALCULATE-SCORE returns for the move." - (check-move-legality board placed-tiles) - (prog1 - (mapcar (lambda (word-result) - (list (word-text word-result) (word-score word-result))) - (words-formed board placed-tiles)) - (dolist (placed-tile placed-tiles) - (put-letter board (tile-of placed-tile) (x-of placed-tile) (y-of placed-tile))))) Added: branches/trunk-reorg/projects/scrabble/src/web.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/src/web.lisp 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,24 @@ +(in-package :scrabble.web) + +(defmethod as-xml ((board board)) + (with-element "board" + (dotimes (x 15) + (dotimes (y 15) + (awhen (at-xy board x y) + (with-element "tile" + (attribute "x" x) + (attribute "y" y) + (attribute "letter" (char-of it)) + (attribute "value" (value-of it)))))))) + +(defmethod as-xml ((player player)) + (with-element "player" + (attribute "name" (user-full-name player)))) + +(defmethod as-xml ((game game)) + (with-element "game" + (attribute "language" (princ-to-string (language-of game))) + (attribute "remaining-tiles" (remaining-tile-count (tile-bag-of game))) + (dolist (player (players-of game)) + (as-xml player)) + (as-xml (board-of game)))) Added: branches/trunk-reorg/projects/scrabble/website/en/A.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/A.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/B.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/B.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/C.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/C.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/D.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/D.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/E.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/E.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/F.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/F.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/G.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/G.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/H.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/H.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/I.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/I.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/J.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/J.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/K.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/K.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/L.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/L.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/M.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/M.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/N.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/N.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/NIL.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/NIL.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/O.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/O.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/P.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/P.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/Q.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Q.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/R.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/R.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/S.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/S.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/T.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/T.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/U.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/U.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/V.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/V.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/W.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/W.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/X.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/X.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/Y.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Y.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/Z.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/Z.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/charmap.xml =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/charmap.xml 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/website/en/charmap.xml 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1,2 @@ +<?xml version="1.0" encoding="UTF-8"?> +<chars><char filename="A.png">A</char><char filename="B.png">B</char><char filename="C.png">C</char><char filename="D.png">D</char><char filename="E.png">E</char><char filename="F.png">F</char><char filename="G.png">G</char><char filename="H.png">H</char><char filename="I.png">I</char><char filename="J.png">J</char><char filename="K.png">K</char><char filename="L.png">L</char><char filename="M.png">M</char><char filename="N.png">N</char><char filename="O.png">O</char><char filename="P.png">P</char><char filename="Q.png">Q</char><char filename="R.png">R</char><char filename="S.png">S</char><char filename="T.png">T</char><char filename="U.png">U</char><char filename="V.png">V</char><char filename="W.png">W</char><char filename="X.png">X</char><char filename="Y.png">Y</char><char filename="Z.png">Z</char><char filename="NIL.png">NIL</char></chars> \ No newline at end of file Added: branches/trunk-reorg/projects/scrabble/website/en/double-letter.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/double-letter.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/double-word.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/double-word.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.css 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.css 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1 @@ +link ../de/scrabble.css \ No newline at end of file Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.css ___________________________________________________________________ Name: svn:special + * Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.html =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.html 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.html 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1 @@ +link ../de/scrabble.html \ No newline at end of file Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.html ___________________________________________________________________ Name: svn:special + * Added: branches/trunk-reorg/projects/scrabble/website/en/scrabble.js =================================================================== --- branches/trunk-reorg/projects/scrabble/website/en/scrabble.js 2007-10-06 23:08:12 UTC (rev 2227) +++ branches/trunk-reorg/projects/scrabble/website/en/scrabble.js 2007-10-06 23:09:39 UTC (rev 2228) @@ -0,0 +1 @@ +link ../de/scrabble.js \ No newline at end of file Property changes on: branches/trunk-reorg/projects/scrabble/website/en/scrabble.js ___________________________________________________________________ Name: svn:special + * Added: branches/trunk-reorg/projects/scrabble/website/en/standard.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/standard.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/triple-letter.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/trunk-reorg/projects/scrabble/website/en/triple-word.png =================================================================== (Binary files differ) Property changes on: branches/trunk-reorg/projects/scrabble/website/en/triple-word.png ___________________________________________________________________ Name: svn:mime-type + application/octet-stream

1 0

[bknr-cvs] r2227 - in branches/trunk-reorg/bknr: modules web/src web/src/sysclasses web/src/web
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 19:08:12 -0400 (Sat, 06 Oct 2007) New Revision: 2227 Modified: branches/trunk-reorg/bknr/modules/bknr-modules.asd branches/trunk-reorg/bknr/web/src/bknr-web.asd branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/sysclasses/cron.lisp branches/trunk-reorg/bknr/web/src/web/authorizer.lisp branches/trunk-reorg/bknr/web/src/web/host.lisp branches/trunk-reorg/bknr/web/src/web/site.lisp branches/trunk-reorg/bknr/web/src/web/web-visitor.lisp Log: Make :bknr-web loadable with SBCL. I'm planning to switch to hunchentoot from aserve, but tha has not happened and until then, only the base components of :bknr-web are in the compile. I'm using the bknr.user now. Modified: branches/trunk-reorg/bknr/modules/bknr-modules.asd =================================================================== --- branches/trunk-reorg/bknr/modules/bknr-modules.asd 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/modules/bknr-modules.asd 2007-10-06 23:08:12 UTC (rev 2227) @@ -25,10 +25,7 @@ :bknr-utils :puri :stem - #+(or) :mime :bknr - :klammerscript - #+(not allegro) :acl-compat) :components ((:file "packages") Modified: branches/trunk-reorg/bknr/web/src/bknr-web.asd =================================================================== --- branches/trunk-reorg/bknr/web/src/bknr-web.asd 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/bknr-web.asd 2007-10-06 23:08:12 UTC (rev 2227) @@ -10,7 +10,7 @@ (make-pathname :name nil :type nil :version nil :defaults (parse-namestring *load-truename*))) -(defsystem :bknr +(defsystem :bknr-web :name "Baikonour - Base modules" :author "Hans Huebner <hans(a)huebner.org>" :author "Manuel Odendahl <manuel(a)bl0rg.net>" @@ -22,34 +22,25 @@ :depends-on (:cl-interpol :cl-ppcre :cl-gd - :aserve - ;:net.post-office + :kmrcl :md5 :cxml :unit-test :bknr-utils :bknr-xml + :hunchentoot + :xhtmlgen :puri - ;:stem - ;:mime - :klammerscript :bknr-datastore - :bknr-data-impex - :kmrcl - :iconv - #+(not allegro) - :acl-compat) + :bknr-data-impex) :components ((:file "packages") - - (:module "xhtmlgen" :components ((:file "xhtmlgen")) - :depends-on ("packages")) (:module "sysclasses" :components ((:file "event") (:file "user" :depends-on ("event")) (:file "cron") (:file "sysparam")) - :depends-on ("xhtmlgen")) + :depends-on ("packages")) (:module "htmlize" :components ((:file "hyperspec") (:file "htmlize" @@ -68,6 +59,7 @@ :depends-on ("parse-xml" "rss"))) :depends-on ("packages")) + #+notyet (:module "web" :components ((:file "site") ;; data (:file "host") @@ -116,8 +108,9 @@ "templates" "site" "web-utils"))) - :depends-on ("sysclasses" "packages" "xhtmlgen" "rss")) + :depends-on ("sysclasses" "packages" "rss")) + #+notyet (:module "images" :components ((:file "image") (:file "image-tags" :depends-on ("image")) Modified: branches/trunk-reorg/bknr/web/src/packages.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/packages.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -175,12 +175,11 @@ :cl-gd :cl-interpol :cl-ppcre - :net.aserve + :hunchentoot :cxml-xmls :xhtml-generator :puri :md5 - :js :bknr.datastore :bknr.indices :bknr.impex @@ -189,7 +188,6 @@ :bknr.events :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) (:export #:*req* #:*ent* #:*user* @@ -400,7 +398,7 @@ :cl-gd :cl-interpol :cl-ppcre - :net.aserve + :hunchentoot :puri :xhtml-generator :bknr.rss @@ -410,7 +408,6 @@ :bknr.utils :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) - (:import-from :net.html.generator #:*html-stream*) (:export #:imageproc #:define-imageproc-handler #:image-handler ; plain images only Modified: branches/trunk-reorg/bknr/web/src/sysclasses/cron.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/sysclasses/cron.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/sysclasses/cron.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -10,24 +10,24 @@ (>= hour 0) (< hour 24))) -(defconstant +day-list+ '(:monday :tuesday :wednesday :thursday :friday :saturday :sunday)) +(defparameter *day-list* '(:monday :tuesday :wednesday :thursday :friday :saturday :sunday)) (defun day-p (day) (or (and (numberp day) (>= day 1) (<= day 7)) (and (symbolp day) - (member day +day-list+)))) + (member day *day-list*)))) (defun day-to-number (day) (if (numberp day) day - (let ((num (position day +day-list+))) + (let ((num (position day *day-list*))) (if num (1+ num) (error "Could not find day in day-list"))))) -(defconstant +month-list+ '(:january :february :march :april :may :june :july +(defparameter *month-list* '(:january :february :march :april :may :june :july :august :september :october :november :december)) (defun month-p (month) @@ -35,12 +35,12 @@ (>= month 1) (<= month 12)) (and (symbolp month) - (member month +month-list+)))) + (member month *month-list*)))) (defun month-to-number (month) (if (numberp month) month - (let ((num (position month +month-list+))) + (let ((num (position month *month-list*))) (if num (1+ num) (error "Could not find month in month-list"))))) Modified: branches/trunk-reorg/bknr/web/src/web/authorizer.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/web/authorizer.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/web/authorizer.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -3,6 +3,7 @@ (defclass bknr-authorizer () ()) +#+cmu (defmethod http-request-remote-host ((req http-request)) (let ((remote-host (socket:remote-host (request-socket req))) (forwarded-for (regex-replace Modified: branches/trunk-reorg/bknr/web/src/web/host.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/web/host.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/web/host.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -46,11 +46,11 @@ (host-ip-address host))) (defmethod host-ipaddr ((host host)) - (socket:dotted-to-ipaddr (host-ip-address host))) + (kmrcl::dotted-to-ipaddr (host-ip-address host))) (defun find-host (&key ip-address create ipaddr) (when ipaddr - (setf ip-address (socket:ipaddr-to-dotted ipaddr))) + (setf ip-address (kmrcl::ipaddr-to-dotted ipaddr))) (or (host-with-ipaddress ip-address) (and create (make-object 'host :ip-address ip-address)))) Modified: branches/trunk-reorg/bknr/web/src/web/site.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/web/site.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/web/site.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -6,5 +6,5 @@ (defparameter *thumbnail-max-height* 54) ;; default billboard to show on home page -(defconstant *default-billboard* "main") +(defparameter *default-billboard* "main") Modified: branches/trunk-reorg/bknr/web/src/web/web-visitor.lisp =================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-visitor.lisp 2007-10-06 23:06:39 UTC (rev 2226) +++ branches/trunk-reorg/bknr/web/src/web/web-visitor.lisp 2007-10-06 23:08:12 UTC (rev 2227) @@ -24,7 +24,7 @@ (when (web-visitor-event-host event) (format stream " from ~a [~a]" (host-name (web-visitor-event-host event)) - (host-ip-address (web-visitor-event-host event)))))) + (host-ip-address (web-visitor-event-host event))))) event) #+(or)

1 0

[bknr-cvs] r2226 - in branches/trunk-reorg/bknr/datastore/src: . data xml xml-impex
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 19:06:39 -0400 (Sat, 06 Oct 2007) New Revision: 2226 Modified: branches/trunk-reorg/bknr/datastore/src/bknr-impex.asd branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd branches/trunk-reorg/bknr/datastore/src/data/encoding.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp Log: Use :closer-mop instead of compiler-specific MOP. Fix import glitches for bknr-xml. Support character datatype for transaction log reading/writing. Modified: branches/trunk-reorg/bknr/datastore/src/bknr-impex.asd =================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-impex.asd 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/bknr-impex.asd 2007-10-06 23:06:39 UTC (rev 2226) @@ -21,7 +21,7 @@ :description "BKNR XML import/export" :long-description "" - :depends-on (:cl-interpol :cxml :bknr-utils :bknr-xml :bknr-indices) + :depends-on (:cl-interpol :cxml :closer-mop :bknr-utils :bknr-xml :bknr-indices) :components ((:module "xml-impex" :components Modified: branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd =================================================================== --- branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/bknr-xml.asd 2007-10-06 23:06:39 UTC (rev 2226) @@ -17,26 +17,5 @@ :description "baikonour - launchpad for lisp satellites" :depends-on (:cl-interpol :cxml) :components ((:module "xml" :components ((:file "package") - (:file "xml"))))) - -;; -*-Lisp-*- - -(in-package :cl-user) - -(defpackage :bknr.xml.system - (:use :cl :asdf)) - -(in-package :bknr.xml.system) - -(defsystem :bknr-xml - :name "baikonour" - :author "Hans Huebner <hans(a)huebner.org>" - :author "Manuel Odendahl <manuel(a)bl0rg.net>" - :version "0" - :maintainer "Manuel Odendahl <manuel(a)bl0rg.net>" - :licence "BSD" - :description "baikonour - launchpad for lisp satellites" - :depends-on (:cl-interpol :cxml) - :components ((:module "xml" :components ((:file "package") (:file "xml"))))) Modified: branches/trunk-reorg/bknr/datastore/src/data/encoding.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/data/encoding.lisp 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/data/encoding.lisp 2007-10-06 23:06:39 UTC (rev 2226) @@ -47,6 +47,10 @@ ;;; tail object Falls n != 0: CDR des letzten Conses ;;; ;;; ---------------------------------------------------------------- +;;; Char +;;; tag #\c +;;; data char Zeichen, mit WRITE-CHAR geschrieben +;;; ---------------------------------------------------------------- ;;; String ;;; tag #\s ;;; n %integer Anzahl der folgenden Zeichen @@ -169,6 +173,10 @@ (%write-char #\l stream) (%encode-list object stream)) +(defun encode-char (object stream) + (%write-char #\c stream) + (%write-char object stream)) + (defun %encode-string (object stream) (%encode-integer (length object) stream) #+allegro @@ -263,6 +271,7 @@ (typecase object (integer (encode-integer object stream)) (symbol (encode-symbol object stream)) + (character (encode-char object stream)) (string (encode-string object stream)) (list (encode-list object stream)) (array (encode-array object stream)) @@ -301,6 +310,9 @@ (assert (plusp n)) ;n==0 geben wir nicht aus (%decode-integer/fixed stream n))) +(defun %decode-char (stream) + (%read-char stream)) + (defun %decode-string (stream) #-allegro (let* ((n (%decode-integer stream)) @@ -395,6 +407,7 @@ (#\a (%decode-array stream)) (#\i (%decode-integer stream)) (#\y (%decode-symbol stream)) + (#\c (%decode-char stream)) (#\s (%decode-string stream)) (#\l (%decode-list stream)) (#\# (%decode-hash-table stream)) Modified: branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/xml/xml.lisp 2007-10-06 23:06:39 UTC (rev 2226) @@ -61,66 +61,3 @@ (write-char #\> stream) (write-char #\Newline stream)))) -(in-package :bknr.xml) - -(defun node-children-nodes (xml) - (remove-if-not #'consp (node-children xml))) - -(defun find-child (xml node-name) - (let ((children (node-children-nodes xml))) - (find node-name children :test #'string-equal :key #'node-name))) - -(defun find-children (xml node-name) - (let ((children (node-children-nodes xml))) - (find-all node-name children :test #'string-equal :key #'node-name))) - -(defun node-string-body (xml) - (let ((children (remove-if #'consp (node-children xml)))) - (if (every #'stringp children) - (apply #'concatenate 'string children) - (error "Some children are not strings")))) - -(defun node-attribute (xml attribute-name) - (cadr (assoc attribute-name (node-attrs xml) :test #'string-equal))) - -(defun node-child-string-body (xml node-name) - (let ((child (find-child xml node-name))) - (if (and child (consp child)) - (node-string-body child) - nil))) - -(defun node-to-html (node &optional (stream *standard-output*)) - (when (stringp node) - (write-string node) - (return-from node-to-html)) - (write-char #\< stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (loop for (key value) in (node-attrs node) - do (write-char #\Space stream) - (write-string key stream) - (write-char #\= stream) - (write-char #\" stream) - (write-string value stream) - (write-char #\" stream)) - (if (node-children node) - (progn - (write-char #\> stream) - (write-char #\Newline stream) - (dolist (child (node-children node)) - (node-to-html child stream)) - (write-char #\< stream) - (write-char #\/ stream) - (when (node-ns node) - (write-string (node-ns node) stream) - (write-char #\: stream)) - (write-string (node-name node) stream) - (write-char #\> stream) - (write-char #\Newline stream)) - (progn (write-char #\Space stream) - (write-char #\/ stream) - (write-char #\> stream) - (write-char #\Newline stream)))) - Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/package.lisp 2007-10-06 23:06:39 UTC (rev 2226) @@ -6,12 +6,7 @@ :ext :cl-user :cxml - #+allegro - :aclmop - #+cmu - :pcl - #+sbcl - :sb-pcl + :closer-mop :bknr.utils :bknr.xml :bknr.indices) Modified: branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp 2007-10-06 21:39:22 UTC (rev 2225) +++ branches/trunk-reorg/bknr/datastore/src/xml-impex/xml-export.lisp 2007-10-06 23:06:39 UTC (rev 2226) @@ -39,9 +39,9 @@ (defmethod write-to-xml ((object standard-object) &key &allow-other-keys) (cxml:with-element (string-downcase (class-name (class-of object))) - (dolist (slot (pcl:class-slots (class-of object))) - (cxml:with-element (string-downcase (symbol-name (pcl:slot-definition-name slot))) - (let ((value (slot-value object (pcl:slot-definition-name slot)))) + (dolist (slot (class-slots (class-of object))) + (cxml:with-element (string-downcase (symbol-name (slot-definition-name slot))) + (let ((value (slot-value object (slot-definition-name slot)))) (when value (cxml:text (handler-case (cxml::utf8-string-to-rod (princ-to-string value))

1 0

[bknr-cvs] r2225 - in branches/trunk-reorg/thirdparty: . kmrcl-1.97
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 17:39:22 -0400 (Sat, 06 Oct 2007) New Revision: 2225 Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/ branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile branches/trunk-reorg/thirdparty/kmrcl-1.97/README branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp Removed: branches/trunk-reorg/thirdparty/kmrcl-1.72/ Log: bring kmrcl up to date Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/ChangeLog 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,53 @@ +18 Sep 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.97 + * datetime.lisp: Improve output format for date-string + +10 Sep 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.96 + * byte-stream.lisp: Use without-package-locks as suggested + by Daniel Gackle. + +01 Jun 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.95 + * {datetime,package}.lisp: Add day-of-week and pretty-date-ut + +07 Jan 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.94 + * signals.lisp: Conditionalize Lispworks support to :unix *features* + +07 Jan 2007 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.93 + * signals.lisp: Add new file for signal processing + +31 Dec 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * impl.lisp, sockets.lisp, equal.lisp, datetime.lisp: Declare ignored variables + +29 Nov 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.92 + * strings.lisp: Add uri-query-to-alist + +24 Oct 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.91 + * io.lisp: Fix output from read-file-to-string + +22 Sep 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.90 + * sockets.lisp: Commit patch from Joerg Hoehle for CLISP sockets + +04 Sep 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.89 + * kmrcl.asd, mop.lisp: Add support for CLISP MOP + * strings.lisp: Add prefixed-number-string macro with type optimization used + by prefixed-fixnum-string and prefixed-integer-string + * package.lisp: export prefixed-integer-string + +27 Jul 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.88 + * strings.lisp, package.lisp: Add binary-sequence-to-hex-string + +26 Jul 2006 Kevin Rosenberg <kevin(a)rosenberg.net> + * Version 1.87 + * proceeses.lisp, sockets.lisp: Apply patch from Travis Cross + for SBCL, posted on + http://common-lisp.net/pipermail/tbnl-devel/2005-December/000524.html + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/LICENSE 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,78 @@ +Copyright (C) 2000-2006 by Kevin M. Rosenberg. + +This code is free software; you can redistribute it and/or modify it +under the terms of the version 2.1 of the GNU Lesser General Public +License as published by the Free Software Foundation, as clarified by +the Franz preamble to the LGPL found in +http://opensource.franz.com/preamble.html. The preambled is copied below. + +This code 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 +Lesser General Public License for more details. + +The GNU Lessor General Public License can be found in your Debian file +system in /usr/share/common-licenses/LGPL. + +Preamble to the Gnu Lesser General Public License +------------------------------------------------- +Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 + +The concept of the GNU Lesser General Public License version 2.1 +("LGPL") has been adopted to govern the use and distribution of +above-mentioned application. However, the LGPL uses terminology that +is more appropriate for a program written in C than one written in +Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if +certain clarifications are made. This document details those +clarifications. Accordingly, the license for the open-source Lisp +applications consists of this document plus the LGPL. Wherever there +is a conflict between this document and the LGPL, this document takes +precedence over the LGPL. + +A "Library" in Lisp is a collection of Lisp functions, data and +foreign modules. The form of the Library can be Lisp source code (for +processing by an interpreter) or object code (usually the result of +compilation of source code or built with some other +mechanisms). Foreign modules are object code in a form that can be +linked into a Lisp executable. When we speak of functions we do so in +the most general way to include, in addition, methods and unnamed +functions. Lisp "data" is also a general term that includes the data +structures resulting from defining Lisp classes. A Lisp application +may include the same set of Lisp objects as does a Library, but this +does not mean that the application is necessarily a "work based on the +Library" it contains. + +The Library consists of everything in the distribution file set before +any modifications are made to the files. If any of the functions or +classes in the Library are redefined in other files, then those +redefinitions ARE considered a work based on the Library. If +additional methods are added to generic functions in the Library, +those additional methods are NOT considered a work based on the +Library. If Library classes are subclassed, these subclasses are NOT +considered a work based on the Library. If the Library is modified to +explicitly call other functions that are neither part of Lisp itself +nor an available add-on module to Lisp, then the functions called by +the modified Library ARE considered a work based on the Library. The +goal is to ensure that the Library will compile and run without +getting undefined function errors. + +It is permitted to add proprietary source code to the Library, but it +must be done in a way such that the Library will still run without +that proprietary code present. Section 5 of the LGPL distinguishes +between the case of a library being dynamically linked at runtime and +one being statically linked at build time. Section 5 of the LGPL +states that the former results in an executable that is a "work that +uses the Library." Section 5 of the LGPL states that the latter +results in one that is a "derivative of the Library", which is +therefore covered by the LGPL. Since Lisp only offers one choice, +which is to link the Library into an executable at build time, we +declare that, for the purpose applying the LGPL to the Library, an +executable that results from linking a "work that uses the Library" +with the Library is considered a "work that uses the Library" and is +therefore NOT covered by the LGPL. + +Because of this declaration, section 6 of LGPL is not applicable to +the Library. However, in connection with each distribution of this +executable, you must also deliver, in accordance with the terms and +conditions of the LGPL, the source code of Library (or your derivative +thereof) that is incorporated into this executable. Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/Makefile 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,32 @@ +.PHONY: all clean test test-acl test-sbcl + +test-file:=`pwd`/run-tests.lisp +all: + +clean: + @find . -type f -name "*.fasl*" -or -name "*.ufsl" -or -name "*.x86f" \ + -or -name "*.fas" -or -name "*.pfsl" -or -name "*.dfsl" \ + -or -name "*~" -or -name ".#*" -or -name "#*#" | xargs rm -f + +test: test-alisp + +test-alisp: + alisp8 -q -L $(test-file) + +test-mlisp: + mlisp -q -L $(test-file) + +test-sbcl: + sbcl --noinform --disable-debugger --userinit $(test-file) + +test-cmucl: + lisp -init $(test-file) + +test-lw: + lw-console -init $(test-file) + +test-scl: + scl -init $(test-file) + +test-clisp: + clisp -norc -q -i $(test-file) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/README =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/README 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/README 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,6 @@ +KMRCL is a collection of utility functions. It is used as a base for +some of Kevin M. Rosenberg's Common Lisp packages. + +The web site for KMRCL is http://files.b9.com/kmrcl/ + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/attrib-class.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,106 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl-*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: attrib-class.lisp +;;;; Purpose: Defines metaclass allowing use of attributes on slots +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +;; Disable attrib class until understand changes in sbcl/cmucl +;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method +;; for slot access of ALL-ATTRIBUTES. Does this work on Allegro/LW? + +;;;; Defines a metaclass that allows the use of attributes (or subslots) +;;;; on slots. Based on example in AMOP, but modified to use ACL's MOP. + +(in-package #:kmrcl) + +(defclass attributes-class (kmr-mop:standard-class) + () + (:documentation "metaclass that implements attributes on slots. Based +on example from AMOP")) + +(defclass attributes-dsd (kmr-mop:standard-direct-slot-definition) + ((attributes :initarg :attributes :initform nil + :accessor dsd-attributes))) + +(defclass attributes-esd (kmr-mop:standard-effective-slot-definition) + ((attributes :initarg :attributes :initform nil + :accessor esd-attributes))) + +;; encapsulating macro for Lispworks +(kmr-mop:process-slot-option attributes-class :attributes) + +#+(or cmu scl sbcl openmcl) +(defmethod kmr-mop:validate-superclass ((class attributes-class) + (superclass kmr-mop:standard-class)) + t) + +(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs) + (declare (ignore initargs)) + (kmr-mop:find-class 'attributes-dsd)) + +(defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs) + (declare (ignore initargs)) + (kmr-mop:find-class 'attributes-esd)) + +(defmethod kmr-mop:compute-effective-slot-definition + ((cl attributes-class) #+kmr-normal-cesd name dsds) + #+kmr-normal-cesd (declare (ignore name)) + (let ((esd (call-next-method))) + (setf (esd-attributes esd) (remove-duplicates (mapappend #'dsd-attributes dsds))) + esd)) + +;; This does not work in Lispworks prior to version 4.3 + +(defmethod kmr-mop:compute-slots ((class attributes-class)) + (let* ((normal-slots (call-next-method)) + (alist (mapcar + #'(lambda (slot) + (cons (kmr-mop:slot-definition-name slot) + (mapcar #'(lambda (attr) (list attr)) + (esd-attributes slot)))) + normal-slots))) + + (cons (make-instance + 'attributes-esd + :name 'all-attributes + :initform `',alist + :initfunction #'(lambda () alist) + :allocation :instance + :documentation "Attribute bucket" + :type t + ) + normal-slots))) + +(defun slot-attribute (instance slot-name attribute) + (cdr (slot-attribute-bucket instance slot-name attribute))) + +(defun (setf slot-attribute) (new-value instance slot-name attribute) + (setf (cdr (slot-attribute-bucket instance slot-name attribute)) + new-value)) + +(defun slot-attribute-bucket (instance slot-name attribute) + (let* ((all-buckets (slot-value instance 'all-attributes)) + (slot-bucket (assoc slot-name all-buckets))) + (unless slot-bucket + (error "The slot named ~S of ~S has no attributes." + slot-name instance)) + (let ((attr-bucket (assoc attribute (cdr slot-bucket)))) + (unless attr-bucket + (error "The slot named ~S of ~S has no attributes named ~S." + slot-name instance attribute)) + attr-bucket))) + + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/buff-input.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,182 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: buff-input.lisp +;;;; Purpose: Buffered line input +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package :kmrcl) + +(eval-when (:compile-toplevel) + (declaim (optimize (speed 3) (safety 0) (space 0) (debug 0)))) + +(defconstant +max-field+ 10000) +(defconstant +max-fields-per-line+ 20) +(defconstant +field-delim+ #\|) +(defconstant +eof-char+ #\rubout) +(defconstant +newline+ #\Newline) + +(declaim (type character +eof-char+ +field-delim+ +newline+) + (type fixnum +max-field+ +max-fields-per-line+)) + +;; Buffered fields parsing function +;; Uses fill-pointer for size + +(defun make-fields-buffer (&optional (max-fields +max-fields-per-line+) + (max-field-len +max-field+)) + (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil))) + (dotimes (i +max-fields-per-line+) + (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil))) + bufs)) + +(defun read-buffered-fields (fields strm &optional (field-delim +field-delim+) + (eof 'eof)) + "Read a line from a stream into a field buffers" + (declare (type base-char field-delim) + (type vector fields)) + (setf (fill-pointer fields) 0) + (do ((ifield 0 (1+ ifield)) + (linedone nil) + (is-eof nil)) + (linedone (if is-eof eof fields)) + (declare (type fixnum ifield) + (type boolean linedone is-eof)) + (let ((field (aref fields ifield))) + (declare (type base-string field)) + (do ((ipos 0) + (fielddone nil) + (rc (read-char strm nil +eof-char+) + (read-char strm nil +eof-char+))) + (fielddone (unread-char rc strm)) + (declare (type fixnum ipos) + (type base-char rc) + (type boolean fielddone)) + (cond + ((char= rc field-delim) + (setf (fill-pointer field) ipos) + (setq fielddone t)) + ((char= rc +newline+) + (setf (fill-pointer field) ipos) + (setf (fill-pointer fields) ifield) + (setq fielddone t) + (setq linedone t)) + ((char= rc +eof-char+) + (setf (fill-pointer field) ipos) + (setf (fill-pointer fields) ifield) + (setq fielddone t) + (setq linedone t) + (setq is-eof t)) + (t + (setf (char field ipos) rc) + (incf ipos))))))) + +;; Buffered fields parsing +;; Does not use fill-pointer +;; Returns 2 values -- string array and length array +(defstruct field-buffers + (nfields 0 :type fixnum) + (buffers) + (field-lengths)) + +(defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+) + (max-field-len +max-field+)) + (let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil)) + (bufstruct (make-field-buffers))) + (dotimes (i +max-fields-per-line+) + (setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil))) + (setf (field-buffers-buffers bufstruct) bufs) + (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+ + :element-type 'fixnum :fill-pointer nil :adjustable nil)) + (setf (field-buffers-nfields bufstruct) 0) + bufstruct)) + + +(defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+) + (eof 'eof)) + "Read a line from a stream into a field buffers" + (declare (character field-delim)) + (setf (field-buffers-nfields fields) 0) + (do ((ifield 0 (1+ ifield)) + (linedone nil) + (is-eof nil)) + (linedone (if is-eof eof fields)) + (declare (fixnum ifield) + (t linedone is-eof)) + (let ((field (aref (field-buffers-buffers fields) ifield))) + (declare (simple-string field)) + (do ((ipos 0) + (fielddone nil) + (rc (read-char strm nil +eof-char+) + (read-char strm nil +eof-char+))) + (fielddone (unread-char rc strm)) + (declare (fixnum ipos) + (character rc) + (t fielddone)) + (cond + ((char= rc field-delim) + (setf (aref (field-buffers-field-lengths fields) ifield) ipos) + (setq fielddone t)) + ((char= rc +newline+) + (setf (aref (field-buffers-field-lengths fields) ifield) ipos) + (setf (field-buffers-nfields fields) ifield) + (setq fielddone t) + (setq linedone t)) + ((char= rc +eof-char+) + (setf (aref (field-buffers-field-lengths fields) ifield) ipos) + (setf (field-buffers-nfields fields) ifield) + (setq fielddone t) + (setq linedone t) + (setq is-eof t)) + (t + (setf (char field ipos) rc) + (incf ipos))))))) + +(defun bfield (fields i) + (if (>= i (field-buffers-nfields fields)) + nil + (subseq (aref (field-buffers-buffers fields) i) 0 (aref (field-buffers-field-lengths fields) i)))) + +;;; Buffered line parsing function + +(defconstant +max-line+ 20000) +(let ((linebuffer (make-array +max-line+ + :element-type 'character + :fill-pointer 0))) + (defun read-buffered-line (strm eof) + "Read a line from astream into a vector buffer" + (declare (optimize (speed 3) (space 0) (safety 0))) + (let ((pos 0) + (done nil)) + (declare (fixnum pos) (type boolean done)) + (setf (fill-pointer linebuffer) 0) + (do ((c (read-char strm nil +eof-char+) + (read-char strm nil +eof-char+))) + (done (progn + (unless (eql c +eof-char+) (unread-char c strm)) + (if (eql c +eof-char+) eof linebuffer))) + (declare (character c)) + (cond + ((>= pos +max-line+) + (warn "Line overflow") + (setf done t)) + ((char= c #\Newline) + (when (plusp pos) + (setf (fill-pointer linebuffer) (1- pos))) + (setf done t)) + ((char= +eof-char+) + (setf done t)) + (t + (setf (char linebuffer pos) c) + (incf pos))))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/byte-stream.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,270 @@ +;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: kmrcl -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: byte-stream.lisp +;;;; Purpose: Byte array input/output streams +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: June 2003 +;;;; +;;;; $Id$ +;;;; +;;;; Works for CMUCL, SBCL, and AllergoCL only +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2003 by Kevin M. Rosenberg +;;;; and by onShore Development, Inc. +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +;; Intial CMUCL version by OnShored. Ported to SBCL by Kevin Rosenberg + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (sb-ext:without-package-locks + (sb-pcl::structure-class-p + (find-class (intern "FILE-STREAM" "SB-IMPL")))) + (push :old-sb-file-stream cl:*features*))) + +#+(or cmu sbcl) +(progn +(defstruct (byte-array-output-stream + (:include #+cmu system:lisp-stream + #+(and sbcl old-sb-file-stream) sb-impl::file-stream + #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream + (bout #'byte-array-bout) + (misc #'byte-array-out-misc)) + (:print-function %print-byte-array-output-stream) + (:constructor make-byte-array-output-stream ())) + ;; The buffer we throw stuff in. + (buffer (make-array 128 :element-type '(unsigned-byte 8))) + ;; Index of the next location to use. + (index 0 :type fixnum)) + +(defun %print-byte-array-output-stream (s stream d) + (declare (ignore s d)) + (write-string "#<Byte-Array-Output Stream>" stream)) + +(setf (documentation 'make-binary-output-stream 'function) + "Returns an Output stream which will accumulate all output given it for + the benefit of the function Get-Output-Stream-Data.") + +(defun byte-array-bout (stream byte) + (let ((current (byte-array-output-stream-index stream)) + (workspace (byte-array-output-stream-buffer stream))) + (if (= current (length workspace)) + (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8)))) + (replace new-workspace workspace) + (setf (aref new-workspace current) byte) + (setf (byte-array-output-stream-buffer stream) new-workspace)) + (setf (aref workspace current) byte)) + (setf (byte-array-output-stream-index stream) (1+ current)))) + +(defun byte-array-out-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:file-position + (if (null arg1) + (byte-array-output-stream-index stream))) + (:element-type '(unsigned-byte 8)))) + +(defun get-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function and +clears buffer." + (declare (type byte-array-output-stream stream)) + (prog1 + (dump-output-stream-data stream) + (setf (byte-array-output-stream-index stream) 0))) + +(defun dump-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function." + (declare (type byte-array-output-stream stream)) + (let* ((length (byte-array-output-stream-index stream)) + (result (make-array length :element-type '(unsigned-byte 8)))) + (replace result (byte-array-output-stream-buffer stream)) + result)) + +) ; progn + + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (sb-ext:without-package-locks + (defvar *system-copy-fn* (if (fboundp (intern "COPY-SYSTEM-AREA" "SB-KERNEL")) + (intern "COPY-SYSTEM-AREA" "SB-KERNEL") + (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL"))) + (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")) + sb-vm:n-byte-bits + 1)))) + +#+(or cmu sbcl) +(progn + (defstruct (byte-array-input-stream + (:include #+cmu system:lisp-stream + ;;#+sbcl sb-impl::file-stream + #+(and sbcl old-sb-file-stream) sb-impl::file-stream + #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream + (in #'byte-array-inch) + (bin #'byte-array-binch) + (n-bin #'byte-array-stream-read-n-bytes) + (misc #'byte-array-in-misc)) + (:print-function %print-byte-array-input-stream) + ;(:constructor nil) + (:constructor internal-make-byte-array-input-stream + (byte-array current end))) + (byte-array nil :type vector) + (current nil) + (end nil)) + + +(defun %print-byte-array-input-stream (s stream d) + (declare (ignore s d)) + (write-string "#<Byte-Array-Input Stream>" stream)) + +(defun byte-array-inch (stream eof-errorp eof-value) + (let ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream))) + (cond ((= index (byte-array-input-stream-end stream)) + #+cmu + (eof-or-lose stream eof-errorp eof-value) + #+sbcl + (sb-impl::eof-or-lose stream eof-errorp eof-value) + ) + (t + (setf (byte-array-input-stream-current stream) (1+ index)) + (aref byte-array index))))) + +(defun byte-array-binch (stream eof-errorp eof-value) + (let ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream))) + (cond ((= index (byte-array-input-stream-end stream)) + #+cmu + (eof-or-lose stream eof-errorp eof-value) + #+sbcl + (sb-impl::eof-or-lose stream eof-errorp eof-value) + ) + (t + (setf (byte-array-input-stream-current stream) (1+ index)) + (aref byte-array index))))) + +(defun byte-array-stream-read-n-bytes (stream buffer start requested eof-errorp) + (declare (type byte-array-input-stream stream)) + (let* ((byte-array (byte-array-input-stream-byte-array stream)) + (index (byte-array-input-stream-current stream)) + (available (- (byte-array-input-stream-end stream) index)) + (copy (min available requested))) + (when (plusp copy) + (setf (byte-array-input-stream-current stream) + (+ index copy)) + #+cmu + (system:without-gcing + (system::system-area-copy (system:vector-sap byte-array) + (* index vm:byte-bits) + (if (typep buffer 'system::system-area-pointer) + buffer + (system:vector-sap buffer)) + (* start vm:byte-bits) + (* copy vm:byte-bits))) + #+sbcl + (sb-sys:without-gcing + (funcall *system-copy-fn* (sb-sys:vector-sap byte-array) + (* index +system-copy-multiplier+) + (if (typep buffer 'sb-sys::system-area-pointer) + buffer + (sb-sys:vector-sap buffer)) + (* start +system-copy-multiplier+) + (* copy +system-copy-multiplier+)))) + (if (and (> requested copy) eof-errorp) + (error 'end-of-file :stream stream) + copy))) + +(defun byte-array-in-misc (stream operation &optional arg1 arg2) + (declare (ignore arg2)) + (case operation + (:file-position + (if arg1 + (setf (byte-array-input-stream-current stream) arg1) + (byte-array-input-stream-current stream))) + (:file-length (length (byte-array-input-stream-byte-array stream))) + (:unread (decf (byte-array-input-stream-current stream))) + (:listen (or (/= (the fixnum (byte-array-input-stream-current stream)) + (the fixnum (byte-array-input-stream-end stream))) + :eof)) + (:element-type 'base-char))) + +(defun make-byte-array-input-stream (buffer &optional (start 0) (end (length buffer))) + "Returns an input stream which will supply the bytes of BUFFER between + Start and End in order." + (internal-make-byte-array-input-stream buffer start end)) + +) ;; progn + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :old-sb-file-stream cl:*features*))) + +;;; Simple streams implementation by Kevin Rosenberg + +#+allegro +(progn + + (defclass extendable-buffer-output-stream (excl:buffer-output-simple-stream) + () + ) + + (defun make-byte-array-output-stream () + "Returns an Output stream which will accumulate all output given it for + the benefit of the function Get-Output-Stream-Data." + (make-instance 'extendable-buffer-output-stream + :buffer (make-array 128 :element-type '(unsigned-byte 8)) + :external-form :octets)) + + (defun get-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function +and clears buffer." + (prog1 + (dump-output-stream-data stream) + (file-position stream 0))) + + (defun dump-output-stream-data (stream) + "Returns an array of all data sent to a stream made by +Make-Byte-Array-Output-Stream since the last call to this function." + (force-output stream) + (let* ((length (file-position stream)) + (result (make-array length :element-type '(unsigned-byte 8)))) + (replace result (slot-value stream 'excl::buffer)) + result)) + + (excl::without-package-locks + (defmethod excl:device-extend ((stream extendable-buffer-output-stream) + need action) + (declare (ignore action)) + (let* ((len (file-position stream)) + (new-len (max (+ len need) (* 2 len))) + (old-buf (slot-value stream 'excl::buffer)) + (new-buf (make-array new-len :element-type '(unsigned-byte 8)))) + (declare (fixnum len) + (optimize (speed 3) (safety 0))) + (dotimes (i len) + (setf (aref new-buf i) (aref old-buf i))) + (setf (slot-value stream 'excl::buffer) new-buf) + (setf (slot-value stream 'excl::buffer-ptr) new-len) + ) + t)) + +) + +#+allegro +(progn + (defun make-byte-array-input-stream (buffer &optional (start 0) + (end (length buffer))) + (excl:make-buffer-input-stream buffer start end :octets)) + ) ;; progn + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/color.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,315 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: color.lisp +;;;; Purpose: Functions for color +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Oct 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +;; The HSV colour space has three coordinates: hue, saturation, and +;; value (sometimes called brighness) respectively. This colour system is +;; attributed to "Smith" around 1978 and used to be called the hexcone +;; colour model. The hue is an angle from 0 to 360 degrees, typically 0 +;; is red, 60 degrees yellow, 120 degrees green, 180 degrees cyan, 240 +;; degrees blue, and 300 degrees magenta. Saturation typically ranges +;; from 0 to 1 (sometimes 0 to 100%) and defines how grey the colour is, +;; 0 indicates grey and 1 is the pure primary colour. Value is similar to +;; luninance except it also varies the colour saturation. If the colour +;; space is represented by disks of varying lightness then the hue and +;; saturation are the equivalent to polar coordinates (r,theta) of any +;; point in the plane. The disks on the right show this for various +;; values. + +(defun hsv->rgb (h s v) + (declare (optimize (speed 3) (safety 0))) + (when (zerop s) + (return-from hsv->rgb (values v v v))) + + (while (minusp h) + (incf h 360)) + (while (>= h 360) + (decf h 360)) + + (let ((h-pos (/ h 60))) + (multiple-value-bind (h-int h-frac) (truncate h-pos) + (declare (fixnum h-int)) + (let ((p (* v (- 1 s))) + (q (* v (- 1 (* s h-frac)))) + (t_ (* v (- 1 (* s (- 1 h-frac))))) + r g b) + + (cond + ((zerop h-int) + (setf r v + g t_ + b p)) + ((= 1 h-int) + (setf r q + g v + b p)) + ((= 2 h-int) + (setf r p + g v + b t_)) + ((= 3 h-int) + (setf r p + g q + b v)) + ((= 4 h-int) + (setf r t_ + g p + b v)) + ((= 5 h-int) + (setf r v + g p + b q))) + (values r g b))))) + + +(defun hsv255->rgb255 (h s v) + (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + + (when (zerop s) + (return-from hsv255->rgb255 (values v v v))) + + (locally (declare (type fixnum h s v)) + (while (minusp h) + (incf h 360)) + (while (>= h 360) + (decf h 360)) + + (let ((h-pos (/ h 60))) + (multiple-value-bind (h-int h-frac) (truncate h-pos) + (declare (fixnum h-int)) + (let* ((fs (/ s 255)) + (fv (/ v 255)) + (p (round (* 255 fv (- 1 fs)))) + (q (round (* 255 fv (- 1 (* fs h-frac))))) + (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac)))))) + r g b) + + (cond + ((zerop h-int) + (setf r v + g t_ + b p)) + ((= 1 h-int) + (setf r q + g v + b p)) + ((= 2 h-int) + (setf r p + g v + b t_)) + ((= 3 h-int) + (setf r p + g q + b v)) + ((= 4 h-int) + (setf r t_ + g p + b v)) + ((= 5 h-int) + (setf r v + g p + b q))) + (values r g b)))))) + + + +(defun rgb->hsv (r g b) + (declare (optimize (speed 3) (safety 0))) + + (let* ((min (min r g b)) + (max (max r g b)) + (delta (- max min)) + (v max) + (s 0) + (h nil)) + + (when (plusp max) + (setq s (/ delta max))) + + (when (plusp delta) + (setq h (cond + ((= max r) + (nth-value 0 (/ (- g b) delta))) + ((= max g) + (nth-value 0 (+ 2 (/ (- b r) delta)))) + (t + (nth-value 0 (+ 4 (/ (- r g) delta)))))) + (setq h (the fixnum (* 60 h))) + (when (minusp h) + (incf h 360))) + + (values h s v))) + +(defun rgb255->hsv255 (r g b) + "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255" + (declare (fixnum r g b) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + + (let* ((min (min r g b)) + (max (max r g b)) + (delta (- max min)) + (v max) + (s 0) + (h nil)) + (declare (fixnum min max delta v s) + (type (or null fixnum) h)) + + (when (plusp max) + (setq s (truncate (the fixnum (* 255 delta)) max))) + + (when (plusp delta) + (setq h (cond + ((= max r) + (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta)) + ((= max g) + (the fixnum + (+ 120 (truncate (the fixnum (* 60 (the fixnum (- b r)))) delta)))) + (t + (the fixnum + (+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta)))))) + (when (minusp h) + (incf h 360))) + + (values h s v))) + + +(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001)) + (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + (flet ((~= (a b) + (cond + ((and (null a) (null b)) + t) + ((or (null a) (null b)) + nil) + (t + (< (abs (- a b)) limit))))) + (cond + ((and (~= 0 v1) (~= 0 v2)) + t) + ((or (null h1) (null h2)) + (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2)) + t)) + (t + (when (~= h1 h2) (~= s1 s2) (~= v1 v2) + t))))) + +(defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1)) + (declare (type fixnum s1 v1 s2 v2 limit) + (type (or null fixnum) h1 h2) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + (flet ((~= (a b) + (declare (type (or null fixnum) a b)) + (cond + ((and (null a) (null b)) + t) + ((or (null a) (null b)) + nil) + (t + (<= (abs (the fixnum (- a b))) limit))))) + (cond + ((and (~= 0 v1) (~= 0 v2)) + t) + ((or (null h1) (null h2)) + (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2)) + t)) + (t + (when (~= h1 h2) (~= s1 s2) (~= v1 v2) + t))))) + +(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key + (hue-range 15) (value-range .2) (saturation-range 0.2) + (gray-limit 0.3) (black-limit 0.3)) + "Returns T if two HSV values are similar." + (cond + ;; all black colors are similar + ((and (<= v1 black-limit) (<= v2 black-limit)) + t) + ;; all desaturated (gray) colors are similar for a value, despite hue + ((and (<= s1 gray-limit) (<= s2 gray-limit)) + (when (<= (abs (- v1 v2)) value-range) + t)) + (t + (when (and (<= (abs (hue-difference h1 h2)) hue-range) + (<= (abs (- v1 v2)) value-range) + (<= (abs (- s1 s2)) saturation-range)) + t)))) + + +(defun hsv255-similar (h1 s1 v1 h2 s2 v2 + &key (hue-range 15) (value-range 50) (saturation-range 50) + (gray-limit 75) (black-limit 75)) + "Returns T if two HSV values are similar." + (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range + gray-limit black-limit) + (type (or null fixnum) h1 h2) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))) + (cond + ;; all black colors are similar + ((and (<= v1 black-limit) (<= v2 black-limit)) + t) + ;; all desaturated (gray) colors are similar for a value, despite hue + ((and (<= s1 gray-limit) (<= s2 gray-limit)) + (when (<= (abs (- v1 v2)) value-range) + t)) + (t + (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range) + (<= (abs (- v1 v2)) value-range) + (<= (abs (- s1 s2)) saturation-range)) + t)))) + + + +(defun hue-difference (h1 h2) + "Return difference between two hues around 360 degree circle" + (cond + ((and (null h1) (null h2)) + t) + ((or (null h1) (null h2)) + 360) + (t + (let ((diff (- h2 h1))) + (cond + ((< diff -180) + (+ 360 diff) + ) + ((> diff 180) + (- (- 360 diff))) + (t + diff)))))) + + +(defun hue-difference-fixnum (h1 h2) + "Return difference between two hues around 360 degree circle" + (cond + ((and (null h1) (null h2)) + t) + ((or (null h1) (null h2)) + 360) + (t + (locally (declare (type fixnum h1 h2)) + (let ((diff (- h2 h1))) + (cond + ((< diff -180) + (+ 360 diff) + ) + ((> diff 180) + (- (- 360 diff))) + (t + diff))))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/console.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,50 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: console.lisp +;;;; Purpose: Console interactiion +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Dec 2002 +;;;; +;;;; $Id$ +;;;;a +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and by onShore Development, Inc. +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defvar *console-msgs* t) + +(defvar *console-msgs-types* nil) + +(defun cmsg (template &rest args) + "Format output to console" + (when *console-msgs* + (setq template (concatenate 'string "~&;; " template "~%")) + (apply #'format t template args))) + +(defun cmsg-c (condition template &rest args) + "Push CONDITION keywords into *console-msgs-types* to print console msgs + for that CONDITION. TEMPLATE and ARGS function identically to + (format t TEMPLATE ARGS) " + (when (or (member :verbose *console-msgs-types*) + (member condition *console-msgs-types*)) + (apply #'cmsg template args))) + +(defun cmsg-add (condition) + (pushnew condition *console-msgs-types*)) + +(defun cmsg-remove (condition) + (setf *console-msgs-types* (remove condition *console-msgs-types*))) + +(defun fixme (template &rest args) + "Format output to console" + (setq template (concatenate 'string "~&;; ** FIXME ** " template "~%")) + (apply #'format t template args) + (values)) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/datetime.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,157 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: datetime.lisp +;;;; Purpose: Date & Time functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +;;; Formatting functions + +(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0)) + (multiple-value-bind (sec min hr dy mn yr wkday) + (decode-universal-time + (encode-universal-time s m hour day month year)) + (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday" + "Friday" "Saturday" "Sunday") + wkday) + (elt '("January" "February" "March" "April" "May" "June" + "July" "August" "September" "October" "November" + "December") + (1- mn)) + (format nil "~A" dy) + (format nil "~A" yr) + (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec)))) + +(defun pretty-date-ut (&optional (tm (get-universal-time))) + (multiple-value-bind (sec min hr dy mn yr) (decode-universal-time tm) + (pretty-date yr mn dy hr min sec))) + +(defun date-string (ut) + (if (typep ut 'integer) + (multiple-value-bind (sec min hr day mon year dow daylight-p zone) + (decode-universal-time ut) + (declare (ignore daylight-p zone)) + (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~] ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d" + dow + day + (1- mon) + year + hr min sec)))) + +(defun print-seconds (secs) + (print-float-units secs "sec")) + +(defun print-float-units (val unit) + (cond + ((< val 1d-6) + (format t "~,2,9F nano~A" val unit)) + ((< val 1d-3) + (format t "~,2,6F micro~A" val unit)) + ((< val 1) + (format t "~,2,3F milli~A" val unit)) + ((> val 1d9) + (format t "~,2,-9F giga~A" val unit)) + ((> val 1d6) + (format t "~,2,-6F mega~A" val unit)) + ((> val 1d3) + (format t "~,2,-3F kilo~A" val unit)) + (t + (format t "~,2F ~A" val unit)))) + +(defconstant +posix-epoch+ + (encode-universal-time 0 0 0 1 1 1970 0)) + +(defun posix-time-to-utime (time) + (+ time +posix-epoch+)) + +(defun utime-to-posix-time (utime) + (- utime +posix-epoch+)) + +;; Monthnames taken from net-telent-date to support lml2 + +(defvar *monthnames* + '((1 . "January") + (2 . "February") + (3 . "March") + (4 . "April") + (5 . "May") + (6 . "June") + (7 . "July") + (8 . "August") + (9 . "September") + (10 . "October") + (11 . "November") + (12 . "December"))) + +(defun monthname (stream arg colon-p at-p &optional width (mincol 0) (colinc 1) (minpad 0) (padchar #\Space)) + "Print the name of the month (1=January) corresponding to ARG on STREAM. This is intended for embedding in a FORMAT directive: WIDTH governs the number of characters of text printed, MINCOL, COLINC, MINPAD, PADCHAR work as for ~A" + (declare (ignore colon-p)) + (let ((monthstring (cdr (assoc arg *monthnames*)))) + (if (not monthstring) (return-from monthname nil)) + (let ((truncate (if width (min width (length monthstring)) nil))) + (format stream + (if at-p "~V,V,V,V@A" "~V,V,V,VA") + mincol colinc minpad padchar + (subseq monthstring 0 truncate))))) + +(defconstant* +zellers-adj+ #(0 3 2 5 0 3 5 1 4 6 2 4)) + +(defun day-of-week (year month day) + "Day of week calculation using Zeller's Congruence. +Input: The year y, month m (1 ≤ m ≤ 12) and day d (1 ≤ d ≤ 31). +Output: n - the day of the week (Sunday = 0, Saturday = 6)." + + (when (< month 3) + (decf year)) + (mod + (+ year (floor year 4) (- (floor year 100)) (floor year 400) + (aref +zellers-adj+ (1- month)) day) + 7)) + +;;;; Daylight Saving Time calculations + +;; Daylight Saving Time begins for most of the United States at 2 +;; a.m. on the first Sunday of April. Time reverts to standard time at +;; 2 a.m. on the last Sunday of October. In the U.S., each time zone +;; switches at a different time. + +;; In the European Union, Summer Time begins and ends at 1 am +;; Universal Time (Greenwich Mean Time). It starts the last Sunday in +;; March, and ends the last Sunday in October. In the EU, all time +;; zones change at the same moment. + +;; Spring forward, Fall back +;; During DST, clocks are turned forward an hour, effectively moving +;; an hour of daylight from the morning to the evening. + +;; United States European Union + +;; Year DST Begins DST Ends Summertime Summertime +;; at 2 a.m. at 2 a.m. period begins period ends +;; at 1 a.m. UT at 1 a.m. UT +;; ---------------------------------------------------------- +;; 2000 April 2 October 29 March 26 October 29 +;; 2001 April 1 October 28 March 25 October 28 +;; 2002 April 7 October 27 March 31 October 27 +;; 2003 April 6 October 26 March 30 October 26 +;; 2004 April 4 October 31 March 28 October 31 +;; 2005 April 3 October 30 March 27 October 30 +;; 2006 April 2 October 29 March 26 October 29 +;; 2007 April 1 October 28 March 25 October 28 +;; 2008 April 6 October 26 March 30 October 26 + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/docbook.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,110 @@ +(in-package kmrcl) + +(defpackage docbook + (:use #:cl #:cl-who #:kmrcl) + (:export + #:docbook-file + #:docbook-stream + #:xml-file->sexp-file + )) +(in-package docbook) + +(defmacro docbook-stream (stream tree) + `(progn + (print-prologue ,stream) + (write-char #\Newline ,stream) + (let (cl-who::*indent* t) + (cl-who:with-html-output (,stream) ,tree)))) + +(defun print-prologue (stream) + (write-string "<?xml version='1.0' ?> " stream) + (write-char #\Newline stream) + (write-string "<!DOCTYPE book PUBLIC \"-//OASIS//DTD DocBook XML V4.2//EN\"" stream) + (write-char #\Newline stream) + (write-string " \"http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd\" [" stream) + (write-char #\Newline stream) + (write-string "<!ENTITY % myents SYSTEM \"entities.xml\">" stream) + (write-char #\Newline stream) + (write-string "%myents;" stream) + (write-char #\Newline stream) + (write-string "]>" stream) + (write-char #\Newline stream)) + +(defmacro docbook-file (name tree) + (let ((%name (gensym))) + `(let ((,%name ,name)) + (with-open-file (stream ,%name :direction :output + :if-exists :supersede) + (docbook-stream stream ,tree)) + (values)))) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'pxml) + (require 'uri)) + +(defun is-whitespace-string (s) + (and (stringp s) + (kmrcl:is-string-whitespace s))) + +(defun atom-processor (a) + (when a + (typecase a + (symbol + (nth-value 0 (kmrcl:ensure-keyword a))) + (string + (kmrcl:collapse-whitespace a)) + (t + a)))) + +(defun entity-callback (var token &optional public) + (declare (ignore token public)) + (cond + ((and (net.uri:uri-scheme var) + (string= "http" (net.uri:uri-scheme var))) + nil) + (t + (let ((path (net.uri:uri-path var))) + (if (probe-file path) + (ignore-errors (open path)) + (make-string-input-stream + (let ((*print-circle* nil)) + (format nil "<!ENTITY ~A '~A'>" path path)))))))) + +#+allegro +(defun xml-file->sexp-file (file &key (preprocess nil)) + (let* ((path (etypecase file + (string (parse-namestring file)) + (pathname file))) + (new-path (make-pathname :defaults path + :type "sexp")) + raw-sexp) + + (if preprocess + (multiple-value-bind (xml error status) + (kmrcl:command-output (format nil + "sh -c \"export XML_CATALOG_FILES='~A'; cd ~A; xsltproc --xinclude pprint.xsl ~A\"" + "catalog-debian.xml" + (namestring (make-pathname :defaults (if (pathname-directory path) + path + *default-pathname-defaults*) + :name nil :type nil)) + (namestring path))) + (unless (and (zerop status) (or (null error) (zerop (length error)))) + (error "Unable to preprocess XML file ~A, status ~D.~%Error: ~A" + path status error)) + (setq raw-sexp (net.xml.parser:parse-xml + (apply #'concatenate 'string xml) + :content-only nil))) + (with-open-file (input path :direction :input) + (setq raw-sexp (net.xml.parser:parse-xml input :external-callback #'entity-callback)))) + + (with-open-file (output new-path :direction :output + :if-exists :supersede) + (let ((filtered (kmrcl:remove-from-tree-if #'is-whitespace-string + raw-sexp + #'atom-processor))) + (write filtered :stream output :pretty t)))) + (values)) + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/equal.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,138 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: equal.lisp +;;;; Purpose: Generalized equal function for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + + +(in-package #:kmrcl) + + +(defun generalized-equal (obj1 obj2) + (if (not (equal (type-of obj1) (type-of obj2))) + (progn + (terpri) + (describe obj1) + (describe obj2) + nil) + (typecase obj1 + (double-float + (let ((diff (abs (/ (- obj1 obj2) obj1)))) + (if (> diff (* 10 double-float-epsilon)) + nil + t))) + (complex + (and (generalized-equal (realpart obj1) (realpart obj2)) + (generalized-equal (imagpart obj1) (imagpart obj2)))) + (structure-object + (generalized-equal-fielded-object obj1 obj2)) + (standard-object + (generalized-equal-fielded-object obj1 obj2)) + (hash-table + (generalized-equal-hash-table obj1 obj2) + ) + (function + (generalized-equal-function obj1 obj2)) + (string + (string= obj1 obj2)) + (array + (generalized-equal-array obj1 obj2)) + (t + (equal obj1 obj2))))) + + +(defun generalized-equal-function (obj1 obj2) + (string= (function-to-string obj1) (function-to-string obj2))) + +(defun generalized-equal-array (obj1 obj2) + (block test + (when (not (= (array-total-size obj1) (array-total-size obj2))) + (return-from test nil)) + (dotimes (i (array-total-size obj1)) + (unless (generalized-equal (aref obj1 i) (aref obj2 i)) + (return-from test nil))) + (return-from test t))) + +(defun generalized-equal-hash-table (obj1 obj2) + (block test + (when (not (= (hash-table-count obj1) (hash-table-count obj2))) + (return-from test nil)) + (maphash + #'(lambda (k v) + (multiple-value-bind (value found) (gethash k obj2) + (unless (and found (generalized-equal v value)) + (return-from test nil)))) + obj1) + (return-from test t))) + +(defun generalized-equal-fielded-object (obj1 obj2) + (block test + (when (not (equal (class-of obj1) (class-of obj2))) + (return-from test nil)) + (dolist (field (class-slot-names (class-name (class-of obj1)))) + (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field)) + (return-from test nil))) + (return-from test t))) + +(defun class-slot-names (c-name) + "Given a CLASS-NAME, returns a list of the slots in the class." + #+(or allegro cmu lispworks sbcl scl) + (mapcar #'kmr-mop:slot-definition-name + (kmr-mop:class-slots (kmr-mop:find-class c-name))) + #+(and mcl (not openmcl)) + (let* ((class (find-class c-name nil))) + (when (typep class 'standard-class) + (nconc (mapcar #'car (ccl:class-instance-slots class)) + (mapcar #'car (ccl:class-class-slots class))))) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (declare (ignore c-name)) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (error "class-slot-names is not defined on this platform") + ) + +(defun structure-slot-names (s-name) + "Given a STRUCTURE-NAME, returns a list of the slots in the structure." + #+allegro (class-slot-names s-name) + #+lispworks (structure:structure-class-slot-names + (find-class s-name)) + #+(or sbcl cmu) (mapcar #'kmr-mop:slot-definition-name + (kmr-mop:class-slots (kmr-mop:find-class s-name))) + #+scl (mapcar #'kernel:dsd-name + (kernel:dd-slots + (kernel:layout-info + (kernel:class-layout (find-class s-name))))) + #+(and mcl (not openmcl)) + (let* ((sd (gethash s-name ccl::%defstructs%)) + (slots (if sd (ccl::sd-slots sd)))) + (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (declare (ignore s-name)) + #-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl))) + (error "structure-slot-names is not defined on this platform") + ) + +(defun function-to-string (obj) + "Returns the lambda code for a function. Relies on +Allegro implementation-dependent features." + (multiple-value-bind (lambda closurep name) (function-lambda-expression obj) + (declare (ignore closurep)) + (if lambda + (format nil "#'~s" lambda) + (if name + (format nil "#'~s" name) + (progn + (print obj) + (break)))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/functions.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,53 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: functions.lisp +;;;; Purpose: Function routines for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package :kmrcl) + +(defun memo-proc (fn) + "Memoize results of call to fn, returns a closure with hash-table" + (let ((cache (make-hash-table :test #'equal))) + #'(lambda (&rest args) + (multiple-value-bind (val foundp) (gethash args cache) + (if foundp + val + (setf (gethash args cache) (apply fn args))))))) + +(defun memoize (fn-name) + (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name)))) + +(defmacro defun-memo (fn args &body body) + "Define a memoized function" + `(memoize (defun ,fn ,args . ,body))) + +(defmacro _f (op place &rest args) + (multiple-value-bind (vars forms var set access) + (get-setf-expansion place) + `(let* (,@(mapcar #'list vars forms) + (,(car var) (,op ,access ,@args))) + ,set))) + +(defun compose (&rest fns) + (if fns + (let ((fn1 (car (last fns))) + (fns (butlast fns))) + #'(lambda (&rest args) + (reduce #'funcall fns + :from-end t + :initial-value (apply fn1 args)))) + #'identity)) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/ifstar.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,61 @@ +;; the if* macro used in Allegro: +;; +;; This is in the public domain... please feel free to put this definition +;; in your code or distribute it with your version of lisp. + +(in-package #:kmrcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/impl.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,148 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: impl.lisp +;;;; Purpose: Implementation Dependent routines for kmrcl +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun canonicalize-directory-name (filename) + (flet ((un-unspecific (value) + (if (eq value :unspecific) nil value))) + (let* ((path (pathname filename)) + (name (un-unspecific (pathname-name path))) + (type (un-unspecific (pathname-type path))) + (new-dir + (cond ((and name type) (list (concatenate 'string name "." type))) + (name (list name)) + (type (list type)) + (t nil)))) + (if new-dir + (make-pathname + :directory (append (un-unspecific (pathname-directory path)) + new-dir) + :name nil :type nil :version nil :defaults path) + path)))) + + +(defun probe-directory (filename &key (error-if-does-not-exist nil)) + (let* ((path (canonicalize-directory-name filename)) + (probe + #+allegro (excl:probe-directory path) + #+clisp (values + (ignore-errors + (#+lisp=cl ext:probe-directory + #-lisp=cl lisp:probe-directory + path))) + #+(or cmu scl) (when (eq :directory + (unix:unix-file-kind (namestring path))) + path) + #+lispworks (when (lw:file-directory-p path) + path) + #+sbcl (when (eq :directory + (sb-unix:unix-file-kind (namestring path))) + path) + #-(or allegro clisp cmu lispworks sbcl scl) + (probe-file path))) + (if probe + probe + (when error-if-does-not-exist + (error "Directory ~A does not exist." filename))))) + +(defun cwd (&optional dir) + "Change directory and set default pathname" + (cond + ((not (null dir)) + (when (and (typep dir 'logical-pathname) + (translate-logical-pathname dir)) + (setq dir (translate-logical-pathname dir))) + (when (stringp dir) + (setq dir (parse-namestring dir))) + #+allegro (excl:chdir dir) + #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir) + #+(or cmu scl) (setf (ext:default-directory) dir) + #+cormanlisp (ccl:set-current-directory dir) + #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir) + #+openmcl (ccl:cwd dir) + #+gcl (si:chdir dir) + #+lispworks (hcl:change-directory dir) + (setq cl:*default-pathname-defaults* dir)) + (t + (let ((dir + #+allegro (excl:current-directory) + #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) + #+(or cmu scl) (ext:default-directory) + #+sbcl (sb-unix:posix-getcwd/) + #+cormanlisp (ccl:get-current-directory) + #+lispworks (hcl:get-working-directory) + #+mcl (ccl:mac-default-directory) + #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename "."))) + (when (stringp dir) + (setq dir (parse-namestring dir))) + dir)))) + + + +(defun quit (&optional (code 0)) + "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function." + #+allegro (excl:exit code :quiet t) + #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) + #+(or cmu scl) (ext:quit code) + #+cormanlisp (win32:exitprocess code) + #+gcl (lisp:bye code) + #+lispworks (lw:quit :status code) + #+lucid (lcl:quit code) + #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1))) + #+mcl (ccl:quit code) + #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl) + (error 'not-implemented :proc (list 'quit code))) + + +(defun command-line-arguments () + #+allegro (system:command-line-arguments) + #+sbcl sb-ext:*posix-argv* + ) + +(defun copy-file (from to &key link overwrite preserve-symbolic-links + (preserve-time t) remove-destination force verbose) + #+allegro (sys:copy-file from to :link link :overwrite overwrite + :preserve-symbolic-links preserve-symbolic-links + :preserve-time preserve-time + :remove-destination remove-destination + :force force :verbose verbose) + #-allegro + (declare (ignore verbose preserve-symbolic-links overwrite)) + (cond + ((and (typep from 'stream) (typep to 'stream)) + (copy-binary-stream from to)) + ((not (probe-file from)) + (error "File ~A does not exist." from)) + ((eq link :hard) + (run-shell-command "ln -f ~A ~A" (namestring from) (namestring to))) + (link + (multiple-value-bind (stdout stderr status) + (command-output "ln -f ~A ~A" (namestring from) (namestring to)) + (declare (ignore stdout stderr)) + ;; try symbolic if command failed + (unless (zerop status) + (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to))))) + (t + (when (and (or force remove-destination) (probe-file to)) + (delete-file to)) + (let* ((options (if preserve-time + "-p" + "")) + (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to)))) + (run-shell-command cmd))))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/io.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,329 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: io.lisp +;;;; Purpose: Input/Output functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun print-file-contents (file &optional (strm *standard-output*)) + "Opens a reads a file. Returns the contents as a single string" + (when (probe-file file) + (let ((eof (cons 'eof nil))) + (with-open-file (in file :direction :input) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (write-string line strm) + (write-char #\newline strm)))))) + +(defun read-stream-to-string (in) + (with-output-to-string (out) + (let ((eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (format out "~A~%" line))))) + +(defun read-file-to-string (file) + "Opens a reads a file. Returns the contents as a single string" + (with-open-file (in file :direction :input) + (read-stream-to-string in))) + +(defun read-file-to-usb8-array (file) + "Opens a reads a file. Returns the contents as single unsigned-byte array" + (with-open-file (in file :direction :input :element-type '(unsigned-byte 8)) + (let* ((file-len (file-length in)) + (usb8 (make-array file-len :element-type '(unsigned-byte 8))) + (pos (read-sequence usb8 in))) + (unless (= file-len pos) + (error "Length read (~D) doesn't match file length (~D)~%" pos file-len)) + usb8))) + + +(defun read-stream-to-strings (in) + (let ((lines '()) + (eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (push line lines)) + (nreverse lines))) + +(defun read-file-to-strings (file) + "Opens a reads a file. Returns the contents as a list of strings" + (with-open-file (in file :direction :input) + (read-stream-to-strings in))) + +(defun file-subst (old new file1 file2) + (with-open-file (in file1 :direction :input) + (with-open-file (out file2 :direction :output + :if-exists :supersede) + (stream-subst old new in out)))) + +(defun print-n-chars (char n stream) + (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0))) + (dotimes (i n) + (declare (fixnum i)) + (write-char char stream))) + +(defun print-n-strings (str n stream) + (declare (fixnum n) (optimize (speed 3) (safety 0) (space 0))) + (dotimes (i n) + (declare (fixnum i)) + (write-string str stream))) + +(defun indent-spaces (n &optional (stream *standard-output*)) + "Indent n*2 spaces to output stream" + (print-n-chars #\space (+ n n) stream)) + + +(defun indent-html-spaces (n &optional (stream *standard-output*)) + "Indent n*2 html spaces to output stream" + (print-n-strings " " (+ n n) stream)) + + +(defun print-list (l &optional (output *standard-output*)) + "Print a list to a stream" + (format output "~{~A~%~}" l)) + +(defun print-rows (rows &optional (ostrm *standard-output*)) + "Print a list of list rows to a stream" + (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r))) + + +;; Buffered stream substitute + +(defstruct buf + vec (start -1) (used -1) (new -1) (end -1)) + +(defun bref (buf n) + (svref (buf-vec buf) + (mod n (length (buf-vec buf))))) + +(defun (setf bref) (val buf n) + (setf (svref (buf-vec buf) + (mod n (length (buf-vec buf)))) + val)) + +(defun new-buf (len) + (make-buf :vec (make-array len))) + +(defun buf-insert (x b) + (setf (bref b (incf (buf-end b))) x)) + +(defun buf-pop (b) + (prog1 + (bref b (incf (buf-start b))) + (setf (buf-used b) (buf-start b) + (buf-new b) (buf-end b)))) + +(defun buf-next (b) + (when (< (buf-used b) (buf-new b)) + (bref b (incf (buf-used b))))) + +(defun buf-reset (b) + (setf (buf-used b) (buf-start b) + (buf-new b) (buf-end b))) + +(defun buf-clear (b) + (setf (buf-start b) -1 (buf-used b) -1 + (buf-new b) -1 (buf-end b) -1)) + +(defun buf-flush (b str) + (do ((i (1+ (buf-used b)) (1+ i))) + ((> i (buf-end b))) + (princ (bref b i) str))) + + +(defun stream-subst (old new in out) + (declare (string old new)) + (let* ((pos 0) + (len (length old)) + (buf (new-buf len)) + (from-buf nil)) + (declare (fixnum pos len)) + (do ((c (read-char in nil :eof) + (or (setf from-buf (buf-next buf)) + (read-char in nil :eof)))) + ((eql c :eof)) + (declare (character c)) + (cond ((char= c (char old pos)) + (incf pos) + (cond ((= pos len) ; 3 + (princ new out) + (setf pos 0) + (buf-clear buf)) + ((not from-buf) ; 2 + (buf-insert c buf)))) + ((zerop pos) ; 1 + (princ c out) + (when from-buf + (buf-pop buf) + (buf-reset buf))) + (t ; 4 + (unless from-buf + (buf-insert c buf)) + (princ (buf-pop buf) out) + (buf-reset buf) + (setf pos 0)))) + (buf-flush buf out))) + +(declaim (inline write-fixnum)) +(defun write-fixnum (n s) + #+allegro (excl::print-fixnum s 10 n) + #-allegro (write-string (write-to-string n) s)) + + + + +(defun null-output-stream () + (when (probe-file #p"/dev/null") + (open #p"/dev/null" :direction :output :if-exists :overwrite)) + ) + + +(defun directory-tree (filename) + "Returns a tree of pathnames for sub-directories of a directory" + (let* ((root (canonicalize-directory-name filename)) + (subdirs (loop for path in (directory + (make-pathname :name :wild + :type :wild + :defaults root)) + when (probe-directory path) + collect (canonicalize-directory-name path)))) + (when (find nil subdirs) + (error "~A" subdirs)) + (when (null root) + (error "~A" root)) + (if subdirs + (cons root (mapcar #'directory-tree subdirs)) + (if (probe-directory root) + (list root) + (error "root not directory ~A" root))))) + + +(defmacro with-utime-decoding ((utime &optional zone) &body body) + "UTIME is a universal-time, ZONE is a number of hours offset from UTC, or NIL to use local time. Execute BODY in an environment where SECOND MINUTE HOUR DAY-OF-MONTH MONTH YEAR DAY-OF-WEEK DAYLIGHT-P ZONE are bound to the decoded components of the universal time" + `(multiple-value-bind + (second minute hour day-of-month month year day-of-week daylight-p zone) + (decode-universal-time ,utime ,@(if zone (list zone))) + (declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone)) + ,@body)) + +(defvar +datetime-number-strings+ + (make-array 61 :adjustable nil :element-type 'string :fill-pointer nil + :initial-contents + '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11" + "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23" + "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35" + "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47" + "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59" + "60"))) + +(defun is-dst (utime) + (with-utime-decoding (utime) + daylight-p)) + + +(defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body) + (with-gensyms (zone) + `(let* ((,zone (cond + ((eq :utc ,utc-offset) + 0) + ((null utc-offset) + nil) + (t + (if (is-dst ,utime) + (1- (- ,utc-offset)) + (- ,utc-offset)))))) + (if ,zone + (with-utime-decoding (,utime ,zone) + ,@body) + (with-utime-decoding (,utime) + ,@body))))) + + +(defun write-utime-hms (utime &key utc-offset stream) + (if stream + (write-utime-hms-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-hms-stream utime s utc-offset)))) + +(defun write-utime-hms-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ second) stream))) + +(defun write-utime-hm (utime &key utc-offset stream) + (if stream + (write-utime-hm-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-hm-stream utime s utc-offset)))) + +(defun write-utime-hm-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream))) + + +(defun write-utime-ymdhms (utime &key stream utc-offset) + (if stream + (write-utime-ymdhms-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-ymdhms-stream utime s utc-offset)))) + +(defun write-utime-ymdhms-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (prefixed-fixnum-string year nil 4) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ month) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ day-of-month) stream) + (write-char #\space stream) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ second) stream))) + +(defun write-utime-ymdhm (utime &key stream utc-offset) + (if stream + (write-utime-ymdhm-stream utime stream utc-offset) + (with-output-to-string (s) + (write-utime-ymdhm-stream utime s utc-offset)))) + +(defun write-utime-ymdhm-stream (utime stream &optional utc-offset) + (with-utime-decoding-utc-offset (utime utc-offset) + (write-string (prefixed-fixnum-string year nil 4) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ month) stream) + (write-char #\/ stream) + (write-string (aref +datetime-number-strings+ day-of-month) stream) + (write-char #\space stream) + (write-string (aref +datetime-number-strings+ hour) stream) + (write-char #\: stream) + (write-string (aref +datetime-number-strings+ minute) stream))) + +(defun copy-binary-stream (in out &key (chunk-size 16384)) + (do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8))) + (pos (read-sequence buf in) (read-sequence buf in))) + ((zerop pos)) + (write-sequence buf out :end pos))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl-tests.asd 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,26 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmrcl-tests.asd +;;;; Purpose: ASDF system definitionf for kmrcl testing package +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(defpackage #:kmrcl-tests-system + (:use #:asdf #:cl)) +(in-package #:kmrcl-tests-system) + +(defsystem kmrcl-tests + :depends-on (:rt :kmrcl) + :components + ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package '#:regression-test))) + (error "test-op failed"))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/kmrcl.asd 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,67 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmrcl.asd +;;;; Purpose: ASDF system definition for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:cl-user) +(defpackage #:kmrcl-system (:use #:asdf #:cl)) +(in-package #:kmrcl-system) + +#+(or allegro cmu clisp lispworks sbcl scl openmcl) +(pushnew :kmr-mop cl:*features*) + +(defsystem kmrcl + :name "kmrcl" + :author "Kevin M. Rosenberg <kevin(a)rosenberg.net>" + :maintainer "Kevin M. Rosenberg <kmr(a)debian.org>" + :licence "LLGPL" + :depends-on (#+sbcl sb-posix) + :components + ((:file "package") + (:file "ifstar" :depends-on ("package")) + (:file "byte-stream" :depends-on ("package")) + (:file "macros" :depends-on ("package")) + (:file "functions" :depends-on ("macros")) + (:file "lists" :depends-on ("macros")) + (:file "seqs" :depends-on ("macros")) + (:file "impl" :depends-on ("macros")) + (:file "io" :depends-on ("macros" "impl")) + (:file "console" :depends-on ("macros")) + (:file "strings" :depends-on ("macros" "seqs")) + (:file "strmatch" :depends-on ("strings")) + (:file "buff-input" :depends-on ("macros")) + (:file "random" :depends-on ("macros")) + (:file "symbols" :depends-on ("macros")) + (:file "datetime" :depends-on ("macros")) + (:file "math" :depends-on ("macros")) + (:file "color" :depends-on ("macros")) + #+kmr-mop (:file "mop" :depends-on ("macros")) + ;; #+kmr-mop (:file "attrib-class" :depends-on ("seqs" "mop")) + (:file "equal" :depends-on ("macros" #+kmr-mop "mop")) + (:file "web-utils" :depends-on ("macros" "strings")) + (:file "xml-utils" :depends-on ("macros")) + (:file "sockets" :depends-on ("strings")) + (:file "processes" :depends-on ("macros")) + (:file "listener" :depends-on ("sockets" "processes" "console")) + (:file "repl" :depends-on ("listener" "strings")) + (:file "os" :depends-on ("macros" "impl")) + (:file "signals" :depends-on ("package")) + )) + +(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl)))) + (operate 'load-op 'kmrcl-tests) + (operate 'test-op 'kmrcl-tests :force t)) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/listener.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,288 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: listener.lisp +;;;; Purpose: Listener and worker processes +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jun 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +;;; Variables and data structures for Listener + +(defvar *listener-count* 0 + "used to name listeners") + +(defvar *worker-count* 0 + "used to name workers") + +(defvar *active-listeners* nil + "List of active listeners") + +(defclass listener () + ((port :initarg :port :accessor port) + (function :initarg :function :accessor listener-function + :initform nil) + (function-args :initarg :function-args :accessor function-args + :initform nil) + (process :initarg :process :accessor process :initform nil) + (socket :initarg :socket :accessor socket :initform nil) + (workers :initform nil :accessor workers + :documentation "list of worker threads") + (name :initform "" :accessor name :initarg :name) + (base-name :initform "listener" :accessor base-name :initarg :base-name) + (wait :initform nil :accessor wait :initarg :wait) + (timeout :initform nil :accessor timeout :initarg :timeout) + (number-fixed-workers :initform nil :accessor number-fixed-workers + :initarg :number-fixed-workers) + (catch-errors :initform nil :accessor catch-errors :initarg :catch-errors) + (remote-host-checker :initform nil :accessor remote-host-checker + :initarg :remote-host-checker) + (format :initform :text :accessor listener-format :initarg :format))) + +(defclass fixed-worker () + ((listener :initarg :listener :accessor listener :initform nil) + (name :initarg :name :accessor name :initform nil) + (process :initarg :process :accessor process :initform nil))) + +(defclass worker (fixed-worker) + ((connection :initarg :connection :accessor connection :initform nil) + (thread-fun :initarg :thread-fun :accessor thread-fun :initform nil))) + + +(defmethod print-object ((obj listener) s) + (print-unreadable-object (obj s :type t :identity nil) + (format s "port ~A" (port obj)))) + +(defmethod print-object ((obj fixed-worker) s) + (print-unreadable-object (obj s :type t :identity nil) + (format s "port ~A" (port (listener obj))))) + +;; High-level API + +(defun init/listener (listener state) + (check-type listener listener) + (case state + (:start + (when (member listener *active-listeners*) + (cmsg "~&listener ~A already initialized" listener) + (return-from init/listener)) + (when (listener-startup listener) + (push listener *active-listeners*) + listener)) + (:stop + (unless (member listener *active-listeners*) + (cmsg "~&listener ~A is not in active list" listener) + (return-from init/listener listener)) + (listener-shutdown listener) + (setq *active-listeners* (remove listener *active-listeners*))) + (:restart + (init/listener listener :stop) + (init/listener listener :start)))) + +(defun stop-all/listener () + (dolist (listener *active-listeners*) + (ignore-errors + (init/listener listener :stop)))) + +(defun listener-startup (listener) + (handler-case + (progn + (setf (name listener) (next-server-name (base-name listener))) + (make-socket-server listener)) + (error (e) + (format t "~&Error while trying to start listener on port ~A~& ~A" + (port listener) e) + (decf *listener-count*) + nil) + (:no-error (res) + (declare (ignore res)) + listener))) + +(defun listener-shutdown (listener) + (dolist (worker (workers listener)) + (when (and (typep worker 'worker) + (connection worker)) + (errorset (close-active-socket + (connection worker)) nil) + (setf (connection worker) nil)) + (when (process worker) + (errorset (destroy-process (process worker)) nil) + (setf (process worker) nil))) + (setf (workers listener) nil) + (with-slots (process socket) listener + (when socket + (errorset (close-passive-socket socket) nil) + (setf socket nil)) + (when process + (errorset (destroy-process process) nil) + (setf process nil)))) + +;; Low-level functions + +(defun next-server-name (base-name) + (format nil "~D-~A-socket-server" (incf *listener-count*) base-name)) + +(defun next-worker-name (base-name) + (format nil "~D-~A-worker" (incf *worker-count*) base-name)) + +(defun make-socket-server (listener) + #+lispworks + (progn + (setf (process listener) + (comm:start-up-server :process-name (name listener) + :service (port listener) + :function + #'(lambda (handle) + (lw-worker handle listener))))) + #-lispworks + (progn + (setf (socket listener) (create-inet-listener + (port listener) + :format (listener-format listener))) + (if (number-fixed-workers listener) + (start-fixed-number-of-workers listener) + (setf (process listener) (make-process + (name listener) + #'(lambda () + (start-socket-server listener)))))) + listener) + + +(defmethod initialize-instance :after + ((self worker) &key listener connection name &allow-other-keys) + (flet ((do-work () + (apply (listener-function listener) + connection + (function-args listener)))) + (unless connection + (error "connection not provided to modlisp-worker")) + (setf (slot-value self 'listener) listener) + (setf (slot-value self 'name) name) + (setf (slot-value self 'connection) connection) + (setf (slot-value self 'thread-fun) + #'(lambda () + (unwind-protect + (if (catch-errors listener) + (handler-case + (if (timeout listener) + (with-timeout ((timeout listener)) + (do-work)) + (do-work)) + (error (e) + (cmsg "Error ~A [~A]" e name))) + (if (timeout listener) + (with-timeout ((timeout listener)) + (do-work)) + (do-work))) + (progn + (errorset (finish-output connection) nil) + (errorset (close-active-socket connection) nil) + (cmsg-c :threads "~A ended" name) + (setf (workers listener) + (remove self (workers listener))))))))) + +(defun accept-and-check-tcp-connection (listener) + (multiple-value-bind (conn socket) (accept-tcp-connection (socket listener)) + (when (and (remote-host-checker listener) + (not (funcall (remote-host-checker listener) + (remote-host socket)))) + (cmsg-c :thread "Deny connection from ~A" (remote-host conn)) + (errorset (close-active-socket conn) nil) + (setq conn nil)) + conn)) + +(defun start-socket-server (listener) + (unwind-protect + (loop + (let ((connection (accept-and-check-tcp-connection listener))) + (when connection + (if (wait listener) + (unwind-protect + (apply (listener-function listener) + connection + (function-args listener)) + (progn + (errorset (finish-output connection) nil) + (errorset (close-active-socket connection) nil))) + (let ((worker (make-instance 'worker :listener listener + :connection connection + :name (next-worker-name + (base-name listener))))) + (setf (process worker) + (make-process (name worker) (thread-fun worker))) + (push worker (workers listener))))))) + (errorset (close-passive-socket (socket listener)) nil))) + +#+lispworks +(defun lw-worker (handle listener) + (let ((connection (make-instance 'comm:socket-stream + :socket handle + :direction :io + :element-type 'base-char))) + (if (wait listener) + (progn + (apply (listener-function listener) + connection + (function-args listener)) + (finish-output connection)) + (let ((worker (make-instance 'worker :listener listener + :connection connection + :name (next-worker-name + (base-name listener))))) + (setf (process worker) + (make-process (name worker) (thread-fun worker))) + (push worker (workers listener)))))) + +;; Fixed pool of workers + +(defun start-fixed-number-of-workers (listener) + (dotimes (i (number-fixed-workers listener)) + (let ((name (next-worker-name (base-name listener)))) + (push + (make-instance 'fixed-worker + :name name + :listener listener + :process + (make-process + name #'(lambda () (fixed-worker name listener)))) + (workers listener))))) + + +(defun fixed-worker (name listener) + (loop + (let ((connection (accept-and-check-tcp-connection listener))) + (when connection + (flet ((do-work () + (apply (listener-function listener) + connection + (function-args listener)))) + (unwind-protect + (handler-case + (if (catch-errors listener) + (handler-case + (if (timeout listener) + (with-timeout ((timeout listener)) + (do-work)) + (do-work)) + (error (e) + (cmsg "Error ~A [~A]" e name))) + (if (timeout listener) + (with-timeout ((timeout listener)) + (do-work)) + (do-work))) + (error (e) + (format t "Error: ~A" e))) + (errorset (finish-output connection) nil) + (errorset (close connection) nil))))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/lists.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,203 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: lists.lisp +;;;; Purpose: Functions for lists for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun mklist (obj) + "Make into list if atom" + (if (listp obj) obj (list obj))) + +(defun map-and-remove-nils (fn lst) + "mao a list by function, eliminate elements where fn returns nil" + (let ((acc nil)) + (dolist (x lst (nreverse acc)) + (let ((val (funcall fn x))) + (when val (push val acc)))))) + +(defun filter (fn lst) + "Filter a list by function, eliminate elements where fn returns nil" + (let ((acc nil)) + (dolist (x lst (nreverse acc)) + (when (funcall fn x) + (push x acc))))) + +(defun appendnew (l1 l2) + "Append two lists, filtering out elem from second list that are already in first list" + (dolist (elem l2 l1) + (unless (find elem l1) + (setq l1 (append l1 (list elem)))))) + +(defun remove-from-tree-if (pred tree &optional atom-processor) + "Strip from tree of atoms that satistify predicate" + (if (atom tree) + (unless (funcall pred tree) + (if atom-processor + (funcall atom-processor tree) + tree)) + (let ((car-strip (remove-from-tree-if pred (car tree) atom-processor)) + (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor))) + (cond + ((and car-strip (atom (cadr tree)) (null cdr-strip)) + (list car-strip)) + ((and car-strip cdr-strip) + (cons car-strip cdr-strip)) + (car-strip + car-strip) + (cdr-strip + cdr-strip))))) + +(defun find-tree (sym tree) + "Finds an atom as a car in tree and returns cdr tree at that positions" + (if (or (null tree) (atom tree)) + nil + (if (eql sym (car tree)) + (cdr tree) + (aif (find-tree sym (car tree)) + it + (aif (find-tree sym (cdr tree)) + it + nil))))) + +(defun flatten (lis) + (cond ((atom lis) lis) + ((listp (car lis)) + (append (flatten (car lis)) (flatten (cdr lis)))) + (t (append (list (car lis)) (flatten (cdr lis)))))) + +;;; Keyword functions + +(defun remove-keyword (key arglist) + (loop for sublist = arglist then rest until (null sublist) + for (elt arg . rest) = sublist + unless (eq key elt) append (list elt arg))) + +(defun remove-keywords (key-names args) + (loop for ( name val ) on args by #'cddr + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) + +(defun mapappend (func seq) + (apply #'append (mapcar func seq))) + +(defun mapcar-append-string-nontailrec (func v) + "Concatenate results of mapcar lambda calls" + (aif (car v) + (concatenate 'string (funcall func it) + (mapcar-append-string-nontailrec func (cdr v))) + "")) + + +(defun mapcar-append-string (func v &optional (accum "")) + "Concatenate results of mapcar lambda calls" + (aif (car v) + (mapcar-append-string + func + (cdr v) + (concatenate 'string accum (funcall func it))) + accum)) + +(defun mapcar2-append-string-nontailrec (func la lb) + "Concatenate results of mapcar lambda call's over two lists" + (let ((a (car la)) + (b (car lb))) + (if (and a b) + (concatenate 'string (funcall func a b) + (mapcar2-append-string-nontailrec func (cdr la) (cdr lb))) + ""))) + +(defun mapcar2-append-string (func la lb &optional (accum "")) + "Concatenate results of mapcar lambda call's over two lists" + (let ((a (car la)) + (b (car lb))) + (if (and a b) + (mapcar2-append-string func (cdr la) (cdr lb) + (concatenate 'string accum (funcall func a b))) + accum))) + +(defun append-sublists (list) + "Takes a list of lists and appends all sublists" + (let ((results (car list))) + (dolist (elem (cdr list) results) + (setq results (append results elem))))) + + +;; alists and plists + +(defun alist-elem-p (elem) + (and (consp elem) (atom (car elem)) (atom (cdr elem)))) + +(defun alistp (alist) + (when (listp alist) + (dolist (elem alist) + (unless (alist-elem-p elem) + (return-from alistp nil))) + t)) + +(defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity)) + "Macro to support below (setf get-alist)" + (let ((elem (gensym "ELEM-")) + (val (gensym "VAL-"))) + `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key)) + (,val ,value)) + (cond + (,elem + (setf (cdr ,elem) ,val)) + (,alist + (setf (cdr (last ,alist)) (list (cons ,akey ,val)))) + (t + (setf ,alist (list (cons ,akey ,val))))) + ,alist))) + +(defun get-alist (key alist &key (test #'eql)) + (cdr (assoc key alist :test test))) + +(defun (setf get-alist) (value key alist &key (test #'eql)) + "This won't work if the alist is NIL." + (update-alist key value alist :test test) + value) + +(defun alist-plist (alist) + (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist))) + +(defun plist-alist (plist) + (do ((alist '()) + (pl plist (cddr pl))) + ((null pl) alist) + (setq alist (acons (car pl) (cadr pl) alist)))) + +(defmacro update-plist (pkey value plist &key (test '#'eql)) + "Macro to support below (setf get-alist)" + (let ((pos (gensym))) + `(let ((,pos (member ,pkey ,plist :test ,test))) + (if ,pos + (progn + (setf (cadr ,pos) ,value) + ,plist) + (setf ,plist (append ,plist (list ,pkey ,value))))))) + + +(defun unique-slot-values (list slot &key (test 'eql)) + (let ((uniq '())) + (dolist (item list (nreverse uniq)) + (let ((value (slot-value item slot))) + (unless (find value uniq :test test) + (push value uniq)))))) + + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/macros.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,279 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: gentils.lisp +;;;; Purpose: Main general utility functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defmacro let-when ((var test-form) &body body) + `(let ((,var ,test-form)) + (when ,var ,@body))) + +(defmacro let-if ((var test-form) if-true &optional if-false) + `(let ((,var ,test-form)) + (if ,var ,if-true ,if-false))) + +;; Anaphoric macros + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it ,then ,else))) + +(defmacro awhen (test-form &body body) + `(aif ,test-form + (progn ,@body))) + +(defmacro awhile (expr &body body) + `(do ((it ,expr ,expr)) + ((not it)) + ,@body)) + +(defmacro aand (&rest args) + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(aif ,(car args) (aand ,@(cdr args)))))) + +(defmacro acond (&rest clauses) + (if (null clauses) + nil + (let ((cl1 (car clauses)) + (sym (gensym))) + `(let ((,sym ,(car cl1))) + (if ,sym + (let ((it ,sym)) ,@(cdr cl1)) + (acond ,@(cdr clauses))))))) + +(defmacro alambda (parms &body body) + `(labels ((self ,parms ,@body)) + #'self)) + +(defmacro aif2 (test &optional then else) + (let ((win (gensym))) + `(multiple-value-bind (it ,win) ,test + (if (or it ,win) ,then ,else)))) + +(defmacro awhen2 (test &body body) + `(aif2 ,test + (progn ,@body))) + +(defmacro awhile2 (test &body body) + (let ((flag (gensym))) + `(let ((,flag t)) + (while ,flag + (aif2 ,test + (progn ,@body) + (setq ,flag nil)))))) + +(defmacro acond2 (&rest clauses) + (if (null clauses) + nil + (let ((cl1 (car clauses)) + (val (gensym)) + (win (gensym))) + `(multiple-value-bind (,val ,win) ,(car cl1) + (if (or ,val ,win) + (let ((it ,val)) ,@(cdr cl1)) + (acond2 ,@(cdr clauses))))))) + +(defmacro mac (expr) +"Expand a macro" + `(pprint (macroexpand-1 ',expr))) + +(defmacro print-form-and-results (form) + `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form)) + + +;;; Loop macros + +(defmacro until (test &body body) + `(do () + (,test) + ,@body)) + +(defmacro while (test &body body) + `(do () + ((not ,test)) + ,@body)) + +(defmacro for ((var start stop) &body body) + (let ((gstop (gensym))) + `(do ((,var ,start (1+ ,var)) + (,gstop ,stop)) + ((> ,var ,gstop)) + ,@body))) + +(defmacro with-each-stream-line ((var stream) &body body) + (let ((eof (gensym)) + (eof-value (gensym)) + (strm (gensym))) + `(let ((,strm ,stream) + (,eof ',eof-value)) + (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof))) + ((eql ,var ,eof)) + ,@body)))) + +(defmacro with-each-file-line ((var file) &body body) + (let ((stream (gensym))) + `(with-open-file (,stream ,file :direction :input) + (with-each-stream-line (,var ,stream) + ,@body)))) + + +(defmacro in (obj &rest choices) + (let ((insym (gensym))) + `(let ((,insym ,obj)) + (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c)) + choices))))) + +(defmacro mean (&rest args) + `(/ (+ ,@args) ,(length args))) + +(defmacro with-gensyms (syms &body body) + `(let ,(mapcar #'(lambda (s) `(,s (gensym))) + syms) + ,@body)) + + +(defmacro time-seconds (&body body) + (let ((t1 (gensym))) + `(let ((,t1 (get-internal-real-time))) + (values + (progn ,@body) + (coerce (/ (- (get-internal-real-time) ,t1) + internal-time-units-per-second) + 'double-float))))) + +(defmacro time-iterations (n &body body) + (let ((i (gensym)) + (count (gensym))) + `(progn + (let ((,count ,n)) + (format t "~&Test with ~d iterations: ~W" ,count (quote ,body)) + (let ((t1 (get-internal-real-time))) + (dotimes (,i ,count) + ,@body) + (let* ((t2 (get-internal-real-time)) + (secs (coerce (/ (- t2 t1) + internal-time-units-per-second) + 'double-float))) + (format t "~&Total time: ") + (print-seconds secs) + (format t ", time per iteration: ") + (print-seconds (coerce (/ secs ,n) 'double-float)))))))) + +(defmacro mv-bind (vars form &body body) + `(multiple-value-bind ,vars ,form + ,@body)) + +;; From USENET +(defmacro deflex (var val &optional (doc nil docp)) + "Defines a top level (global) lexical VAR with initial value VAL, + which is assigned unconditionally as with DEFPARAMETER. If a DOC + string is provided, it is attached to both the name |VAR| and the + name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of + kind 'VARIABLE. The new VAR will have lexical scope and thus may + be shadowed by LET bindings without affecting its global value." + (let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-))) + (s1 (symbol-name var)) + (p1 (symbol-package var)) + (s2 (load-time-value (symbol-name '#:*))) + (backing-var (intern (concatenate 'string s0 s1 s2) p1))) + `(progn + (defparameter ,backing-var ,val ,@(when docp `(,doc))) + ,@(when docp + `((setf (documentation ',var 'variable) ,doc))) + (define-symbol-macro ,var ,backing-var)))) + +(defmacro def-cached-vector (name element-type) + (let ((get-name (concat-symbol "get-" name "-vector")) + (release-name (concat-symbol "release-" name "-vector")) + (table-name (concat-symbol "*cached-" name "-table*")) + (lock-name (concat-symbol "*cached-" name "-lock*"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar ,table-name (make-hash-table :test 'equal)) + (defvar ,lock-name (kmrcl::make-lock ,name)) + + (defun ,get-name (size) + (kmrcl::with-lock-held (,lock-name) + (let ((buffers (gethash (cons size ,element-type) ,table-name))) + (if buffers + (let ((buffer (pop buffers))) + (setf (gethash (cons size ,element-type) ,table-name) buffers) + buffer) + (make-array size :element-type ,element-type))))) + + (defun ,release-name (buffer) + (kmrcl::with-lock-held (,lock-name) + (let ((buffers (gethash (cons (array-total-size buffer) + ,element-type) + ,table-name))) + (setf (gethash (cons (array-total-size buffer) + ,element-type) ,table-name) + (cons buffer buffers)))))))) + +(defmacro def-cached-instance (name) + (let* ((new-name (concat-symbol "new-" name "-instance")) + (release-name (concat-symbol "release-" name "-instance")) + (cache-name (concat-symbol "*cached-" name "-instance-table*")) + (lock-name (concat-symbol "*cached-" name "-instance-lock*"))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar ,cache-name nil) + (defvar ,lock-name (kmrcl::make-lock ',name)) + + (defun ,new-name () + (kmrcl::with-lock-held (,lock-name) + (if ,cache-name + (pop ,cache-name) + (make-instance ',name)))) + + (defun ,release-name (instance) + (kmrcl::with-lock-held (,lock-name) + (push instance ,cache-name)))))) + +(defmacro with-ignore-errors (&rest forms) + `(progn + ,@(mapcar + (lambda (x) (list 'ignore-errors x)) + forms))) + +(defmacro ppmx (form) + "Pretty prints the macro expansion of FORM." + `(let* ((exp1 (macroexpand-1 ',form)) + (exp (macroexpand exp1)) + (*print-circle* nil)) + (cond ((equal exp exp1) + (format t "~&Macro expansion:") + (pprint exp)) + (t (format t "~&First step of expansion:") + (pprint exp1) + (format t "~%~%Final expansion:") + (pprint exp))) + (format t "~%~%") + (values))) + +(defmacro defconstant* (sym value &optional doc) + "Ensure VALUE is evaluated only once." + `(defconstant ,sym (if (boundp ',sym) + (symbol-value ',sym) + ,value) + ,@(when doc (list doc)))) + +(defmacro defvar-unbound (sym &optional (doc "")) + "defvar with a documentation string." + `(progn + (defvar ,sym) + (setf (documentation ',sym 'variable) ,doc))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/math.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,110 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: math.lisp +;;;; Purpose: General purpose math functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Nov 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + + +(in-package #:kmrcl) + +(defun deriv (f dx) + #'(lambda (x) + (/ (- (funcall f (+ x dx)) (funcall f x)) + dx))) + +(defun sin^ (x) + (funcall (deriv #'sin 1d-8) x)) + +;;; (sin^ pi) + +(defmacro ensure-integer (obj) + "Ensure object is an integer. If it is a string, then parse it" + `(if (stringp ,obj) + (parse-integer ,obj) + ,obj)) + +(defun histogram (v n-bins &key min max) + (declare (fixnum n-bins)) + (when (listp v) + (setq v (coerce v 'vector))) + (when (zerop (length v)) + (return-from histogram (values nil nil nil)) ) + (let ((n (length v)) + (bins (make-array n-bins :element-type 'integer :initial-element 0)) + found-min found-max) + (declare (fixnum n)) + (unless (and min max) + (setq found-min (aref v 0) + found-max (aref v 0)) + (loop for i fixnum from 1 to (1- n) + do + (let ((x (aref v i))) + (cond + ((> x found-max) + (setq found-max x)) + ((< x found-min) + (setq found-min x))))) + (unless min + (setq min found-min)) + (unless max + (setq max found-max))) + (let ((width (/ (- max min) n-bins))) + (setq width (+ width (* double-float-epsilon width))) + (dotimes (i n) + (let ((bin (nth-value 0 (truncate (- (aref v i) min) width)))) + (declare (fixnum bin)) + (when (and (not (minusp bin)) + (< bin n-bins)) + (incf (aref bins bin)))))) + (values bins min max))) + + +(defun fixnum-width () + (nth-value 0 (truncate (+ (/ (log (1+ most-positive-fixnum)) (log 2)) .5)))) + +(defun scaled-epsilon (float &optional (operation '+)) + "Return the smallest number that would return a value different from + FLOAT if OPERATION were applied to FLOAT and this number. OPERATION + should be either + or -, and defauls to +." + (multiple-value-bind (significand exponent) + (decode-float float) + (multiple-value-bind (1.0-significand 1.0-exponent) + (decode-float (float 1.0 float)) + (if (and (eq operation '-) + (= significand 1.0-significand)) + (scale-float (typecase float + (short-float short-float-negative-epsilon) + (single-float single-float-negative-epsilon) + (double-float double-float-negative-epsilon) + (long-float long-float-negative-epsilon)) + (- exponent 1.0-exponent)) + (scale-float (typecase float + (short-float short-float-epsilon) + (single-float single-float-epsilon) + (double-float double-float-epsilon) + (long-float long-float-epsilon)) + (- exponent 1.0-exponent)))))) + +(defun sinc (x) + (if (zerop x) + 1d0 + (let ((x (coerce x 'double-float))) + (/ (sin x) x)))) + + +(defun numbers-within-percentage (a b percent) + "Determines if two numbers are equal within a percentage difference." + (let ((abs-diff (* 0.01 percent 0.5 (+ (abs a) (abs b))))) + (< (abs (- a b)) abs-diff))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/mop.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,187 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mop.lisp +;;;; Purpose: Imports standard MOP symbols into KMRCL +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +;;; This file imports MOP symbols into KMR-MOP packages and then +;;; re-exports them to hide differences in MOP implementations. + +(in-package #:cl-user) + +#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (if (find-package 'sb-mop) + (pushnew :kmr-sbcl-mop cl:*features*) + (pushnew :kmr-sbcl-pcl cl:*features*))) + +#+cmu +(eval-when (:compile-toplevel :load-toplevel :execute) + (if (eq (symbol-package 'pcl:find-class) + (find-package 'common-lisp)) + (pushnew :kmr-cmucl-mop cl:*features*) + (pushnew :kmr-cmucl-pcl cl:*features*))) + +(defpackage #:kmr-mop + (:use + #:cl + #:kmrcl + #+kmr-sbcl-mop #:sb-mop + #+kmr-cmucl-mop #:mop + #+allegro #:mop + #+lispworks #:clos + #+clisp #:clos + #+scl #:clos + #+openmcl #:openmcl-mop + ) + ) + +(in-package #:kmr-mop) + +#+lispworks +(defun intern-eql-specializer (slot) + `(eql ,slot)) + +(defmacro process-class-option (metaclass slot-name &optional required) + #+lispworks + `(defmethod clos:process-a-class-option ((class ,metaclass) + (name (eql ,slot-name)) + value) + (when (and ,required (null value)) + (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name)) + (list name `',value)) + #-lispworks + (declare (ignore metaclass slot-name required)) + ) + +(defmacro process-slot-option (metaclass slot-name) + #+lispworks + `(defmethod clos:process-a-slot-option ((class ,metaclass) + (option (eql ,slot-name)) + value + already-processed-options + slot) + (list* option `',value already-processed-options)) + #-lispworks + (declare (ignore metaclass slot-name)) + ) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import + #+allegro + '(excl::compute-effective-slot-definition-initargs) + #+lispworks + '(clos::compute-effective-slot-definition-initargs) + #+clisp + '(clos::compute-effective-slot-definition-initargs) + #+sbcl + '(#+kmr-sbcl-mop class-of #-kmr-sbcl-mop sb-pcl:class-of + #+kmr-sbcl-mop class-name #-kmr-sbcl-mop sb-pcl:class-name + #+kmr-sbcl-mop class-slots #-kmr-sbcl-mop sb-pcl:class-slots + #+kmr-sbcl-mop find-class #-kmr-sbcl-mop sb-pcl:find-class + sb-pcl::standard-class + sb-pcl:slot-definition-name sb-pcl::finalize-inheritance + sb-pcl::standard-direct-slot-definition + sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass + sb-pcl::direct-slot-definition-class + sb-pcl::effective-slot-definition-class + sb-pcl::compute-effective-slot-definition + sb-pcl:class-direct-slots + sb-pcl::compute-effective-slot-definition-initargs + sb-pcl::slot-value-using-class + sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer + sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list + sb-pcl::compute-slots) + #+cmu + '(pcl:class-of pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class + pcl::slot-definition-name pcl:finalize-inheritance + pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition + pcl::validate-superclass pcl:direct-slot-definition-class pcl::effective-slot-definition-class + pcl:compute-effective-slot-definition + pcl:class-direct-slots + pcl::compute-effective-slot-definition-initargs + pcl::slot-value-using-class + pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer + pcl:make-method-lambda pcl:generic-function-lambda-list + pcl::compute-slots) + #+scl + '(class-of class-name class-slots find-class clos::standard-class + clos::slot-definition-name clos:finalize-inheritance + clos::standard-direct-slot-definition clos::standard-effective-slot-definition + clos::effective-slot-definition-class + clos:class-direct-slots + clos::validate-superclass clos:direct-slot-definition-class + clos:compute-effective-slot-definition + clos::compute-effective-slot-definition-initargs + clos::slot-value-using-class + clos::class-prototype clos:generic-function-method-class clos:intern-eql-specializer + clos:make-method-lambda clos:generic-function-lambda-list + clos::compute-slots + ;; note: make-method-lambda is not fbound + ) + #+openmcl + '(openmcl-mop::slot-definition-name openmcl-mop:finalize-inheritance + openmcl-mop::standard-direct-slot-definition openmcl-mop::standard-effective-slot-definition + openmcl-mop::validate-superclass openmcl-mop:direct-slot-definition-class openmcl-mop::effective-slot-definition-class + openmcl-mop:compute-effective-slot-definition + openmcl-mop:class-direct-slots + openmcl-mop::compute-effective-slot-definition-initargs + openmcl-mop::slot-value-using-class + openmcl-mop:class-prototype openmcl-mop:generic-function-method-class openmcl-mop:intern-eql-specializer + openmcl-mop:make-method-lambda openmcl-mop:generic-function-lambda-list + openmcl-mop::compute-slots) )) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(class-of class-name class-slots find-class + standard-class + slot-definition-name finalize-inheritance + standard-direct-slot-definition + standard-effective-slot-definition validate-superclass + compute-effective-slot-definition-initargs + direct-slot-definition-class effective-slot-definition-class + compute-effective-slot-definition + slot-value-using-class + class-prototype generic-function-method-class intern-eql-specializer + make-method-lambda generic-function-lambda-list + compute-slots + class-direct-slots + ;; KMR-MOP encapsulating macros + process-slot-option + process-class-option)) + + #+sbcl + (if (find-package 'sb-mop) + (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*)) + (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*))) + + #+cmu + (if (find-package 'mop) + (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*)) + (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*))) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'compute-effective-slot-definition))) + 3) + (pushnew :kmr-normal-cesd cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'direct-slot-definition-class))) + 3) + (pushnew :kmr-normal-dsdc cl:*features*)) + + ) ;; eval-when Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/os.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,179 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: os.lisp +;;;; Purpose: Operating System utilities +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jul 2003 +;;;; +;;;; $Id$ +;;;; +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun command-output (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, +returns (VALUES string-output error-output exit-status)" + (let ((command (apply #'format nil control-string args))) + #+sbcl + (let* ((process (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (sb-impl::process-output process))) + (error (read-stream-to-string (sb-impl::process-error process)))) + (close (sb-impl::process-output process)) + (close (sb-impl::process-error process)) + (values + output + error + (sb-impl::process-exit-code process))) + + + #+(or cmu scl) + (let* ((process (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (ext::process-output process))) + (error (read-stream-to-string (ext::process-error process)))) + (close (ext::process-output process)) + (close (ext::process-error process)) + + (values + output + error + (ext::process-exit-code process))) + + #+allegro + (multiple-value-bind (output error status) + (excl.osi:command-output command :whole t) + (values output error status)) + + #+lispworks + ;; BUG: Lispworks combines output and error streams + (let ((output (make-string-output-stream))) + (unwind-protect + (let ((status + (system:call-system-showing-output + command + :prefix "" + :show-cmd nil + :output-stream output))) + (values (get-output-stream-string output) nil status)) + (close output))) + + #+clisp + ;; BUG: CLisp doesn't allow output to user-specified stream + (values + nil + nil + (ext:run-shell-command command :output :terminal :wait t)) + + #+openmcl + (let* ((process (ccl:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream + :wait t)) + (output (read-stream-to-string (ccl::external-process-output-stream process))) + (error (read-stream-to-string (ccl::external-process-error-stream process)))) + (close (ccl::external-process-output-stream process)) + (close (ccl::external-process-error-stream process)) + (values output + error + (nth-value 1 (ccl::external-process-status process)))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "COMMAND-OUTPUT not implemented for this Lisp") + + )) + +(defun run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, +returns (VALUES output-string pid)" + (let ((command (apply #'format nil control-string args))) + #+sbcl + (sb-impl::process-exit-code + (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output nil)) + + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output nil)) + + + #+allegro + (excl:run-shell-command command :input nil :output nil + :wait t) + + #+lispworks + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :show-cmd nil + :prefix "" + :output-stream nil) + + #+clisp ;XXX not exactly *verbose-out*, I know + (ext:run-shell-command command :output :terminal :wait t) + + #+openmcl + (nth-value 1 + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output nil + :wait t))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "RUN-SHELL-PROGRAM not implemented for this Lisp") + + )) + +(defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force) + #+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist + :quiet quiet :force force) + #-(or allegro) (declare (ignore force)) + #-(or allegro) (cond + ((probe-directory dir) + (let ((cmd (format nil "rm -rf ~A" (namestring dir)))) + (unless quiet + (format *trace-output* ";; ~A" cmd)) + (command-output cmd))) + ((eq if-does-not-exist :error) + (error "Directory ~A does not exist [delete-directory-and-files]." dir)))) + +(defun file-size (file) + (when (probe-file file) + #+allegro (let ((stat (excl.osi:stat (namestring file)))) + (excl.osi:stat-size stat)) + #-allegro + (with-open-file (in file :direction :input) + (file-length in)))) + +(defun getpid () + "Return the PID of the lisp process." + #+allegro (excl::getpid) + #+(and lispworks win32) (win32:get-current-process-id) + #+(and lispworks (not win32)) (system::getpid) + #+sbcl (sb-posix:getpid) + #+cmu (unix:unix-getpid) + #+openmcl (ccl::getpid) + #+(and clisp unix) (system::process-id) + #+(and clisp win32) (cond ((find-package :win32) + (funcall (find-symbol "GetCurrentProcessId" + :win32))) + (t + (system::getenv "PID"))) + ) + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/package.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,324 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for kmrcl package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2006 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:kmrcl + (:nicknames #:kl) + (:use #:cl) + (:export + #:ensure-integer + #:mklist + #:filter + #:map-and-remove-nils + #:appendnew + #:memo-proc + #:memoize + #:defun-memo + #:_f + #:compose + #:until + #:while + #:for + + ;; strings.lisp + #:string-trim-whitespace + #:string-left-trim-whitespace + #:string-right-trim-whitespace + #:mapappend + #:mapcar-append-string + #:mapcar2-append-string + #:position-char + #:position-not-char + #:delimited-string-to-list + #:string-delimited-string-to-list + #:list-to-delimited-string + #:prefixed-fixnum-string + #:prefixed-integer-string + #:integer-string + #:fast-string-search + #:string-substitute + #:string-to-list-skip-delimiter + #:string-starts-with + #:count-string-char + #:count-string-char-if + #:hexchar + #:charhex + #:encode-uri-string + #:decode-uri-string + #:uri-query-to-alist + #:non-alphanumericp + #:random-string + #:first-char + #:last-char + #:ensure-string + #:string-right-trim-one-char + #:string-strip-ending + #:string-maybe-shorten + #:string-elide + #:shrink-vector + #:collapse-whitespace + #:string->list + #:trim-non-alphanumeric + #:binary-sequence-to-hex-string + + ;; io.lisp + #:indent-spaces + #:indent-html-spaces + #:print-n-chars + #:print-n-strings + #:print-list + #:print-rows + #:write-fixnum + #:file-subst + #:stream-subst + #:null-output-stream + #:directory-tree + #:write-utime-hms + #:write-utime-hm + #:write-utime-ymdhms + #:write-utime-ymdhm + #:write-utime-hms-stream + #:write-utime-hm-stream + #:write-utime-ymdhms-stream + #:write-utime-ymdhm-stream + #:with-utime-decoding + #:with-utime-decoding-utc-offset + #:is-dst + #:year + #:month + #:day-of-month + #:hour + #:minute + #:second + #:daylight-p + #:zone + #:day-of-month + #:day-of-week + #:+datetime-number-strings+ + #:utc-offset + #:copy-binary-stream + + ;; impl.lisp + #:probe-directory + #:cwd + #:quit + #:command-line-arguments + #:copy-file + #:run-shell-command + + ;; lists.lisp + #:remove-from-tree-if + #:find-tree + #:with-each-file-line + #:with-each-stream-line + #:remove-keyword + #:remove-keywords + #:append-sublists + #:alist-elem-p + #:alistp + #:get-alist + #:update-alist + #:alist-plist + #:plist-alist + #:update-plist + #:get-plist + #:flatten + #:unique-slot-values + + ;; seq.lisp + #:nsubseq + + ;; math.lisp + #:ensure-integer + #:histogram + #:fixnum-width + #:scaled-epsilon + #:sinc + #:numbers-within-percentage + + ;; macros.lisp + #:time-iterations + #:time-seconds + #:in + #:mean + #:with-gensyms + #:let-if + #:let-when + #:aif + #:awhen + #:awhile + #:aand + #:acond + #:alambda + #:it + #:mac + #:mv-bind + #:deflex + #:def-cached-vector + #:def-cached-instance + #:with-ignore-errors + #:ppmx + #:defconstant* + #:defvar-unbound + + ;; files.lisp + #:print-file-contents + #:read-stream-to-string + #:read-file-to-string + #:read-file-to-usb8-array + #:read-stream-to-strings + #:read-file-to-strings + + ;; strings.lisp + #:string-append + #:count-string-words + #:substitute-string-for-char + #:string-trim-last-character + #:nstring-trim-last-character + #:string-hash + #:is-string-empty + #:is-char-whitespace + #:not-whitespace-char + #:is-string-whitespace + #:string-invert + #:escape-xml-string + #:make-usb8-array + #:usb8-array-to-string + #:string-to-usb8-array + #:substitute-chars-strings + #:add-sql-quotes + #:escape-backslashes + #:concat-separated-strings + #:print-separated-strings + #:lex-string + #:split-alphanumeric-string + + ;; strmatch.lisp + #:score-multiword-match + #:multiword-match + + ;; symbols.lisp + #:ensure-keyword + #:ensure-keyword-upcase + #:ensure-keyword-default-case + #:concat-symbol + #:concat-symbol-pkg + #:show + #:show-variables + #:show-functions + + ;; From attrib-class.lisp + #:attributes-class + #:slot-attribute + #:slot-attributes + + #:generalized-equal + + ;; From buffered input + + #:make-fields-buffer + #:read-buffered-fields + + ;; From datetime.lisp + #:pretty-date-ut + #:pretty-date + #:date-string + #:print-float-units + #:print-seconds + #:posix-time-to-utime + #:utime-to-posix-time + + ;; From random.lisp + #:seed-random-generator + #:random-choice + + ;; From repl.lisp + #:make-repl + #:init/repl + + ;; From web-utils + #:*base-url* + #:base-url! + #:make-url + #:*standard-html-header* + #:*standard-xhtml-header* + #:*standard-xml-header* + #:user-agent-ie-p + #:decode-uri-query-string + #:split-uri-query-string + + ;; From xml-utils + #:sgml-header-stream + #:xml-tag-contents + #:positions-xml-tag-contents + #:cdata-string + #:write-cdata + + ;; From console + #:*console-msgs* + #:cmsg + #:cmsg-c + #:cmsg-add + #:cmsg-remove + #:fixme + + ;; byte-stream + #:make-binary-array-output-stream + #:get-output-stream-data + #:dump-output-stream-data + #:make-byte-array-input-stream + + ;; sockets.lisp + #:make-active-socket + #:close-active-socket + + ;; listener.lisp + #:init/listener + #:stop-all/listener + #:listener + + ;; fformat.lisp + #:fformat + + ;; os.lisp + #:command-output + #:run-shell-command-output-stream + #:delete-directory-and-files + #:file-size + #:getpid + + ;; color.lisp + #:rgb->hsv + #:rgb255->hsv255 + #:hsv->rgb + #:hsv255->rgb255 + #:hsv-equal + #:hsv255-equal + #:hsv-similar + #:hsv255-similar + #:hue-difference + #:hue-difference-fixnum + + ;; signals.lisp + #:set-signal-handler + #:remove-signal-handler + )) + + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/processes.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,76 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: processes.lisp +;;;; Purpose: Multiprocessing functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: June 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +(defun make-process (name func) + #+allegro (mp:process-run-function name func) + #+cmu (mp:make-process func :name name) + #+lispworks (mp:process-run-function name nil func) + #+sb-thread (sb-thread:make-thread func :name name) + #+openmcl (ccl:process-run-function name func) + #-(or allegro cmu lispworks sb-thread openmcl) (funcall func) + ) + +(defun destroy-process (process) + #+cmu (mp:destroy-process process) + #+allegro (mp:process-kill process) + #+sb-thread (sb-thread:destroy-thread process) + #+lispworks (mp:process-kill process) + #+openmcl (ccl:process-kill process) + ) + +(defun make-lock (name) + #+allegro (mp:make-process-lock :name name) + #+cmu (mp:make-lock name) + #+lispworks (mp:make-lock :name name) + #+sb-thread (sb-thread:make-mutex :name name) + #+openmcl (ccl:make-lock name) + ) + +(defmacro with-lock-held ((lock) &body body) + #+allegro + `(mp:with-process-lock (,lock) ,@body) + #+cmu + `(mp:with-lock-held (,lock) ,@body) + #+lispworks + `(mp:with-lock (,lock) ,@body) + #+sb-thread + `(sb-thread:with-recursive-lock (,lock) ,@body) + #+openmcl + `(ccl:with-lock-grabbed (,lock) ,@body) + #-(or allegro cmu lispworks sb-thread openmcl) + `(progn ,@body) + ) + + +(defmacro with-timeout ((seconds) &body body) + #+allegro + `(mp:with-timeout (,seconds) ,@body) + #+cmu + `(mp:with-timeout (,seconds) ,@body) + #+sb-thread + `(sb-ext:with-timeout ,seconds ,@body) + #+openmcl + `(ccl:process-wait-with-timeout "waiting" + (* ,seconds ccl:*ticks-per-second*) + #'(lambda () + ,@body) nil) + #-(or allegro cmu sb-thread openmcl) + `(progn ,@body) + ) + +(defun process-sleep (n) + #+allegro (mp:process-sleep n) + #-allegro (sleep n)) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/random.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,47 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: random.lisp +;;;; Purpose: Random number functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun seed-random-generator () + "Evaluate a random number of items" + (let ((randfile (make-pathname + :directory '(:absolute "dev") + :name "urandom"))) + (setf *random-state* (make-random-state t)) + (if (probe-file randfile) + (with-open-file + (rfs randfile :element-type 'unsigned-byte) + (let* + ;; ((seed (char-code (read-char rfs)))) + ((seed (read-byte rfs))) + ;;(format t "Randomizing!~%") + (loop + for item from 1 to seed + do (loop + for it from 0 to (+ (read-byte rfs) 5) + do (random 65536)))))))) + + +(defmacro random-choice (&rest exprs) + `(case (random ,(length exprs)) + ,@(let ((key -1)) + (mapcar #'(lambda (expr) + `(,(incf key) ,expr)) + exprs)))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/repl.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,96 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: repl.lisp +;;;; Purpose: A repl server +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defconstant +default-repl-server-port+ 4000) + +(defclass repl () + ((listener :initarg :listener :accessor listener + :initform nil))) + +(defun make-repl (&key (port +default-repl-server-port+) + announce user-checker remote-host-checker) + (make-instance 'listener + :port port + :base-name "repl" + :function 'repl-worker + :function-args (list user-checker announce) + :format :text + :wait nil + :remote-host-checker remote-host-checker + :catch-errors nil)) + +(defun init/repl (repl state) + (init/listener repl state)) + + +(defun repl-worker (conn user-checker announce) + (when announce + (format conn "~A~%" announce) + (force-output conn)) + (when user-checker + (let (login password) + (format conn "login: ") + (finish-output conn) + (setq login (read-socket-line conn)) + (format conn "password: ") + (finish-output conn) + (setq password (read-socket-line conn)) + (unless (funcall user-checker login password) + (format conn "Invalid login~%") + (finish-output conn) + (return-from repl-worker)))) + #+allegro + (tpl::start-interactive-top-level + conn + #'tpl::top-level-read-eval-print-loop + nil) + #-allegro + (repl-on-stream conn) + ) + +(defun read-socket-line (stream) + (string-right-trim-one-char #\return + (read-line stream nil nil))) + +(defun print-prompt (stream) + (format stream "~&~A> " (package-name *package*)) + (force-output stream)) + +(defun repl-on-stream (stream) + (let ((*standard-input* stream) + (*standard-output* stream) + (*terminal-io* stream) + (*debug-io* stream)) + #| + #+sbcl + (if (and (find-package 'sb-aclrepl) + (fboundp (intern "REPL-FUN" "SB-ACLREPL"))) + (sb-aclrepl::repl-fun) + (%repl)) + #-sbcl + |# + (%repl))) + +(defun %repl () + (loop + (print-prompt *standard-output*) + (let ((form (read *standard-input*))) + (format *standard-output* "~&~S~%" (eval form))))) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/run-tests.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,24 @@ +(in-package #:cl-user) +(defpackage #:run-tests (:use #:cl)) +(in-package #:run-tests) + +(require 'rt) +(load "kmrcl.asd") +(load "kmrcl-tests.asd") +(asdf:oos 'asdf:test-op 'kmrcl) + +(defun quit (&optional (code 0)) + "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function." + #+allegro (excl:exit code) + #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) + #+(or cmu scl) (ext:quit code) + #+cormanlisp (win32:exitprocess code) + #+gcl (lisp:bye code) + #+lispworks (lw:quit :status code) + #+lucid (lcl:quit code) + #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1))) + #+mcl (ccl:quit code) + #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl) + (error 'not-implemented :proc (list 'quit code))) + +(quit) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/seqs.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,28 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: seqs.lisp +;;;; Purpose: Sequence functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package :kmrcl) + + +(defun nsubseq (sequence start &optional end) + "Return a subsequence by pointing to location in original sequence" + (unless end (setq end (length sequence))) + (make-array (- end start) + :element-type (array-element-type sequence) + :displaced-to sequence + :displaced-index-offset start)) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/signals.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,74 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: signals.lisp +;;;; Purpose: Signal processing functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Jan 2007 +;;;; +;;;; $Id: processes.lisp 10985 2006-07-26 18:52:03Z kevin $ +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun signal-key-to-number (sig) + "These signals and numbers are only valid on POSIX systems, perhaps +some are Linux-specific." + (case sig + (:hup 1) + (:int 2) + (:quit 3) + (:kill 9) + (:usr1 10) + (:usr2 12) + (:pipe 13) + (:alrm 14) + (:term 15) + (t + (error "Signal ~A not known." sig)))) + + +(defun set-signal-handler (sig handler) + "Sets the handler for a signal to a function. Where possible, returns +the old handler for the function for later restoration with remove-signal-handler +below. + +To be portable, signal handlers should use (&rest dummy) function signatures +and ignore the value. They should return T to tell some Lisp implementations (Allegro) +that the signal was successfully handled." + (let ((signum (etypecase sig + (integer sig) + (keyword (signal-key-to-number sig))))) + #+allegro (excl:add-signal-handler signum handler) + #+cmu (system:enable-interrupt signum handler) + #+(and lispworks unix) + ;; non-documented method to get old handler, works in lispworks 5 + (let ((old-handler (when (and (boundp 'system::*signal-handler-functions*) + (typep system::*signal-handler-functions* 'array)) + (aref system::*signal-handler-functions* signum)))) + (system:set-signal-handler signum handler) + old-handler) + #+sbcl (sb-sys:enable-interrupt signum handler) + #-(or allegro cmu (and lispworks unix) sbcl) + (declare (ignore sig handler)) + #-(or allegro cmu (and lispworks unix) sbcl) + (warn "Signal setting not supported on this platform."))) + +(defun remove-signal-handler (sig &optional old-handler) + "Removes a handler from signal. Tries, when possible, to restore old-handler." + (let ((signum (etypecase sig + (integer sig) + (keyword (signal-key-to-number sig))))) + ;; allegro automatically restores old handler, because set-signal-handler above + ;; actually pushes the new handler onto a list of handlers + #+allegro (declare (ignore old-handler)) + #+allegro (excl:remove-signal-handler signum) + #+cmu (system:enable-interrupt signum (or old-handler :default)) + ;; lispworks removes handler if old-handler is nil + #+(and lispworks unix) (system:set-signal-handler signum old-handler) + #+sbcl (sb-sys:enable-interrupt signum (or old-handler :default)) + #-(or allegro cmu (and lispworks unix) sbcl) + (declare (ignore sig handler)) + #-(or allegro cmu (and lispworks unix) sbcl) + (warn "Signal setting not supported on this platform."))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/sockets.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,219 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: modlisp -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sockets.lisp +;;;; Purpose: Socket functions +;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve +;;;; Date Started: Jun 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(eval-when (:compile-toplevel :load-toplevel :execute) + #+sbcl (require :sb-bsd-sockets) + #+lispworks (require "comm") + #+allegro (require :socket)) + + +#+sbcl +(defun listen-to-inet-port (&key (port 0) (kind :stream) (reuse nil)) + "Create, bind and listen to an inet socket on *:PORT. +setsockopt SO_REUSEADDR if :reuse is not nil" + (let ((socket (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (if reuse + (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)) + (sb-bsd-sockets:socket-bind + socket (sb-bsd-sockets:make-inet-address "0.0.0.0") port) + (sb-bsd-sockets:socket-listen socket 15) + socket)) + +(defun create-inet-listener (port &key (format :text) (reuse-address t)) + #+cmu (declare (ignore format reuse-address)) + #+cmu (ext:create-inet-listener port) + #+allegro + (socket:make-socket :connect :passive :local-port port :format format + :address-family + (if (stringp port) + :file + (if (or (null port) (integerp port)) + :internet + (error "illegal value for port: ~s" port))) + :reuse-address reuse-address) + #+sbcl (declare (ignore format)) + #+sbcl (listen-to-inet-port :port port :reuse reuse-address) + #+clisp (declare (ignore format reuse-address)) + #+clisp (ext:socket-server port) + #+openmcl + (declare (ignore format)) + #+openmcl + (ccl:make-socket :connect :passive :local-port port + :reuse-address reuse-address) + #-(or allegro clisp cmu sbcl openmcl) + (warn "create-inet-listener not supported on this implementation") + ) + +(defun make-fd-stream (socket &key input output element-type) + #+cmu + (sys:make-fd-stream socket :input input :output output + :element-type element-type) + #+sbcl + (sb-bsd-sockets:socket-make-stream socket :input input :output output + :element-type element-type) + #-(or cmu sbcl) (declare (ignore input output element-type)) + #-(or cmu sbcl) socket + ) + + +(defun accept-tcp-connection (listener) + "Returns (VALUES stream socket)" + #+allegro + (let ((sock (socket:accept-connection listener))) + (values sock sock)) + #+clisp + (let ((sock (ext:socket-accept listener))) + (values sock sock)) + #+cmu + (progn + (mp:process-wait-until-fd-usable listener :input) + (let ((sock (nth-value 0 (ext:accept-tcp-connection listener)))) + (values (sys:make-fd-stream sock :input t :output t) sock))) + #+sbcl + (when (sb-sys:wait-until-fd-usable + (sb-bsd-sockets:socket-file-descriptor listener) :input) + (let ((sock (sb-bsd-sockets:socket-accept listener))) + (values + (sb-bsd-sockets:socket-make-stream + sock :element-type :default :input t :output t) + sock))) + #+openmcl + (let ((sock (ccl:accept-connection listener :wait t))) + (values sock sock)) + #-(or allegro clisp cmu sbcl openmcl) + (warn "accept-tcp-connection not supported on this implementation") + ) + + +(defmacro errorset (form display) + `(handler-case + ,form + (error (e) + (declare (ignorable e)) + (when ,display + (format t "~&Error: ~A~%" e))))) + +(defun close-passive-socket (socket) + #+allegro (close socket) + #+clisp (ext:socket-server-close socket) + #+cmu (unix:unix-close socket) + #+sbcl (sb-unix:unix-close + (sb-bsd-sockets:socket-file-descriptor socket)) + #+openmcl (close socket) + #-(or allegro clisp cmu sbcl openmcl) + (warn "close-passive-socket not supported on this implementation") + ) + + +(defun close-active-socket (socket) + #+sbcl (sb-bsd-sockets:socket-close socket) + #-sbcl (close socket)) + +(defun ipaddr-to-dotted (ipaddr &key values) + "Convert from 32-bit integer to dotted string." + (declare (type (unsigned-byte 32) ipaddr)) + (let ((a (logand #xff (ash ipaddr -24))) + (b (logand #xff (ash ipaddr -16))) + (c (logand #xff (ash ipaddr -8))) + (d (logand #xff ipaddr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun dotted-to-ipaddr (dotted &key (errorp t)) + "Convert from dotted string to 32-bit integer." + (declare (string dotted)) + (if errorp + (let ((ll (delimited-string-to-list dotted #\.))) + (+ (ash (parse-integer (first ll)) 24) + (ash (parse-integer (second ll)) 16) + (ash (parse-integer (third ll)) 8) + (parse-integer (fourth ll)))) + (ignore-errors + (let ((ll (delimited-string-to-list dotted #\.))) + (+ (ash (parse-integer (first ll)) 24) + (ash (parse-integer (second ll)) 16) + (ash (parse-integer (third ll)) 8) + (parse-integer (fourth ll))))))) + +#+sbcl +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in IPADDR-TO-HOSTNAME not supported.")) + (sb-bsd-sockets:host-ent-name + (sb-bsd-sockets:get-host-by-address + (sb-bsd-sockets:make-inet-address ipaddr)))) + +#+sbcl +(defun lookup-hostname (host &key ignore-cache) + (when ignore-cache + (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported.")) + (if (stringp host) + (sb-bsd-sockets:host-ent-address + (sb-bsd-sockets:get-host-by-name host)) + (dotted-to-ipaddr (ipaddr-to-dotted host)))) + + +(defun make-active-socket (server port) + "Returns (VALUES STREAM SOCKET)" + #+allegro + (let ((sock (socket:make-socket :remote-host server + :remote-port port))) + (values sock sock)) + #+lispworks + (let ((sock (comm:open-tcp-stream server port))) + (values sock sock)) + #+sbcl + (let ((sock (make-instance 'sb-bsd-sockets:inet-socket + :type :stream + :protocol :tcp))) + (sb-bsd-sockets:socket-connect sock (lookup-hostname server) port) + (values + (sb-bsd-sockets:socket-make-stream + sock :input t :output t :element-type :default) + sock)) + #+cmu + (let ((sock (ext:connect-to-inet-socket server port))) + (values + (sys:make-fd-stream sock :input t :output t :element-type 'base-char) + sock)) + #+clisp + (let ((sock (ext:socket-connect port server))) + (values sock sock)) + #+openmcl + (let ((sock (ccl:make-socket :remote-host server :remote-port port ))) + (values sock sock)) + ) + +(defun ipaddr-array-to-dotted (array) + (format nil "~{~D~^.~}" (coerce array 'list)) + #+ignore + (format nil "~D.~D.~D.~D" + (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array))) + +(defun remote-host (socket) + #+allegro (socket:ipaddr-to-dotted (socket:remote-host socket)) + #+lispworks (nth-value 0 (comm:get-socket-peer-address socket)) + #+sbcl (ipaddr-array-to-dotted + (nth-value 0 (sb-bsd-sockets:socket-peername socket))) + #+cmu (nth-value 0 (ext:get-peer-host-and-port socket)) + #+clisp (let* ((peer (ext:socket-stream-peer socket t)) + (stop (position #\Space peer))) + ;; 2.37-2.39 had do-not-resolve-p backwards + (if stop (subseq peer 0 stop) peer)) + #+openmcl (ccl:remote-host socket) + ) + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/strings.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,706 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: strings.lisp +;;;; Purpose: Strings utility functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002-2006 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + + +(in-package #:kmrcl) + +;;; Strings + +(defmacro string-append (outputstr &rest args) + `(setq ,outputstr (concatenate 'string ,outputstr ,@args))) + +(defun list-to-string (lst) + "Converts a list to a string, doesn't include any delimiters between elements" + (format nil "~{~A~}" lst)) + +(defun count-string-words (str) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (let ((n-words 0) + (in-word nil)) + (declare (fixnum n-words)) + (do* ((len (length str)) + (i 0 (1+ i))) + ((= i len) n-words) + (declare (fixnum i)) + (if (alphanumericp (schar str i)) + (unless in-word + (incf n-words) + (setq in-word t)) + (setq in-word nil))))) + +;; From Larry Hunter with modifications +(defun position-char (char string start max) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (simple-string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char= char (schar string i)) (return i)))) + +(defun position-not-char (char string start max) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (simple-string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char/= char (schar string i)) (return i)))) + +(defun delimited-string-to-list (string &optional (separator #\space) + skip-terminal) + "split a string with delimiter" + (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)) + (type string string) + (type character separator)) + (do* ((len (length string)) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) + ((null end) + (if (< pos len) + (push (subseq string pos) output) + (when (or (not skip-terminal) (zerop len)) + (push "" output))) + (nreverse output)) + (declare (type fixnum pos len) + (type (or null fixnum) end)) + (push (subseq string pos end) output) + (setq pos (1+ end)))) + + +(defun list-to-delimited-string (list &optional (separator " ")) + (format nil (concatenate 'string "~{~A~^" (string separator) "~}") list)) + +(defun string-invert (str) + "Invert case of a string" + (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0)) + (simple-string str)) + (let ((up nil) (down nil)) + (block skip + (loop for char of-type character across str do + (cond ((upper-case-p char) + (if down (return-from skip str) (setf up t))) + ((lower-case-p char) + (if up (return-from skip str) (setf down t))))) + (if up (string-downcase str) (string-upcase str))))) + +(defun add-sql-quotes (s) + (substitute-string-for-char s #\' "''")) + +(defun escape-backslashes (s) + (substitute-string-for-char s #\\ "\\\\")) + +(defun substitute-string-for-char (procstr match-char subst-str) + "Substitutes a string for a single matching character of a string" + (substitute-chars-strings procstr (list (cons match-char subst-str)))) + +(defun string-substitute (string substring replacement-string) + "String substitute by Larry Hunter. Obtained from Google" + (let ((substring-length (length substring)) + (last-end 0) + (new-string "")) + (do ((next-start + (search substring string) + (search substring string :start2 last-end))) + ((null next-start) + (concatenate 'string new-string (subseq string last-end))) + (setq new-string + (concatenate 'string + new-string + (subseq string last-end next-start) + replacement-string)) + (setq last-end (+ next-start substring-length))))) + +(defun string-trim-last-character (s) + "Return the string less the last character" + (let ((len (length s))) + (if (plusp len) + (subseq s 0 (1- len)) + s))) + +(defun nstring-trim-last-character (s) + "Return the string less the last character" + (let ((len (length s))) + (if (plusp len) + (nsubseq s 0 (1- len)) + s))) + +(defun string-hash (str &optional (bitmask 65535)) + (let ((hash 0)) + (declare (fixnum hash) + (simple-string str)) + (dotimes (i (length str)) + (declare (fixnum i)) + (setq hash (+ hash (char-code (char str i))))) + (logand hash bitmask))) + +(defun is-string-empty (str) + (zerop (length str))) + +(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed + #+allegro #\%space + #+lispworks #\No-Break-Space)) + +(defun is-char-whitespace (c) + (declare (character c) (optimize (speed 3) (safety 0))) + (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) + (char= c #\Linefeed) + #+allegro (char= c #\%space) + #+lispworks (char= c #\No-Break-Space))) + +(defun is-string-whitespace (str) + "Return t if string is all whitespace" + (every #'is-char-whitespace str)) + +(defun string-right-trim-whitespace (str) + (string-right-trim *whitespace-chars* str)) + +(defun string-left-trim-whitespace (str) + (string-left-trim *whitespace-chars* str)) + +(defun string-trim-whitespace (str) + (string-trim *whitespace-chars* str)) + +(defun replaced-string-length (str repl-alist) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((i 0 (1+ i)) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) + (declare (fixnum i orig-len new-len)) + (let* ((c (char str i)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (when match + (incf new-len (1- (length + (the simple-string (cdr match))))))))) + +(defun substitute-chars-strings (str repl-alist) + "Replace all instances of a chars with a string. repl-alist is an assoc +list of characters and replacement strings." + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((orig-len (length str)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) + ((>= spos orig-len) + new-string) + (declare (fixnum spos dpos) (simple-string new-string)) + (let* ((c (char str spos)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (if match + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len) + (simple-string subst)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) + +(defun escape-xml-string (string) + "Escape invalid XML characters" + (substitute-chars-strings string '((#\& . "&") (#\< . "<")))) + +(defun make-usb8-array (len) + (make-array len :element-type '(unsigned-byte 8))) + +(defun usb8-array-to-string (vec &key (start 0) end) + (declare (type (simple-array (unsigned-byte 8) (*)) vec) + (fixnum start)) + (unless end + (setq end (length vec))) + (let* ((len (- end start)) + (str (make-string len))) + (declare (fixnum len) + (simple-string str) + (optimize (speed 3) (safety 0))) + (do ((i 0 (1+ i))) + ((= i len) str) + (declare (fixnum i)) + (setf (schar str i) (code-char (aref vec (the fixnum (+ i start)))))))) + +(defun string-to-usb8-array (str) + (declare (simple-string str)) + (let* ((len (length str)) + (vec (make-usb8-array len))) + (declare (fixnum len) + (type (simple-array (unsigned-byte 8) (*)) vec) + (optimize (speed 3))) + (do ((i 0 (1+ i))) + ((= i len) vec) + (declare (fixnum i)) + (setf (aref vec i) (char-code (schar str i)))))) + +(defun concat-separated-strings (separator &rest lists) + (format nil (concatenate 'string "~{~A~^" (string separator) "~}") + (append-sublists lists))) + +(defun only-null-list-elements-p (lst) + (or (null lst) (every #'null lst))) + +(defun print-separated-strings (strm separator &rest lists) + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) + (compilation-speed 0))) + (do* ((rest-lists lists (cdr rest-lists)) + (list (car rest-lists) (car rest-lists)) + (last-list (only-null-list-elements-p (cdr rest-lists)) + (only-null-list-elements-p (cdr rest-lists)))) + ((null rest-lists) strm) + (do* ((lst list (cdr lst)) + (elem (car lst) (car lst)) + (last-elem (null (cdr lst)) (null (cdr lst)))) + ((null lst)) + (write-string elem strm) + (unless (and last-elem last-list) + (write-string separator strm))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro def-prefixed-number-string (fn-name type &optional doc) + `(defun ,fn-name (num pchar len) + ,@(when (stringp doc) (list doc)) + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum len) + (,type num)) + (when pchar + (incf len)) + (do* ((zero-code (char-code #\0)) + (result (make-string len :initial-element #\0)) + (minus? (minusp num)) + (val (if minus? (- num) num) + (nth-value 0 (floor val 10))) + (pos (1- len) (1- pos)) + (mod (mod val 10) (mod val 10))) + ((or (zerop val) (minusp pos)) + (when pchar + (setf (schar result 0) pchar)) + (when minus? (setf (schar result (if pchar 1 0)) #\-)) + result) + (declare (,type val) + (fixnum mod zero-code pos) + (boolean minus?) + (simple-string result)) + (setf (schar result pos) (code-char (the fixnum (+ zero-code mod)))))))) + +(def-prefixed-number-string prefixed-fixnum-string fixnum + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present. LEN must be a fixnum.") + +(def-prefixed-number-string prefixed-integer-string integer + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present. LEN must be an integer.") + +(defun integer-string (num len) + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present." + (declare (optimize (speed 3) (safety 0) (space 0)) + (type fixnum len) + (type integer num)) + (do* ((zero-code (char-code #\0)) + (result (make-string len :initial-element #\0)) + (minus? (minusp num)) + (val (if minus? (- 0 num) num) + (nth-value 0 (floor val 10))) + (pos (1- len) (1- pos)) + (mod (mod val 10) (mod val 10))) + ((or (zerop val) (minusp pos)) + (when minus? (setf (schar result 0) #\-)) + result) + (declare (fixnum mod zero-code pos) (simple-string result) (integer val)) + (setf (schar result pos) (code-char (+ zero-code mod))))) + +(defun fast-string-search (substr str substr-length startpos endpos) + "Optimized search for a substring in a simple-string" + (declare (simple-string substr str) + (fixnum substr-length startpos endpos) + (optimize (speed 3) (space 0) (safety 0))) + (do* ((pos startpos (1+ pos)) + (lastpos (- endpos substr-length))) + ((> pos lastpos) nil) + (declare (fixnum pos lastpos)) + (do ((i 0 (1+ i))) + ((= i substr-length) + (return-from fast-string-search pos)) + (declare (fixnum i)) + (unless (char= (schar str (+ i pos)) (schar substr i)) + (return nil))))) + +(defun string-delimited-string-to-list (str substr) + "splits a string delimited by substr into a list of strings" + (declare (simple-string str substr) + (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0) + (debug 0))) + (do* ((substr-len (length substr)) + (strlen (length str)) + (output '()) + (pos 0) + (end (fast-string-search substr str substr-len pos strlen) + (fast-string-search substr str substr-len pos strlen))) + ((null end) + (when (< pos strlen) + (push (subseq str pos) output)) + (nreverse output)) + (declare (fixnum strlen substr-len pos) + (type (or fixnum null) end)) + (push (subseq str pos end) output) + (setq pos (+ end substr-len)))) + +(defun string-to-list-skip-delimiter (str &optional (delim #\space)) + "Return a list of strings, delimited by spaces, skipping spaces." + (declare (simple-string str) + (optimize (speed 0) (space 0) (safety 0))) + (do* ((results '()) + (end (length str)) + (i (position-not-char delim str 0 end) + (position-not-char delim str j end)) + (j (when i (position-char delim str i end)) + (when i (position-char delim str i end)))) + ((or (null i) (null j)) + (when (and i (< i end)) + (push (subseq str i end) results)) + (nreverse results)) + (declare (fixnum end) + (type (or fixnum null) i j)) + (push (subseq str i j) results))) + +(defun string-starts-with (start str) + (and (>= (length str) (length start)) + (string-equal start str :end2 (length start)))) + +(defun count-string-char (s c) + "Return a count of the number of times a character appears in a string" + (declare (simple-string s) + (character c) + (optimize (speed 3) (safety 0))) + (do ((len (length s)) + (i 0 (1+ i)) + (count 0)) + ((= i len) count) + (declare (fixnum i len count)) + (when (char= (schar s i) c) + (incf count)))) + +(defun count-string-char-if (pred s) + "Return a count of the number of times a predicate is true +for characters in a string" + (declare (simple-string s) + (type (or function symbol) pred) + (optimize (speed 3) (safety 0) (space 0))) + (do ((len (length s)) + (i 0 (1+ i)) + (count 0)) + ((= i len) count) + (declare (fixnum i len count)) + (when (funcall pred (schar s i)) + (incf count)))) + + +;;; URL Encoding + +(defun non-alphanumericp (ch) + (not (alphanumericp ch))) + +(defvar +hex-chars+ "0123456789ABCDEF") +(declaim (type simple-string +hex-chars+)) + +(defun hexchar (n) + (declare (type (integer 0 15) n)) + (schar +hex-chars+ n)) + +(defconstant* +char-code-lower-a+ (char-code #\a)) +(defconstant* +char-code-upper-a+ (char-code #\A)) +(defconstant* +char-code-0+ (char-code #\0)) +(declaim (type fixnum +char-code-0+ +char-code-upper-a+ + +char-code-0)) + +(defun charhex (ch) + "convert hex character to decimal" + (let ((code (char-code (char-upcase ch)))) + (declare (fixnum ch)) + (if (>= code +char-code-upper-a+) + (+ 10 (- code +char-code-upper-a+)) + (- code +char-code-0+)))) + +(defun binary-sequence-to-hex-string (seq) + (let ((list (etypecase seq + (list seq) + (sequence (map 'list #'identity seq))))) + (string-downcase (format nil "~{~2,'0X~}" list)))) + +(defun encode-uri-string (query) + "Escape non-alphanumeric characters for URI fields" + (declare (simple-string query) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((count (count-string-char-if #'non-alphanumericp query)) + (len (length query)) + (new-len (+ len (* 2 count))) + (str (make-string new-len)) + (spos 0 (1+ spos)) + (dpos 0 (1+ dpos))) + ((= spos len) str) + (declare (fixnum count len new-len spos dpos) + (simple-string str)) + (let ((ch (schar query spos))) + (if (non-alphanumericp ch) + (let ((c (char-code ch))) + (setf (schar str dpos) #\%) + (incf dpos) + (setf (schar str dpos) (hexchar (logand (ash c -4) 15))) + (incf dpos) + (setf (schar str dpos) (hexchar (logand c 15)))) + (setf (schar str dpos) ch))))) + +(defun decode-uri-string (query) + "Unescape non-alphanumeric characters for URI fields" + (declare (simple-string query) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((count (count-string-char query #\%)) + (len (length query)) + (new-len (- len (* 2 count))) + (str (make-string new-len)) + (spos 0 (1+ spos)) + (dpos 0 (1+ dpos))) + ((= spos len) str) + (declare (fixnum count len new-len spos dpos) + (simple-string str)) + (let ((ch (schar query spos))) + (if (char= #\% ch) + (let ((c1 (charhex (schar query (1+ spos)))) + (c2 (charhex (schar query (+ spos 2))))) + (declare (fixnum c1 c2)) + (setf (schar str dpos) + (code-char (logior c2 (ash c1 4)))) + (incf spos 2)) + (setf (schar str dpos) ch))))) + + +(defun uri-query-to-alist (query) + "Converts non-decoded URI query to an alist of settings" + (mapcar (lambda (set) + (let ((lst (kmrcl:delimited-string-to-list set #\=))) + (cons (first lst) (second lst)))) + (kmrcl:delimited-string-to-list + (kmrcl:decode-uri-string query) #\&))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +unambiguous-charset+ + "abcdefghjkmnpqrstuvwxyz123456789ABCDEFGHJKLMNPQSRTUVWXYZ") + (defconstant* +unambiguous-length+ (length +unambiguous-charset+))) + +(defun random-char (&optional (set :lower-alpha)) + (ecase set + (:lower-alpha + (code-char (+ +char-code-lower-a+ (random 26)))) + (:lower-alphanumeric + (let ((n (random 36))) + (if (>= n 26) + (code-char (+ +char-code-0+ (- n 26))) + (code-char (+ +char-code-lower-a+ n))))) + (:upper-alpha + (code-char (+ +char-code-upper-a+ (random 26)))) + (:unambiguous + (schar +unambiguous-charset+ (random +unambiguous-length+))) + (:upper-lower-alpha + (let ((n (random 52))) + (if (>= n 26) + (code-char (+ +char-code-upper-a+ (- n 26))) + (code-char (+ +char-code-lower-a+ n))))))) + + +(defun random-string (&key (length 10) (set :lower-alpha)) + "Returns a random lower-case string." + (declare (optimize (speed 3))) + (let ((s (make-string length))) + (declare (simple-string s)) + (dotimes (i length s) + (setf (schar s i) (random-char set))))) + + +(defun first-char (s) + (declare (simple-string s)) + (when (and (stringp s) (plusp (length s))) + (schar s 0))) + +(defun last-char (s) + (declare (simple-string s)) + (when (stringp s) + (let ((len (length s))) + (when (plusp len)) + (schar s (1- len))))) + +(defun ensure-string (v) + (typecase v + (string v) + (character (string v)) + (symbol (symbol-name v)) + (otherwise (write-to-string v)))) + +(defun string-right-trim-one-char (char str) + (declare (simple-string str)) + (let* ((len (length str)) + (last (1- len))) + (declare (fixnum len last)) + (if (char= char (schar str last)) + (subseq str 0 last) + str))) + + +(defun string-strip-ending (str endings) + (if (stringp endings) + (setq endings (list endings))) + (let ((len (length str))) + (dolist (ending endings str) + (when (and (>= len (length ending)) + (string-equal ending + (subseq str (- len + (length ending))))) + (return-from string-strip-ending + (subseq str 0 (- len (length ending)))))))) + + +(defun string-maybe-shorten (str maxlen) + (string-elide str maxlen :end)) + +(defun string-elide (str maxlen position) + (declare (fixnum maxlen)) + (let ((len (length str))) + (declare (fixnum len)) + (cond + ((<= len maxlen) + str) + ((<= maxlen 3) + "...") + ((eq position :middle) + (multiple-value-bind (mid remain) (truncate maxlen 2) + (let ((end1 (- mid 1)) + (start2 (- len (- mid 2) remain))) + (concatenate 'string (subseq str 0 end1) "..." (subseq str start2))))) + ((or (eq position :end) t) + (concatenate 'string (subseq str 0 (- maxlen 3)) "..."))))) + +(defun shrink-vector (str size) + #+allegro + (excl::.primcall 'sys::shrink-svector str size) + #+cmu + (lisp::shrink-vector str size) + #+lispworks + (system::shrink-vector$vector str size) + #+sbcl + (sb-kernel:shrink-vector str size) + #+scl + (common-lisp::shrink-vector str size) + #-(or allegro cmu lispworks sbcl scl) + (setq str (subseq str 0 size)) + str) + +(defun lex-string (string &key (whitespace '(#\space #\newline))) + "Separates a string at whitespace and returns a list of strings" + (flet ((is-sep (char) (member char whitespace :test #'char=))) + (let ((tokens nil)) + (do* ((token-start + (position-if-not #'is-sep string) + (when token-end + (position-if-not #'is-sep string :start (1+ token-end)))) + (token-end + (when token-start + (position-if #'is-sep string :start token-start)) + (when token-start + (position-if #'is-sep string :start token-start)))) + ((null token-start) (nreverse tokens)) + (push (subseq string token-start token-end) tokens))))) + +(defun split-alphanumeric-string (string) + "Separates a string at any non-alphanumeric chararacter" + (declare (simple-string string) + (optimize (speed 3) (safety 0))) + (flet ((is-sep (char) + (declare (character char)) + (and (non-alphanumericp char) + (not (char= #\_ char))))) + (let ((tokens nil)) + (do* ((token-start + (position-if-not #'is-sep string) + (when token-end + (position-if-not #'is-sep string :start (1+ token-end)))) + (token-end + (when token-start + (position-if #'is-sep string :start token-start)) + (when token-start + (position-if #'is-sep string :start token-start)))) + ((null token-start) (nreverse tokens)) + (push (subseq string token-start token-end) tokens))))) + + +(defun trim-non-alphanumeric (word) + "Strip non-alphanumeric characters from beginning and end of a word." + (declare (simple-string word) + (optimize (speed 3) (safety 0) (space 0))) + (let* ((start 0) + (len (length word)) + (end len)) + (declare (fixnum start end len)) + (do ((done nil)) + ((or done (= start end))) + (if (alphanumericp (schar word start)) + (setq done t) + (incf start))) + (when (> end start) + (do ((done nil)) + ((or done (= start end))) + (if (alphanumericp (schar word (1- end))) + (setq done t) + (decf end)))) + (if (or (plusp start) (/= len end)) + (subseq word start end) + word))) + + +(defun collapse-whitespace (s) + "Convert multiple whitespace characters to a single space character." + (declare (simple-string s) + (optimize (speed 3) (safety 0))) + (with-output-to-string (stream) + (do ((pos 0 (1+ pos)) + (in-white nil) + (len (length s))) + ((= pos len)) + (declare (fixnum pos len)) + (let ((c (schar s pos))) + (declare (character c)) + (cond + ((kl:is-char-whitespace c) + (unless in-white + (write-char #\space stream)) + (setq in-white t)) + (t + (setq in-white nil) + (write-char c stream))))))) + +(defun string->list (string) + (let ((eof (list nil))) + (with-input-from-string (stream string) + (do ((x (read stream nil eof) (read stream nil eof)) + (l nil (cons x l))) + ((eq x eof) (nreverse l)))))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/strmatch.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,80 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; package: kmrcl -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: strings.lisp +;;;; Purpose: Strings utility functions for KMRCL package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +(defun score-multiword-match (s1 s2) + "Score a match between two strings with s1 being reference string. +S1 can be a string or a list or strings/conses" + (let* ((word-list-1 (if (stringp s1) + (split-alphanumeric-string s1) + s1)) + (word-list-2 (split-alphanumeric-string s2)) + (n1 (length word-list-1)) + (n2 (length word-list-2)) + (unmatched n1) + (score 0)) + (declare (fixnum n1 n2 score unmatched)) + (decf score (* 4 (abs (- n1 n2)))) + (dotimes (iword n1) + (declare (fixnum iword)) + (let ((w1 (nth iword word-list-1)) + pos) + (cond + ((consp w1) + (let ((first t)) + (dotimes (i-alt (length w1)) + (setq pos + (position (nth i-alt w1) word-list-2 + :test #'string-equal)) + (when pos + (incf score (- 30 + (if first 0 5) + (abs (- iword pos)))) + (decf unmatched) + (return)) + (setq first nil)))) + ((stringp w1) + (kmrcl:awhen (position w1 word-list-2 + :test #'string-equal) + (incf score (- 30 (abs (- kmrcl::it iword)))) + (decf unmatched)))))) + (decf score (* 4 unmatched)) + score)) + + +(defun multiword-match (s1 s2) + "Matches two multiword strings, ignores case, word position, punctuation" + (let* ((word-list-1 (split-alphanumeric-string s1)) + (word-list-2 (split-alphanumeric-string s2)) + (n1 (length word-list-1)) + (n2 (length word-list-2))) + (when (= n1 n2) + ;; remove each word from word-list-2 as walk word-list-1 + (dolist (w word-list-1) + (let ((p (position w word-list-2 :test #'string-equal))) + (unless p + (return-from multiword-match nil)) + (setf (nth p word-list-2) ""))) + t))) + + + + + Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/symbols.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,147 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: cl-symbols.lisp +;;;; Purpose: Returns all defined Common Lisp symbols +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + +(defun cl-symbols () + (append (cl-variables) (cl-functions))) + +(defun cl-variables () + (let ((vars '())) + (do-symbols (s 'common-lisp) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) 'common-lisp) + (when (and (or (eq status :external) + (eq status :internal)) + (boundp sym)) + (push sym vars)))) + (nreverse vars))) + +(defun cl-functions () + (let ((funcs '())) + (do-symbols (s 'common-lisp) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) 'common-lisp) + (when (and (or (eq status :external) + (eq status :internal)) + (fboundp sym)) + (push sym funcs)))) + (nreverse funcs))) + +;;; Symbol functions + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew :kmrcl-lowercase-reader *features*)) + (when (not (string= (symbol-name '#:a) + (symbol-name '#:A))) + (pushnew :kmrcl-case-sensitive *features*))) + +(defun string-default-case (str) + #+(and (not kmrcl-lowercase-reader)) (string-upcase str) + #+(and kmrcl-lowercase-reader) (string-downcase str)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :kmrcl-lowercase-reader *features*)) + (setq cl:*features* (delete :kmrcl-case-sensitive *features*))) + +(defun concat-symbol-pkg (pkg &rest args) + (declare (dynamic-extent args)) + (flet ((stringify (arg) + (etypecase arg + (string + (string-upcase arg)) + (symbol + (symbol-name arg))))) + (let ((str (apply #'concatenate 'string (mapcar #'stringify args)))) + (nth-value 0 (intern (string-default-case str) + (if pkg pkg *package*)))))) + + +(defun concat-symbol (&rest args) + (apply #'concat-symbol-pkg nil args)) + +(defun ensure-keyword (name) + "Returns keyword for a name" + (etypecase name + (keyword name) + (string (nth-value 0 (intern (string-default-case name) :keyword))) + (symbol (nth-value 0 (intern (symbol-name name) :keyword))))) + +(defun ensure-keyword-upcase (desig) + (nth-value 0 (intern (string-upcase + (symbol-name (ensure-keyword desig))) :keyword))) + +(defun ensure-keyword-default-case (desig) + (nth-value 0 (intern (string-default-case + (symbol-name (ensure-keyword desig))) :keyword))) + +(defun show (&optional (what :variables) (package *package*)) + (ecase what + (:variables (show-variables package)) + (:functions (show-functions package)))) + +(defun show-variables (package) + (do-symbols (s package) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) package) + (when (and (or (eq status :external) + (eq status :internal)) + (boundp sym)) + (format t "~&Symbol ~S~T -> ~S~%" + sym + (symbol-value sym)))))) + +(defun show-functions (package) + (do-symbols (s package) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) package) + (when (and (or (eq status :external) + (eq status :internal)) + (fboundp sym)) + (format t "~&Function ~S~T -> ~S~%" + sym + (symbol-function sym)))))) + +(defun find-test-generic-functions (instance) + "Return a list of symbols for generic functions specialized on the +class of an instance and whose name begins with the string 'test-'" + (let ((res) + (package (symbol-package (class-name (class-of instance))))) + (do-symbols (s package) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) package) + (when (and (or (eq status :external) + (eq status :internal)) + (fboundp sym) + (eq (symbol-package sym) package) + (> (length (symbol-name sym)) 5) + (string-equal "test-" (subseq (symbol-name sym) 0 5)) + (typep (symbol-function sym) 'generic-function) + (plusp + (length + (compute-applicable-methods + (ensure-generic-function sym) + (list instance))))) + (push sym res)))) + (nreverse res))) + +(defun run-tests-for-instance (instance) + (dolist (gf-name(find-test-generic-functions instance)) + (funcall gf-name instance)) + (values)) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/tests.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,493 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: kmrcl-tests -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmrcl-tests.lisp +;;;; Purpose: kmrcl tests file +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; +;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:cl) +(defpackage #:kmrcl-tests + (:use #:kmrcl #:cl #:rtest)) +(in-package #:kmrcl-tests) + +(rem-all-tests) + + +(deftest :str.0 (substitute-chars-strings "" nil) "") +(deftest :str.1 (substitute-chars-strings "abcd" nil) "abcd") +(deftest :str.2 (substitute-chars-strings "abcd" nil) "abcd") +(deftest :str.3 (substitute-chars-strings "abcd" '((#\j . "ef"))) "abcd") +(deftest :str.4 (substitute-chars-strings "abcd" '((#\a . "ef"))) "efbcd") +(deftest :str.5 + (substitute-chars-strings "abcd" '((#\a . "ef") (#\j . "ghi"))) + "efbcd") +(deftest :str.6 + (substitute-chars-strings "abcd" '((#\a . "ef") (#\d . "ghi"))) + "efbcghi") + +(deftest :str.7 (escape-xml-string "") "") +(deftest :str.8 (escape-xml-string "abcd") "abcd") +(deftest :str.9 (escape-xml-string "ab&cd") "ab&cd") +(deftest :str.10 (escape-xml-string "ab&cd<") "ab&cd<") +(deftest :str.12 (string-trim-last-character "") "") +(deftest :str.13 (string-trim-last-character "a") "") +(deftest :str.14 (string-trim-last-character "ab") "a") +(deftest :str.15 (nstring-trim-last-character "") "") +(deftest :str.16 (nstring-trim-last-character "a") "") +(deftest :str.17 (nstring-trim-last-character "ab") "a") + +(deftest :str.18 (delimited-string-to-list "ab|cd|ef" #\|) + ("ab" "cd" "ef")) +(deftest :str.19 (delimited-string-to-list "ab|cd|ef" #\| t) + ("ab" "cd" "ef")) +(deftest :str.20 (delimited-string-to-list "") ("")) +(deftest :str.21 (delimited-string-to-list "" #\space t) ("")) +(deftest :str.22 (delimited-string-to-list "ab") ("ab")) +(deftest :str.23 (delimited-string-to-list "ab" #\space t) ("ab")) +(deftest :str.24 (delimited-string-to-list "ab|" #\|) ("ab" "")) +(deftest :str.25 (delimited-string-to-list "ab|" #\| t) ("ab")) + +(deftest :sdstl.1 (string-delimited-string-to-list "ab|cd|ef" "|a") + ("ab|cd|ef")) +(deftest :sdstl.2 (string-delimited-string-to-list "ab|cd|ef" "|") + ("ab" "cd" "ef")) +(deftest :sdstl.3 (string-delimited-string-to-list "ab|cd|ef" "cd") + ("ab|" "|ef")) +(deftest :sdstl.4 (string-delimited-string-to-list "ab|cd|ef" "ab") + ("" "|cd|ef")) + +(deftest :hexstr.1 (binary-sequence-to-hex-string ()) + "") + +(deftest :hexstr.2 (binary-sequence-to-hex-string #()) + "") + +(deftest :hexstr.3 (binary-sequence-to-hex-string #(165)) + "a5" +) + +(deftest :hexstr.4 (binary-sequence-to-hex-string (list 165)) + "a5") + +(deftest :hexstr.5 (binary-sequence-to-hex-string #(165 86)) + "a556") + +(deftest :apsl.1 (append-sublists '((a b) (c d))) (a b c d)) +(deftest :apsl.2 (append-sublists nil) nil) +(deftest :apsl.3 (append-sublists '((a b))) (a b)) +(deftest :apsl.4 (append-sublists '((a))) (a)) +(deftest :apsl.5 (append-sublists '((a) (b) (c d (e f g)))) (a b c d (e f g))) + +(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil)) + "") + +(deftest :pss.1 + (with-output-to-string (s) (print-separated-strings s "|" '("ab")) ) + "ab") + +(deftest :pss.2 + (with-output-to-string (s) (print-separated-strings s "|" '("ab" "cd"))) + "ab|cd") + +(deftest :pss.3 + (with-output-to-string (s) (print-separated-strings s "|" '("ab" "cd") nil)) + "ab|cd") + +(deftest :pss.4 + (with-output-to-string (s) + (print-separated-strings s "|" '("ab" "cd") nil nil)) + "ab|cd") + +(deftest :pss.5 + (with-output-to-string (s) + (print-separated-strings s "|" '("ab" "cd") nil '("ef") nil)) + "ab|cd|ef") + +(deftest :css.0 (concat-separated-strings "|" nil) "") +(deftest :css.1 (concat-separated-strings "|" nil nil) "") +(deftest :css.2 (concat-separated-strings "|" '("ab")) "ab") +(deftest :css.3 (concat-separated-strings "|" '("ab" "cd")) "ab|cd") +(deftest :css.4 (concat-separated-strings "|" '("ab" "cd") nil) "ab|cd") +(deftest :css.5 (concat-separated-strings "|" '("ab" "cd") nil '("ef")) "ab|cd|ef") + +(deftest :f.1 (map-and-remove-nils #'(lambda (x) (when (oddp x) (* x x))) + '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81)) +(deftest :f.2 (filter #'(lambda (x) (when (oddp x) (* x x))) + '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9)) +(deftest :an.1 (appendnew '(a b c d) '(c c e f)) (a b c d e f)) + + +(deftest :pxml.1 + (xml-tag-contents "tag1" "<tag>Test</tag>") + nil nil nil) + +(deftest :pxml.2 + (xml-tag-contents "tag" "<tag>Test</tag>") + "Test" 15 nil) + +(deftest :pxml.3 + (xml-tag-contents "tag" "<tag >Test</tag>") + "Test" 17 nil) + +(deftest :pxml.4 + (xml-tag-contents "tag" "<tag a=\"b\"></tag>") + "" 17 ("a=\"b\"")) + +(deftest :pxml.5 + (xml-tag-contents "tag" "<tag a=\"b\" >Test</tag>") + "Test" 22 ("a=\"b\"")) + +(deftest :pxml.6 + (xml-tag-contents "tag" "<tag a=\"b\" c=\"ab\">Test</tag>") + "Test" 29 ("a=\"b\"" "c=\"ab\"")) + +(deftest :pxml.7 + (xml-tag-contents "tag" "<taga a=\"b\" c=\"ab\">Test</taga>") + nil nil nil) + +(deftest :pxml.8 + (xml-tag-contents "tag" "<taga a=\"b\" c=\"ab\">Test<tag>ab</tag></taga>") + "ab" 37 nil) + +(deftest :pxml.9 + (xml-tag-contents "tag" "<taga a=\"b\" c=\"ab\">Test<tag>ab</ag></taga>") + nil nil nil) + +(deftest :fss.1 (fast-string-search "" "" 0 0 0) 0) +(deftest :fss.2 (fast-string-search "" "abc" 0 0 2) 0) +(deftest :fss.3 (fast-string-search "abc" "" 3 0 0) nil) +(deftest :fss.4 (fast-string-search "abc" "abcde" 3 0 4) 0) +(deftest :fss.5 (fast-string-search "abc" "012abcde" 3 0 7) 3) +(deftest :fss.6 (fast-string-search "abc" "012abcde" 3 0 7) 3) +(deftest :fss.7 (fast-string-search "abc" "012abcde" 3 3 7) 3) +(deftest :fss.8 (fast-string-search "abc" "012abcde" 3 4 7) nil) +(deftest :fss.9 (fast-string-search "abcde" "012abcde" 5 3 8) 3) +(deftest :fss.9b (cl:search "abcde" "012abcde" :start2 3 :end2 8) 3) +(deftest :fss.10 (fast-string-search "abcde" "012abcde" 5 3 7) nil) +(deftest :fss.10b (cl:search "abcde" "012abcde" :start2 3 :end2 7) nil) + +(deftest :stlsd.1 (string-to-list-skip-delimiter "") ()) +(deftest :stlsd.2 (string-to-list-skip-delimiter "abc") ("abc")) +(deftest :stlsd.3 (string-to-list-skip-delimiter "ab c") ("ab" "c")) +(deftest :stlsd.4 (string-to-list-skip-delimiter "ab c") ("ab" "c")) +(deftest :stlsd.5 (string-to-list-skip-delimiter "ab c") ("ab" "c")) +(deftest :stlsd.6 (string-to-list-skip-delimiter "ab c ") ("ab" "c")) +(deftest :stlsd.7 (string-to-list-skip-delimiter " ab c ") ("ab" "c")) +(deftest :stlsd.8 (string-to-list-skip-delimiter "ab,,c" #\,) ("ab" "c")) +(deftest :stlsd.9 (string-to-list-skip-delimiter "ab,,c,," #\,) ("ab" "c")) +(deftest :stlsd.10 (string-to-list-skip-delimiter " ab") ("ab")) + +(deftest :csc.1 (count-string-char "" #\a) 0) +(deftest :csc.2 (count-string-char "abc" #\d) 0) +(deftest :csc.3 (count-string-char "abc" #\b) 1) +(deftest :csc.4 (count-string-char "abcb" #\b) 2) + +(deftest :duqs.1 (decode-uri-query-string "") "") +(deftest :duqs.2 (decode-uri-query-string "abc") "abc") +(deftest :duqs.3 (decode-uri-query-string "abc+") "abc ") +(deftest :duqs.4 (decode-uri-query-string "abc+d") "abc d") +(deftest :duqs.5 (decode-uri-query-string "abc%20d") "abc d") + +(deftest :sse.1 (string-strip-ending "" nil) "") +(deftest :sse.2 (string-strip-ending "abc" nil) "abc") +(deftest :sse.3 (string-strip-ending "abc" "ab") "abc") +(deftest :sse.4 (string-strip-ending "abc" '("ab")) "abc") +(deftest :sse.5 (string-strip-ending "abcd" '("a" "cd")) "ab") + + +(defun test-color-conversion () + (dotimes (ih 11) + (dotimes (is 11) + (dotimes (iv 11) + (let ((h (* ih 30)) + (s (/ is 10)) + (v (/ iv 10))) + (multiple-value-bind (r g b) (hsv->rgb h s v) + (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b) + (unless (hsv-equal h s v h2 s2 v2) + (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" + (float r) (float g) (float b) + (when (typep h 'number) (float h)) + (when (typep h2 'number) (float h2)) + (float s) (float s2) (float v) (float v2)) + (return-from test-color-conversion nil)))))))) + t) + +(defun test-color-conversion-float-255 () + (dotimes (ih 11) + (dotimes (is 11) + (dotimes (iv 11) + (let ((h (* ih 30)) + (s (/ is 10)) + (v (/ iv 10))) + (multiple-value-bind (r g b) (hsv->rgb h s v) + (setf r (round (* 255 r)) + g (round (* 255 g)) + b (round (* 255 b))) + (multiple-value-bind (h2 s2 v2) (rgb255->hsv255 r g b) + (unless (hsv-similar h s v h2 (/ s2 255) (/ v2 255) + :hue-range 10 :saturation-range .1 + :value-range 1 :black-limit 0 :gray-limit 0) + (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" + r g b + (when (typep h 'number) (float h)) + (when (typep h2 'number) (float h2)) + (float s) (float (/ s2 255)) (float v) (float (/ v2 255))) + (return-from test-color-conversion-float-255 nil)))))))) + t) + +(defun test-color-conversion-255-float () + (dotimes (ih 11) + (dotimes (is 11) + (dotimes (iv 11) + (let ((h (* ih 30)) + (s (/ is 10)) + (v (/ iv 10))) + (multiple-value-bind (r g b) (hsv255->rgb255 h (truncate (* 255 s)) + (truncate (* 255 v))) + (setf r (/ r 255) + g (/ g 255) + b (/ b 255)) + + (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b) + (unless (hsv-similar h s v h2 s2 v2 + :hue-range 10 :saturation-range .1 + :value-range 1 :black-limit 0 :gray-limit 0) + (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%" + r g b + (when (typep h 'number) (float h)) + (when (typep h2 'number) (float h2)) + (float s) (float (/ s2 255)) (float v) (float (/ v2 255))) + (return-from test-color-conversion-255-float nil)))))))) + t) + +(defun test-color-conversion-255 () + (dotimes (ih 11) + (dotimes (is 11) + (dotimes (iv 11) + (let ((h (* ih 30)) + (s (truncate (* 255 (/ is 10)))) + (v (truncate (* 255 (/ iv 10))))) + (multiple-value-bind (r g b) (hsv255->rgb255 h s v) + (multiple-value-bind (h2 s2 v2) (rgb255->hsv255 r g b) + (unless (hsv255-similar h s v h2 s2 v2 :hue-range 10 :saturation-range 5 + :value-range 5 :black-limit 0 :gray-limit 0) + (warn "Colors not equal: ~D ~D ~D |~ + ~3,'0D:~3,'0D ~3,'0D:~3,'0D ~3,'0D:~3,'0D~%" + r g b + h h2 s s2 v v2) + (return-from test-color-conversion-255 nil)))))))) + t) + +(deftest :color.conv (test-color-conversion) t) +(deftest :color.conv.float.255 (test-color-conversion-float-255) t) +(deftest :color.conv.255.float (test-color-conversion-255-float) t) +(deftest :color.conv.255 (test-color-conversion-255) t) + +(deftest :hue.diff.1 (hue-difference 10 10) 0) +(deftest :hue.diff.2 (hue-difference 10 9) -1) +(deftest :hue.diff.3 (hue-difference 9 10) 1) +(deftest :hue.diff.4 (hue-difference 10 nil) 360) +(deftest :hue.diff.5 (hue-difference nil 1) 360) +(deftest :hue.diff.7 (hue-difference 10 190) 180) +(deftest :hue.diff.8 (hue-difference 190 10) -180) +(deftest :hue.diff.9 (hue-difference 1 359) -2) +(deftest :hue.diff.10 (hue-difference 1 182) -179) +(deftest :hue.diff.11 (hue-difference 1 270) -91) + +(deftest :hsv.sim.1 (hsv-similar 100 .5 .5 110 .5 .5 :hue-range 5 + :value-range 0 :saturation-range 0 + :black-limit 0 :gray-limit 0) nil) +(deftest :hsv.sim.2 (hsv-similar 100 .5 .5 110 .5 .5 :hue-range 15 + :value-range 0 :saturation-range 0 + :black-limit 0 :gray-limit 0) t) +(deftest :hsv.sim.3 (hsv-similar 100 .5 .5 110 .5 .6 :hue-range 15 + :value-range .2 :saturation-range 0 + :black-limit 0 :gray-limit 0) t) +(deftest :hsv.sim.4 (hsv-similar 100 .5 .5 110 .5 .8 :hue-range 15 + :value-range 0.2 :saturation-range 0 + :black-limit 0 :gray-limit 0) nil) +(deftest :hsv.sim.5 (hsv-similar 100 .5 .5 110 .6 .6 :hue-range 15 + :value-range 0.2 :saturation-range .2 + :black-limit 0 :gray-limit 0) t) +(deftest :hsv.sim.6 (hsv-similar 100 .5 .5 110 .6 .8 :hue-range 15 + :value-range 0.2 :saturation-range .2 + :black-limit 0 :gray-limit 0) nil) +(deftest :hsv.sim.7 (hsv-similar 100 .5 .05 110 .6 .01 :hue-range 0 + :value-range 0 :saturation-range 0 + :black-limit .1 :gray-limit 0) t) +(deftest :hsv.sim.8 (hsv-similar 100 .01 .5 110 .09 .6 :hue-range 0 + :value-range 0.2 :saturation-range 0 + :black-limit 0 :gray-limit .1) t) +(deftest :hsv.sim.9 (hsv-similar 100 .01 .5 110 .09 .6 :hue-range 0 + :value-range 0.05 :saturation-range 0 + :black-limit 0 :gray-limit .1) nil) + +#+ignore +(progn +(deftest :dst.1 + (is-dst-change-usa-spring-utime + (encode-universal-time 0 0 0 2 4 2000)) t) +(deftest :dst.2 + (is-dst-change-usa-spring-utime + (encode-universal-time 0 0 0 1 4 2000)) nil) +(deftest :dst.3 + (is-dst-change-usa-spring-utime + (encode-universal-time 0 0 0 3 4 2000)) nil) +(deftest :dst.4 + (is-dst-change-usa-fall-utime + (encode-universal-time 0 0 0 31 10 2004)) t) +(deftest :dst.5 + (is-dst-change-usa-fall-utime + (encode-universal-time 0 0 0 30 10 2004)) nil) +(deftest :dst.6 + (is-dst-change-usa-fall-utime + (encode-universal-time 0 0 0 1 11 2000)) nil) +) + + +(deftest :ekdc.1 + (ensure-keyword-default-case (read-from-string "TYPE")) :type) + +(deftest :ekdc.2 + (ensure-keyword-default-case (read-from-string "type")) :type) + + +(deftest :se.1 + (string-elide "A Test string" 10 :end) "A Test ..." ) + +(deftest :se.2 + (string-elide "A Test string" 13 :end) "A Test string") + +(deftest :se.3 + (string-elide "A Test string" 11 :end) "A Test s..." ) + +(deftest :se.4 + (string-elide "A Test string" 2 :middle) "...") + +(deftest :se.5 + (string-elide "A Test string" 11 :middle) "A Te...ring") + +(deftest :se.6 + (string-elide "A Test string" 12 :middle) "A Tes...ring") + +(deftest :url.1 + (make-url "pg") + "pg") + +(deftest :url.2 + (make-url "pg" :anchor "now") + "pg#now") + +(deftest :url.3 + (make-url "pg" :vars '(("a" . "5"))) + "pg?a=5") + +(deftest :url.4 + (make-url "pg" :anchor "then" :vars '(("a" . "5") ("b" . "pi"))) + "pg?a=5&b=pi#then") + +(defclass test-unique () + ((a :initarg :a) + (b :initarg :b))) + + +(deftest :unique.1 + (let ((list (list (make-instance 'test-unique :a 1 :b 1) + (make-instance 'test-unique :a 2 :b 2) + (make-instance 'test-unique :a 3 :b 2)))) + (values + (unique-slot-values list 'a) + (unique-slot-values list 'b))) + (1 2 3) (1 2)) + +(deftest :unique.2 + (unique-slot-values nil 'a) + nil) + +(deftest :nwp.1 + (numbers-within-percentage 1. 1.1 9) + nil) + +(deftest :nwp.2 + (numbers-within-percentage 1. 1.1 11) + t) + +(deftest :pfs.1 (prefixed-fixnum-string 0 #\A 5) "A00000") + +(deftest :pfs.2 (prefixed-fixnum-string 1 #\A 5) "A00001") + +(deftest :pfs.3 (prefixed-fixnum-string 21 #\B 3) "B021") + +(deftest :pis.4 (prefixed-integer-string 234134 #\C 7) "C0234134") + + ;;; MOP Testing + +;; Disable attrib class until understand changes in sbcl/cmucl +;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method +;; for slot access of ALL-ATTRIBUTES. Does this work on Allegro/LW? + +#+ignore +(progn +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-package '#:kmr-mop) + (pushnew :kmrtest-mop cl:*features*))) + +#+kmrtest-mop +(setf (find-class 'monitored-credit-rating) nil) +#+kmrtest-mop +(setf (find-class 'credit-rating) nil) + +#+kmrtest-mop +(defclass credit-rating () + ((level :attributes (date-set time-set)) + (id :attributes (person-setting))) + #+lispworks (:optimize-slot-access nil) + (:metaclass attributes-class)) + + +#+kmrtest-mop +(defclass monitored-credit-rating () + ((level :attributes (last-checked interval date-set)) + (cc :initarg :cc) + (id :attributes (verified))) + (:metaclass attributes-class)) + +#+kmrtest-mop +(deftest :attrib.mop.1 + (let ((cr (make-instance 'credit-rating))) + (slot-attribute cr 'level 'date-set)) + nil) + +#+kmrtest-mop +(deftest :attrib.mop.2 + (let ((cr (make-instance 'credit-rating))) + (setf (slot-attribute cr 'level 'date-set) "12/15/1990") + (let ((result (slot-attribute cr 'level 'date-set))) + (setf (slot-attribute cr 'level 'date-set) nil) + result)) + "12/15/1990") + +#+kmrtest-mop +(deftest :attrib.mop.3 + (let ((mcr (make-instance 'monitored-credit-rating))) + (setf (slot-attribute mcr 'level 'date-set) "01/05/2002") + (let ((result (slot-attribute mcr 'level 'date-set))) + (setf (slot-attribute mcr 'level 'date-set) nil) + result)) + "01/05/2002") + + +#+kmrtest-mop +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :kmrtest-mop cl:*features*))) + +) ;; progn Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/web-utils.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,107 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: web-utils.lisp +;;;; Purpose: Basic web utility functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +;;; HTML/XML constants + +(defvar *standard-xml-header* + #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%")) + +(defvar *standard-html-header* "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">") + +(defvar *standard-xhtml-header* + #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")) + + +;;; User agent functions + +(defun user-agent-ie-p (agent) + "Takes a user-agent string and returns T for Internet Explorer." + (or (string-starts-with "Microsoft" agent) + (string-starts-with "Internet Explore" agent) + (search "Safari" agent) + (search "MSIE" agent))) + +;;; URL Functions + +(defvar *base-url* "") +(defun base-url! (url) + (setq *base-url* url)) + +(defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor) + (let ((amp (case format + (:html + "&") + ((:xml :ie-xml) + "&")))) + (concatenate 'string + base-dir page-name + (if vars + (let ((first-var (first vars))) + (concatenate 'string + "?" (car first-var) "=" (cdr first-var) + (mapcar-append-string + #'(lambda (var) + (when (and (car var) (cdr var)) + (concatenate 'string + amp (string-downcase (car var)) "=" (cdr var)))) + (rest vars)))) + "") + (if anchor + (concatenate 'string "#" anchor) + "")))) + +(defun decode-uri-query-string (s) + "Decode a URI query string field" + (declare (simple-string s) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((old-len (length s)) + (new-len (- old-len (* 2 (the fixnum (count-string-char s #\%))))) + (new (make-string new-len)) + (p-old 0) + (p-new 0 (1+ p-new))) + ((= p-new new-len) new) + (declare (simple-string new) + (fixnum p-old p-new old-len new-len)) + (let ((c (schar s p-old))) + (when (char= c #\+) + (setq c #\space)) + (case c + (#\% + (unless (>= old-len (+ p-old 3)) + (error "#\% not followed by enough characters")) + (setf (schar new p-new) + (code-char + (parse-integer (subseq s (1+ p-old) (+ p-old 3)) + :radix 16))) + (incf p-old 3)) + (t + (setf (schar new p-new) c) + (incf p-old)))))) + +(defun split-uri-query-string (s) + (mapcar + (lambda (pair) + (let ((pos (position #\= pair))) + (when pos + (cons (subseq pair 0 pos) + (when (> (length pair) pos) + (decode-uri-query-string (subseq pair (1+ pos)))))))) + (delimited-string-to-list s #\&))) Added: branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp =================================================================== --- branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp 2007-10-06 21:23:47 UTC (rev 2224) +++ branches/trunk-reorg/thirdparty/kmrcl-1.97/xml-utils.lisp 2007-10-06 21:39:22 UTC (rev 2225) @@ -0,0 +1,176 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: xml-utils.lisp +;;;; Purpose: XML utilities +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; KMRCL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:kmrcl) + + +;;; XML Extraction Functions + +(defun find-start-tag (tag taglen xmlstr start end) + "Searches for the start of a tag in an xmlstring. Returns STARTPOS ATTRIBUTE-LIST)" + (declare (simple-string tag xmlstr) + (fixnum taglen start end) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((search-str (concatenate 'string "<" tag)) + (search-len (1+ taglen)) + (bracketpos (fast-string-search search-str xmlstr search-len start end) + (fast-string-search search-str xmlstr search-len start end))) + ((null bracketpos) nil) + (let* ((endtag (+ bracketpos 1 taglen)) + (char-after-tag (schar xmlstr endtag))) + (when (or (char= #\> char-after-tag) + (char= #\space char-after-tag)) + (if (char= #\> char-after-tag) + (return-from find-start-tag (values (1+ endtag) nil)) + (let ((endbrack (position-char #\> xmlstr (1+ endtag) end))) + (if endbrack + (return-from find-start-tag + (values (1+ endbrack) + (string-to-list-skip-delimiter + (subseq xmlstr endtag endbrack)))) + (values nil nil))))) + (setq start endtag)))) + + +(defun find-end-tag (tag taglen xmlstr start end) + (fast-string-search + (concatenate 'string "</" tag ">") xmlstr + (+ taglen 3) start end)) + +(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) + (end-xmlstr (length xmlstr))) + "Returns three values: the start and end positions of contents between + the xml tags and the position following the close of the end tag." + (let* ((taglen (length tag))) + (multiple-value-bind (start attributes) + (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr) + (unless start + (return-from positions-xml-tag-contents (values nil nil nil nil))) + (let ((end (find-end-tag tag taglen xmlstr start end-xmlstr))) + (unless end + (return-from positions-xml-tag-contents (values nil nil nil nil))) + (values start end (+ end taglen 3) attributes))))) + + +(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0) + (end-xmlstr (length xmlstr))) + "Returns two values: the string between XML start and end tag +and position of character following end tag." + (multiple-value-bind + (startpos endpos nextpos attributes) + (positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr) + (if (and startpos endpos) + (values (subseq xmlstr startpos endpos) nextpos attributes) + (values nil nil nil)))) + +(defun cdata-string (str) + (concatenate 'string "<![CDATA[" str "]]>")) + +(defun write-cdata (str s) + (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0))) + (do ((len (length str)) + (i 0 (1+ i))) + ((= i len) str) + (declare (fixnum i len)) + (let ((c (schar str i))) + (case c + (#\< (write-string "<" s)) + (#\& (write-string "&" s)) + (t (write-char c s)))))) + +(defun xml-declaration-stream (stream &key (version "1.0") standalone encoding) + (format stream "<?xml version=\"~A\"~A~A ?>~%" + version + (if encoding + (format nil " encoding=\"~A\"" encoding) + "" + ) + (if standalone + (format nil " standalone=\"~A\"" standalone) + ""))) + +(defun doctype-stream (stream top-element availability registered organization type + label language url entities) + (format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element + availability (if registered "+" "-") organization type label language) + + (when url + (write-char #\space stream) + (write-char #\" stream) + (write-string url stream) + (write-char #\" stream)) + + (when entities + (format stream " [~%~A~%]" entities)) + + (write-char #\> stream) + (write-char #\newline stream)) + +(defun doctype-format (stream format &key top-element (availability "PUBLIC") + (registered nil) organization (type "DTD") label + (language "EN") url entities) + (case format + ((:xhtml11 :xhtml) + (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language + (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd") + entities)) + (:xhtml10-strict + (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language + (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd") + entities)) + (:xhtml10-transitional + (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language + (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd") + entities)) + (:xhtml-frameset + (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language + (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd") + entities)) + (:html2 + (doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities)) + (:html3 + (doctype-stream stream "HTML" availability registered "IETF" type "HTML 3.0" language url entities)) + (:html3.2 + (doctype-stream stream "HTML" availability registered "W3C" type "HTML 3.2 Final" language url entities)) + ((:html :html4) + (doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities)) + ((:docbook :docbook42) + (doctype-stream stream (if top-element top-element "book") + availability registered "OASIS" type "Docbook XML 4.2" language + (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd") + entities)) + (t + (unless top-element (warn "Missing top-element in doctype-format")) + (unless organization (warn "Missing organization in doctype-format")) + (unless label (warn "Missing label in doctype-format")) + (doctype-stream stream top-element availability registered organization type label language url + entities)))) + + +(defun sgml-header-stream (format stream &key entities (encoding "iso-8859-1") standalone (version "1.0") + top-element (availability "PUBLIC") registered organization (type "DTD") + label (language "EN") url) + (when (in format :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml :docbook) + (xml-declaration-stream stream :version version :encoding encoding :standalone standalone)) + (unless (eq :xml format) + (doctype-format stream format :top-element top-element + :availability availability :registered registered + :organization organization :type type :label label :language language + :url url :entities entities)) + stream) +

1 0

[bknr-cvs] r2224 - branches/trunk-reorg/thirdparty
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 17:23:47 -0400 (Sat, 06 Oct 2007) New Revision: 2224 Removed: branches/trunk-reorg/thirdparty/uffi/ Log: remove uffi, using cffi now

1 0

[bknr-cvs] r2223 - branches/trunk-reorg/thirdparty/asdf
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 17:23:22 -0400 (Sat, 06 Oct 2007) New Revision: 2223 Modified: branches/trunk-reorg/thirdparty/asdf/asdf.lisp Log: Commit patch to make error message for dangling link clear, thanks to antifuchs. Modified: branches/trunk-reorg/thirdparty/asdf/asdf.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/asdf.lisp 2007-10-06 08:49:40 UTC (rev 2222) +++ branches/trunk-reorg/thirdparty/asdf/asdf.lisp 2007-10-06 21:23:22 UTC (rev 2223) @@ -384,6 +384,7 @@ (in-memory (gethash name *defined-systems*)) (on-disk (system-definition-pathname name))) (when (and on-disk + (probe-file on-disk) (or (not in-memory) (< (car in-memory) (file-write-date on-disk)))) (let ((package (make-temporary-package)))

1 0

[bknr-cvs] r2222 - branches/trunk-reorg/projects/eboy
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 04:49:40 -0400 (Sat, 06 Oct 2007) New Revision: 2222 Removed: branches/trunk-reorg/projects/eboy/src.old/ Log: remove cruft

1 0

[bknr-cvs] r2221 - in branches/trunk-reorg/projects/scrabble: src website/de
by bknr＠bknr.net 05 Oct '07

05 Oct '07

Author: hhubner Date: 2007-10-05 03:31:39 -0400 (Fri, 05 Oct 2007) New Revision: 2221 Modified: branches/trunk-reorg/projects/scrabble/src/make-letters.lisp branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/scrabble.lisp branches/trunk-reorg/projects/scrabble/website/de/double-letter.png branches/trunk-reorg/projects/scrabble/website/de/double-word.png branches/trunk-reorg/projects/scrabble/website/de/scrabble.css branches/trunk-reorg/projects/scrabble/website/de/triple-letter.png branches/trunk-reorg/projects/scrabble/website/de/triple-word.png Log: checkpoint Modified: branches/trunk-reorg/projects/scrabble/src/make-letters.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-10-05 06:04:47 UTC (rev 2220) +++ branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-10-05 07:31:39 UTC (rev 2221) @@ -4,16 +4,32 @@ (defparameter *special-tile-texts* (make-hash-table)) (setf (gethash :de *special-tile-texts*) - '(:double-letter "DOPPELTER\nBUCHSTABEN\nWERT" - :double-word "DOPPELTER\nWORT\nWERT" - :triple-letter "DREIFACHER\nBUCHSTABEN\nWERT" - :triple-word "DREIFACHER\nWORT\nWERT")) + '(:double-letter "DOPPELTER +BUCHSTABEN +WERT" + :double-word "DOPPELTER +WORT +WERT" + :triple-letter "DREIFACHER +BUCHSTABEN +WERT" + :triple-word "DREIFACHER +WORT +WERT")) (setf (gethash :en *special-tile-texts*) - '(:double-letter "DOUBLE\nLETTER\nSCORE" - :double-word "DOUBLE\nWORD\nSCORE" - :triple-letter "TRIPLE\nLETTER\nSCORE" - :triple-word "TRIPLE\nWORD\nSCORE")) + '(:double-letter "DOUBLE +LETTER +SCORE" + :double-word "DOUBLE +WORD +SCORE" + :triple-letter "TRIPLE +LETTER +SCORE" + :triple-word "TRIPLE +WORD +SCORE")) (defparameter *special-tile-colors* '(:double-letter (0.53 0.8 0.94) @@ -70,7 +86,11 @@ (cond (text (set-font regular-font 6) - (draw-centered-string 26 3 text)) + (let* ((lines (cl-ppcre:split "\\n" text)) + (position (+ 20 (* 6 (/ 2 (length lines)))))) + (dolist (line lines) + (draw-centered-string 20 position line) + (decf position 6)))) (star )) (save-png (make-pathname :name (string-downcase (symbol-name name)) :type "png"))))) @@ -80,7 +100,8 @@ (make-special-tile tile-name (getf *special-tile-colors* tile-name) :text (getf (gethash language *special-tile-texts*) tile-name))) - (make-special-tile :standard (getf *special-tile-colors* :standard) :star t)) + (make-special-tile :standard (getf *special-tile-colors* :standard) :star nil) + (make-special-tile :standard (getf *special-tile-colors* :double-word) :star t)) (defun make-tile-set (directory language) Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-05 06:04:47 UTC (rev 2220) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-05 07:31:39 UTC (rev 2221) @@ -1,6 +1,6 @@ (defpackage :scrabble - (:use :cl :alexandria :anaphora) + (:use :cl :alexandria :anaphora :bknr.datastore) (:export "*BOARD-SCORING*" "*TILE-SETS*" "FIELD-TYPE")) Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-05 06:04:47 UTC (rev 2220) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-05 07:31:39 UTC (rev 2221) @@ -8,7 +8,7 @@ (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) - (:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word) + (:triple-word nil nil :double-letter nil nil nil :double-word nil nil nil :double-letter nil nil :triple-word) (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) @@ -79,8 +79,9 @@ (or (< (x-of a) (x-of b)) (< (y-of a) (y-of b)))) -(defclass board () - ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil)))) +(defclass board (store-object) + ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil))) + (:metaclass persistent-class)) (defmethod print-object ((board board) stream) (print-unreadable-object (board stream :type t :identity t) @@ -99,9 +100,10 @@ (defmethod put-letter ((board board) tile x y) (setf (aref (placed-tiles-of board) x y) tile)) -(defclass tile () +(defclass tile (store-object) ((char :reader char-of :initarg :char) - (value :reader value-of :initarg :value))) + (value :reader value-of :initarg :value)) + (:metaclass persistent-class)) (defmethod print-object ((tile tile) stream) (print-unreadable-object (tile stream :type t :identity nil) @@ -109,10 +111,11 @@ (format stream "~A (~A)" char value)))) (defun make-tile (char value) - (make-instance 'tile :char char :value value)) + (make-object 'tile :char char :value value)) -(defclass tile-bag () - ((tiles :initarg :tiles :accessor tiles-of))) +(defclass tile-bag (store-object) + ((tiles :initarg :tiles :accessor tiles-of)) + (:metaclass persistent-class)) (defmethod remaining-tile-count ((tile-bag tile-bag)) (fill-pointer (tiles-of tile-bag))) Modified: branches/trunk-reorg/projects/scrabble/website/de/double-letter.png =================================================================== (Binary files differ) Modified: branches/trunk-reorg/projects/scrabble/website/de/double-word.png =================================================================== (Binary files differ) Modified: branches/trunk-reorg/projects/scrabble/website/de/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.css 2007-10-05 06:04:47 UTC (rev 2220) +++ branches/trunk-reorg/projects/scrabble/website/de/scrabble.css 2007-10-05 07:31:39 UTC (rev 2221) @@ -114,7 +114,7 @@ #playfield #field-7-4 { background-image: url(standard.png); left: 308; top: 176 } #playfield #field-7-5 { background-image: url(standard.png); left: 308; top: 220 } #playfield #field-7-6 { background-image: url(standard.png); left: 308; top: 264 } -#playfield #field-7-7 { background-image: url(triple-word.png); left: 308; top: 308 } +#playfield #field-7-7 { background-image: url(double-word.png); left: 308; top: 308 } #playfield #field-7-8 { background-image: url(standard.png); left: 308; top: 352 } #playfield #field-7-9 { background-image: url(standard.png); left: 308; top: 396 } #playfield #field-7-10 { background-image: url(standard.png); left: 308; top: 440 } Modified: branches/trunk-reorg/projects/scrabble/website/de/triple-letter.png =================================================================== (Binary files differ) Modified: branches/trunk-reorg/projects/scrabble/website/de/triple-word.png =================================================================== (Binary files differ)

1 0

[bknr-cvs] r2220 - in branches/trunk-reorg/thirdparty: . salza-png-1.0.1
by bknr＠bknr.net 05 Oct '07

05 Oct '07

Author: hhubner Date: 2007-10-05 02:04:47 -0400 (Fri, 05 Oct 2007) New Revision: 2220 Added: branches/trunk-reorg/thirdparty/salza-png-1.0.1/ branches/trunk-reorg/thirdparty/salza-png-1.0.1/README branches/trunk-reorg/thirdparty/salza-png-1.0.1/png.lisp branches/trunk-reorg/thirdparty/salza-png-1.0.1/salza-png.asd Removed: branches/trunk-reorg/thirdparty/salza-png-1.0/ Log: update salza-png Added: branches/trunk-reorg/thirdparty/salza-png-1.0.1/README =================================================================== --- branches/trunk-reorg/thirdparty/salza-png-1.0.1/README 2007-10-05 06:02:33 UTC (rev 2219) +++ branches/trunk-reorg/thirdparty/salza-png-1.0.1/README 2007-10-05 06:04:47 UTC (rev 2220) @@ -0,0 +1,35 @@ +The salza-png software is a standalone version of the PNG writer from +the salza examples directory. Documentation, such as it is, is at the +start of png.lisp. + +For questions or comments, please contact me, Zach Beane, at +xach(a)xach.com. + +salza-png is offered under the following license: + +;;; +;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Added: branches/trunk-reorg/thirdparty/salza-png-1.0.1/png.lisp =================================================================== --- branches/trunk-reorg/thirdparty/salza-png-1.0.1/png.lisp 2007-10-05 06:02:33 UTC (rev 2219) +++ branches/trunk-reorg/thirdparty/salza-png-1.0.1/png.lisp 2007-10-05 06:04:47 UTC (rev 2220) @@ -0,0 +1,203 @@ +;;; +;;; png.lisp +;;; +;;; Created: 2005-03-14 by Zach Beane <xach(a)xach.com> +;;; +;;; An example use of the salza ZLIB interface functions. +;;; +;;; (setq png (make-instance 'png +;;; :color-type :truecolor +;;; :height 10 +;;; :width 10 +;;; :image-data <300 bytes of image data>)) +;;; +;;; (write-png png "example.png") +;;; +;;; +;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;; +;;; $Id: png.lisp,v 1.2 2007/10/01 13:37:47 xach Exp $ + +(defpackage #:png + (:use #:cl #:salza #:salza-deflate) + (:export #:png + #:write-png + #:write-png-stream)) + +(in-package :png) + + +;;; Chunks + +(defclass chunk () + ((buffer :initarg :buffer :reader buffer) + (pos :initform 4 :accessor pos))) + +(defun chunk-write-byte (byte chunk) + "Save one byte to CHUNK." + (setf (aref (buffer chunk) (pos chunk)) byte) + (incf (pos chunk))) + +(defun chunk-write-uint32 (integer chunk) + "Save INTEGER to CHUNK as four bytes." + (dotimes (i 4) + (setf (aref (buffer chunk) (pos chunk)) + (logand #xFF (ash integer (+ -24 (* i 8))))) + (incf (pos chunk)))) + +(defun make-chunk (a b c d size) + "Make a chunk that uses A, B, C, and D as the signature bytes, with +data size SIZE." + (let ((buffer (make-array (+ size 4) :element-type '(unsigned-byte 8)))) + (setf (aref buffer 0) a + (aref buffer 1) b + (aref buffer 2) c + (aref buffer 3) d) + (make-instance 'chunk + :buffer buffer))) + +(defun write-uint32 (integer stream) + (dotimes (i 4) + (write-byte (logand #xFF (ash integer (+ -24 (* i 8)))) stream))) + +(defun write-chunk (chunk stream) + (write-uint32 (- (pos chunk) 4) stream) + (write-sequence (buffer chunk) stream :end (pos chunk)) + (write-sequence (crc32-sequence (buffer chunk) :end (pos chunk)) stream)) + + +;;; PNGs + +(defclass png () + ((width :initarg :width :reader width) + (height :initarg :height :reader height) + (color-type :initform :truecolor :initarg :color-type :reader color-type) + (bpp :initform 8 :initarg :bpp :reader bpp) + (image-data :initarg :image-data :reader image-data))) + +(defmethod initialize-instance :after ((png png) &rest args) + (declare (ignore args)) + (assert (= (length (image-data png)) + (* (height png) (rowstride png))))) + +(defgeneric write-png (png pathname &key if-exists)) +(defgeneric write-ihdr (png stream)) +(defgeneric ihdr-color-type (png)) +(defgeneric write-idat (png stream)) +(defgeneric write-iend (png stream)) +(defgeneric write-png-header (png stream)) +(defgeneric scanline-offset (png scanline)) +(defgeneric rowstride (png)) +(defgeneric samples/pixel (png)) + +(defmethod samples/pixel (png) + (ecase (color-type png) + (:grayscale 1) + (:truecolor 3) + (:indexed-color 1) + (:grayscale-alpha 2) + (:truecolor-alpha 4))) + + +(defmethod rowstride (png) + (* (width png) (samples/pixel png))) + +(defmethod scanline-offset (png scanline) + (* scanline (rowstride png))) + +(defmethod write-png-header (png stream) + (let ((header (make-array 8 + :element-type '(unsigned-byte 8) + :initial-contents '(137 80 78 71 13 10 26 10)))) + (write-sequence header stream))) + +(defvar *color-types* + '((:grayscale . 0) + (:truecolor . 2) + (:indexed-color . 3) + (:grayscale-alpha . 4) + (:truecolor-alpha . 6))) + +(defmethod ihdr-color-type (png) + (cdr (assoc (color-type png) *color-types*))) + +(defmethod write-ihdr (png stream) + (let ((chunk (make-chunk 73 72 68 82 13))) + (chunk-write-uint32 (width png) chunk) + (chunk-write-uint32 (height png) chunk) + (chunk-write-byte (bpp png) chunk) + (chunk-write-byte (ihdr-color-type png) chunk) + ;; compression method + (chunk-write-byte 0 chunk) + ;; filtering + (chunk-write-byte 0 chunk) + ;; interlace + (chunk-write-byte 0 chunk) + (write-chunk chunk stream))) + +(defmethod write-idat (png stream) + (let* ((chunk (make-chunk 73 68 65 84 16384)) + (filter-type (make-array 1 + :element-type '(unsigned-byte 8) + :initial-element 0))) + (flet ((write-full-chunk (zlib-stream) + (setf (pos chunk) (zlib-stream-position zlib-stream)) + (write-chunk chunk stream) + (fill (buffer chunk) 0 :start 4) + (setf (zlib-stream-position zlib-stream) 4))) + (let ((zlib-stream (make-zlib-stream (buffer chunk) + :start 4 + :callback #'write-full-chunk))) + (dotimes (i (height png)) + (let* ((start-offset (scanline-offset png i)) + (end-offset (+ start-offset (rowstride png)))) + (zlib-write-sequence filter-type zlib-stream) + (zlib-write-sequence (image-data png) zlib-stream + :start start-offset + :end end-offset))) + (finish-zlib-stream zlib-stream))))) + + + +(defmethod write-iend (png stream) + (let ((chunk (make-chunk 73 69 78 68 0))) + (write-chunk chunk stream))) + +(defmethod write-png-stream (png stream) + (write-png-header png stream) + (write-ihdr png stream) + (write-idat png stream) + (write-iend png stream)) + +(defmethod write-png (png file &key (if-exists :supersede)) + (with-open-file (stream file + :direction :output + :if-exists if-exists + :if-does-not-exist :create + :element-type '(unsigned-byte 8)) + (write-png-stream png stream) + (truename file))) Added: branches/trunk-reorg/thirdparty/salza-png-1.0.1/salza-png.asd =================================================================== --- branches/trunk-reorg/thirdparty/salza-png-1.0.1/salza-png.asd 2007-10-05 06:02:33 UTC (rev 2219) +++ branches/trunk-reorg/thirdparty/salza-png-1.0.1/salza-png.asd 2007-10-05 06:04:47 UTC (rev 2220) @@ -0,0 +1,35 @@ +;;; +;;; salza-png.asd +;;; +;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;; +;;; $Id: salza-png.asd,v 1.2 2007/10/01 13:37:29 xach Exp $ + +(asdf:defsystem #:salza-png + :depends-on (#:salza) + :version "1.0.1" + :components ((:file "png")))

1 0