cl-kmrcl-1.109/0000755000175000017500000000000012570446256012255 5ustar kevinkevincl-kmrcl-1.109/ifstar.lisp0000644000175000017500000000461110667175455014445 0ustar kevinkevin;; 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))))) cl-kmrcl-1.109/buff-input.lisp0000644000175000017500000001515211362627540015224 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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))))))) cl-kmrcl-1.109/LICENSE0000644000175000017500000001036610667175455013275 0ustar kevinkevinCopyright (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. cl-kmrcl-1.109/processes.lisp0000644000175000017500000000460512570244006015146 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: processes.lisp ;;;; Purpose: Multiprocessing functions ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: June 2003 ;;;; ************************************************************************* (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) #+ccl (ccl:process-run-function name func) #-(or allegro cmu lispworks sb-thread ccl) (funcall func) ) (defun destroy-process (process) #+cmu (mp:destroy-process process) #+allegro (mp:process-kill process) #+sb-thread (sb-thread:terminate-thread process) #+lispworks (mp:process-kill process) #+ccl (ccl:process-kill process) ) (defun make-lock (name) "Make a named process lock." #+abcl (ext:make-thread-lock) #+allegro (mp:make-process-lock :name name) #+ccl (ccl:make-lock name) #+cmu (mp:make-lock name) #+lispworks (mp:make-lock :name name) #+sb-thread (sb-thread:make-mutex :name name) #-(or lispworks abcl openmcl allegro sb-thread) (declare (ignore name)) #-(or abcl allegro ccl cmu lispworks sb-thread) nil) (defmacro with-lock-held ((lock) &body body) #+abcl `(ext:with-thread-lock (,lock) ,@body) #+allegro `(mp:with-process-lock (,lock) ,@body) #+ccl `(ccl:with-lock-grabbed (,lock) ,@body) #+cmu `(mp:with-lock-held (,lock) ,@body) #+lispworks `(mp:with-lock (,lock) ,@body) #+sb-thread `(sb-thread:with-recursive-lock (,lock) ,@body) #-(or abcl allegro ccl cmu lispworks sb-thread) `(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) #+ccl `(ccl:process-wait-with-timeout "waiting" (* ,seconds ccl:*ticks-per-second*) #'(lambda () ,@body) nil) #-(or allegro cmu sb-thread ccl) `(progn ,@body) ) (defun process-sleep (n) "Put thread to sleep for n seconds." #+allegro (mp:process-sleep n) #-allegro (sleep n)) cl-kmrcl-1.109/datetime.lisp0000644000175000017500000001677711602016323014743 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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 (&optional (ut (get-universal-time))) (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)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +minute-seconds+ 60) (defconstant +hour-seconds+ (* 60 +minute-seconds+)) (defconstant +day-seconds+ (* 24 +hour-seconds+)) (defconstant +week-seconds+ (* +day-seconds+ 7)) (defconstant +month-seconds+ (* +day-seconds+ (/ 365.25 12))) (defconstant +year-seconds+ (* +day-seconds+ 365.25))) (defun seconds-to-condensed-time-string (sec &key (dp-digits 0)) "Prints a quantity of seconds as a condensed string. DP-DIGITS controls how many digits after decimal point." (multiple-value-bind (year yrem) (floor (coerce sec 'double-float) +year-seconds+) (multiple-value-bind (month mrem) (floor yrem +month-seconds+) (multiple-value-bind (week wrem) (floor mrem +week-seconds+) (multiple-value-bind (day drem) (floor wrem +day-seconds+) (multiple-value-bind (hour hrem) (floor drem +hour-seconds+) (multiple-value-bind (minute minrem) (floor hrem +minute-seconds+) (let ((secstr (if (zerop dp-digits) (format nil "~Ds" (round minrem)) (format nil (format nil "~~,~DFs" dp-digits) minrem)))) (cond ((plusp year) (format nil "~Dy~DM~Dw~Dd~Dh~Dm~A" year month week day hour minute secstr)) ((plusp month) (format nil "~DM~Dw~Dd~Dh~Dm~A" month week day hour minute secstr)) ((plusp week) (format nil "~Dw~Dd~Dh~Dm~A" week day hour minute secstr)) ((plusp day) (format nil "~Dd~Dh~Dm~A" day hour minute secstr)) ((plusp hour) (format nil "~Dh~Dm~A" hour minute secstr)) ((plusp minute) (format nil "~Dm~A" minute secstr)) (t secstr)))))))))) (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 cl-kmrcl-1.109/xml-utils.lisp0000644000175000017500000001721212570244606015102 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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 "") 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 "")) (defun write-cdata (str s) (declare (simple-string str) (optimize (speed 3) (safety 0) (space 0))) (unless str (return-from write-cdata nil)) (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 "~%" 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 " 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) cl-kmrcl-1.109/web-utils.lisp0000644000175000017500000000704711362627540015064 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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 "~%")) (defvar *standard-html-header* "") (defvar *standard-xhtml-header* #.(format nil "~%")) ;;; 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 #\&))) cl-kmrcl-1.109/ChangeLog0000644000175000017500000000633012570446246014030 0ustar kevinkevin29 Aug 2015 Kevin Rosenberg * Version 1.109 * byte-stream.lisp: Update function names for SBCL 28 Aug 2015 Kevin Rosenberg * Version 1.107 * processes.lisp: Update name of SBCL function call to terminate-thread. * impl.lisp: Update name of SBCL function call to sb-ext:exit 1 Apr 2011 Kevin Rosenberg * Version 1.104 * listener.lisp: Add support for active sockets in listener 17 Apr 2010 Kevin Rosenberg * Version 1.102 * btree.lisp: New file providing binary tree search for sorted vectors * tests.list: Add tests for binary tree search * mop.lisp: Change pushed cl:*features* to be in KMRCL package, not KEYWORD * attrib-class.lisp: Use new mop *feature* names for reader conditionals * io.lisp: Add def-unsigned-int-io, along with function definitions for binary io of 2 through 8 byte unsigned ints. 22 Mar 2010 Kevin Rosenberg * Version 1.101 * lists.lisp: Reduce memory use by FLATTEN 20 Aug 2009 Kevin Rosenberg * Version 1.100 * lists.lisp: For ECL, exclude function that is incompatible with ECL (Thanks to Daniel Herring) 26 Jul 2009 Kevin Rosenberg * Version 1.99 * impl.lisp: Update SBCL internal call for probe-directory (Thanks to Cyrus Harmon) 28 Jan 2008 Kevin Rosenberg * Version 1.98 * {datetime,strings,tests}.lisp: Add remove-char-string 18 Sep 2007 Kevin Rosenberg * Version 1.97 * datetime.lisp: Improve output format for date-string 10 Sep 2007 Kevin Rosenberg * Version 1.96 * byte-stream.lisp: Use without-package-locks as suggested by Daniel Gackle. 01 Jun 2007 Kevin Rosenberg * Version 1.95 * {datetime,package}.lisp: Add day-of-week and pretty-date-ut 07 Jan 2007 Kevin Rosenberg * Version 1.94 * signals.lisp: Conditionalize Lispworks support to :unix *features* 07 Jan 2007 Kevin Rosenberg * Version 1.93 * signals.lisp: Add new file for signal processing 31 Dec 2006 Kevin Rosenberg * impl.lisp, sockets.lisp, equal.lisp, datetime.lisp: Declare ignored variables 29 Nov 2006 Kevin Rosenberg * Version 1.92 * strings.lisp: Add uri-query-to-alist 24 Oct 2006 Kevin Rosenberg * Version 1.91 * io.lisp: Fix output from read-file-to-string 22 Sep 2006 Kevin Rosenberg * Version 1.90 * sockets.lisp: Commit patch from Joerg Hoehle for CLISP sockets 04 Sep 2006 Kevin Rosenberg * 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 * Version 1.88 * strings.lisp, package.lisp: Add binary-sequence-to-hex-string 26 Jul 2006 Kevin Rosenberg * 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 cl-kmrcl-1.109/hash.lisp0000644000175000017500000000256111602016323014054 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: hash.lisp ;;;; Purpose: Hash functions for KMRCL package ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002-2011 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) ;;; hashs (defun print-hash (h &key (stream *standard-output*) key-transform-fn value-transform-fn (prefix "") (divider " -> ") (terminator "~%")) (maphash #'(lambda (k v) (format stream "~A~S~A~S" prefix (if key-transform-fn (funcall key-transform-fn k) k) divider (if value-transform-fn (funcall value-transform-fn v) v)) (when terminator (format stream terminator))) h) h) cl-kmrcl-1.109/math.lisp0000644000175000017500000000735111362627540014100 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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))) cl-kmrcl-1.109/os.lisp0000644000175000017500000001406311362627540013566 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; ************************************************************************* (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)) #+sbcl (sb-posix:stat-size (sb-posix:stat file)) #-(or allegro sbcl) (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"))) ) cl-kmrcl-1.109/strmatch.lisp0000644000175000017500000000526211362627540014773 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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))) cl-kmrcl-1.109/functions.lisp0000644000175000017500000000337311362627540015157 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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)) cl-kmrcl-1.109/color.lisp0000644000175000017500000002150411362627540014261 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: color.lisp ;;;; Purpose: Functions for color ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Oct 2003 ;;;; ;;;; 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 (* 60 (cond ((= max r) (/ (- g b) delta)) ((= max g) (+ 2 (/ (- b r) delta))) (t (+ 4 (/ (- r g) delta)))))) (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 (round (the fixnum (* 255 delta)) max))) (when (plusp delta) (setq h (cond ((= max r) (round (the fixnum (* 60 (the fixnum (- g b)))) delta)) ((= max g) (the fixnum (+ 120 (round (the fixnum (* 60 (the fixnum (- b r)))) delta)))) (t (the fixnum (+ 240 (round (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))))))) cl-kmrcl-1.109/io.lisp0000644000175000017500000003452311362627540013557 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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))) (defmacro def-unsigned-int-io (len r-name w-name &key (big-endian nil)) "Defines read and write functions for an unsigned integer with LEN bytes from STREAM." (when (< len 1) (error "Number of bytes must be greater than 0.~%")) (let ((endian-string (if big-endian "big" "little"))) `(eval-when (:compile-toplevel :load-toplevel :execute) (defun ,r-name (stream) ,(format nil "Reads an ~A byte unsigned integer (~A-endian)." len endian-string) (declare (optimize (speed 3) (compilation-speed 0) (safety 0) (space 0) (debug 0)) (type stream stream)) (let ((val 0)) (declare (type ,(if (< (expt 256 len) most-positive-fixnum) 'fixnum `(integer 0 ,(1- (expt 256 len)))) val)) ,@(loop for i from 1 upto len collect `(setf (ldb (byte 8 ,(* (if big-endian (1- i) (- len i)) 8)) val) (read-byte stream))) val)) (defun ,w-name (val stream &key (bounds-check t)) ,(format nil "Writes an ~A byte unsigned integer as binary to STREAM (~A-endian)." len endian-string) (declare (optimize (speed 3) (compilation-speed 0) (safety 0) (space 0) (debug 0)) (type stream stream) ,(if (< (expt 256 len) most-positive-fixnum) '(type fixnum val) '(type integer val))) (when bounds-check (when (>= val ,(expt 256 len)) (error "Number ~D is too large to fit in ~D bytes.~%" val ,len)) (when (minusp val) (error "Number ~D can't be written as unsigned integer." val))) (locally (declare (type (integer 0 ,(1- (expt 256 len))) val)) ,@(loop for i from 1 upto len collect `(write-byte (ldb (byte 8 ,(* (if big-endian (1- i) (- len i)) 8)) val) stream))) val) nil))) (defmacro make-unsigned-int-io-fn (len) "Makes reader and writer functions for unsigned byte input/output of LEN bytes with both little and big endian order. Function names are in the form of {READ,WRITE}-UINT-{be,le}." `(progn (def-unsigned-int-io ,len ,(intern (format nil "~A~D-~A" (symbol-name '#:read-uint) len (symbol-name '#:le))) ,(intern (format nil "~A~D-~A" (symbol-name '#:write-uint) len (symbol-name '#:le))) :big-endian nil) (def-unsigned-int-io ,len ,(intern (format nil "~A~D-~A" (symbol-name '#:read-uint) len (symbol-name '#:be))) ,(intern (format nil "~A~D-~A" (symbol-name '#:write-uint) len (symbol-name '#:be))) :big-endian t))) (make-unsigned-int-io-fn 2) (make-unsigned-int-io-fn 3) (make-unsigned-int-io-fn 4) (make-unsigned-int-io-fn 5) (make-unsigned-int-io-fn 6) (make-unsigned-int-io-fn 7) (make-unsigned-int-io-fn 8) cl-kmrcl-1.109/console.lisp0000644000175000017500000000327411362627540014611 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: console.lisp ;;;; Purpose: Console interactiion ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; ;;;; 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)) cl-kmrcl-1.109/run-tests.lisp0000644000175000017500000000143210667175455015117 0ustar kevinkevin(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) cl-kmrcl-1.109/mop.lisp0000644000175000017500000001651211362627540013741 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 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 'kmrcl::sbcl-mop cl:*features*) (pushnew 'kmrcl::sbcl-pcl cl:*features*))) #+cmu (eval-when (:compile-toplevel :load-toplevel :execute) (if (eq (symbol-package 'pcl:find-class) (find-package 'common-lisp)) (pushnew 'kmrcl::cmucl-mop cl:*features*) (pushnew 'kmrcl::cmucl-pcl cl:*features*))) (defpackage #:kmr-mop (:use #:cl #:kmrcl #+kmrcl::sbcl-mop #:sb-mop #+kmrcl::cmucl-mop #:mop #+allegro #:mop #+lispworks #:clos #+clisp #:clos #+scl #:clos #+ccl #: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 '(#+kmrcl::sbcl-mop class-of #-kmrcl::sbcl-mop sb-pcl:class-of #+kmrcl::sbcl-mop class-name #-kmrcl::sbcl-mop sb-pcl:class-name #+kmrcl::sbcl-mop class-slots #-kmrcl::sbcl-mop sb-pcl:class-slots #+kmrcl::sbcl-mop find-class #-kmrcl::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 ) #+ccl '(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 'kmrcl::sbcl-mop cl:*features*)) (setq cl:*features* (delete 'kmrcl::sbcl-pcl cl:*features*))) #+cmu (if (find-package 'mop) (setq cl:*features* (delete 'kmrcl::cmucl-mop cl:*features*)) (setq cl:*features* (delete 'kmrcl::cmucl-pcl cl:*features*))) (when (< (length (generic-function-lambda-list (ensure-generic-function 'compute-effective-slot-definition))) 3) (pushnew 'short-arg-cesd cl:*features*)) (when (< (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew 'short-arg-dsdc cl:*features*)) ) ;; eval-when cl-kmrcl-1.109/impl.lisp0000644000175000017500000001361512570244241014103 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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 (let ((file-kind-fun (or (find-symbol "NATIVE-FILE-KIND" :sb-impl) (find-symbol "UNIX-FILE-KIND" :sb-unix)))) (when (eq :directory (funcall file-kind-fun (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:exit :code (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))))) cl-kmrcl-1.109/seqs.lisp0000644000175000017500000000204411362627540014114 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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)) cl-kmrcl-1.109/lists.lisp0000644000175000017500000001474711577741076014325 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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 (tree) (let ((result '())) (labels ((scan (item) (if (consp item) (map nil #'scan item) (push item result)))) (scan tree)) (nreverse result))) ;;; Keyword functions ;; ECL doesn't allow FOR clauses after UNTIL. #-ecl (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 remove-alist (key alist &key (test #'eql)) "Removes a key from an alist." (remove key alist :test test :key #'car)) (defun delete-alist (key alist &key (test #'eql)) "Deletes a key from an alist." (delete key alist :test test :key #'car)) (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)))))) cl-kmrcl-1.109/symbols.lisp0000644000175000017500000001165111351772466014643 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 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) ;;; Symbol functions (defun cl-symbol-list (test-fn) (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)) (funcall test-fn sym)) (push sym vars)))) (nreverse vars))) (defun cl-variables () (cl-symbol-list #'boundp)) (defun cl-functions () (cl-symbol-list #'fboundp)) (defun cl-symbols () (nconc (cl-variables) (cl-functions))) (eval-when (:compile-toplevel :load-toplevel :execute) (when (char= #\a (schar (symbol-name '#:a) 0)) (pushnew 'kmrcl::kmrcl-lowercase-reader *features*)) (when (not (string= (symbol-name '#:a) (symbol-name '#:A))) (pushnew 'kmrcl::kmrcl-case-sensitive *features*))) (defun string-default-case (str) #+(and (not kmrcl::kmrcl-lowercase-reader)) (string-upcase str) #+(and kmrcl::kmrcl-lowercase-reader) (string-downcase str)) (eval-when (:compile-toplevel :load-toplevel :execute) (setq cl:*features* (delete 'kmrcl::kmrcl-lowercase-reader *features*)) (setq cl:*features* (delete 'kmrcl::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 print-symbols (package test-fn value-fn &optional (stream *standard-output*)) (do-symbols (s package) (multiple-value-bind (sym status) (find-symbol (symbol-name s) package) (when (and (or (eq status :external) (eq status :internal)) (funcall test-fn sym)) (format stream "~&Symbol ~S~T -> ~S~%" sym (funcall value-fn sym)))))) (defun show-variables (&optional (package *package*) (stream *standard-output*)) (print-symbols package 'boundp 'symbol-value stream)) (defun show-functions (&optional (package *package*) (stream *standard-output*)) (print-symbols package 'fboundp 'symbol-function stream)) (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)) cl-kmrcl-1.109/Makefile0000644000175000017500000000115010667175455013717 0ustar kevinkevin.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) cl-kmrcl-1.109/byte-stream.lisp0000644000175000017500000002456512570446156015415 0ustar kevinkevin;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: byte-stream.lisp ;;;; Purpose: Byte array input/output streams ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: June 2003 ;;;; ;;;; 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 AllegroCL, 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 "#" 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 (sb-ext:without-package-locks (defvar *system-copy-fn* (intern "SYSTEM-AREA-UB8-COPY" "SB-KERNEL")) (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-UB8-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 "#" 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 cl-kmrcl-1.109/macros.lisp0000644000175000017500000002260511577741076014443 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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 (form &key (stream *standard-output*) (full nil) (width 80) (downcase t) &environment env) (multiple-value-bind (expanded expanded-p) (funcall (if full #'macroexpand #'macroexpand-1) form env) (write expanded :stream stream :pretty t :right-margin width :case (if downcase :downcase :upcase) :length nil :level nil :circle nil :gensym nil) (fresh-line stream) expanded-p)) (defmacro print-form-and-results (form) (let ((r (gensym "RES-"))) `(let ((r ,form)) (format t "~&~A --> ~S~%" ',form r) r))) ;;; 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 "STOP-"))) `(do ((,var ,start (1+ ,var)) (,gstop ,stop)) ((> ,var ,gstop)) ,@body))) (defmacro with-each-stream-line ((var stream) &body body) (let ((eof (gensym "EOF-")) (eof-value (gensym "EOF-VALUE-")) (strm (gensym "STREAM-"))) `(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 ,(format nil "~A-" s)))) 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))) cl-kmrcl-1.109/kmrcl-tests.asd0000644000175000017500000000147211577741076015226 0ustar kevinkevin;;;; -*- 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") t)) cl-kmrcl-1.109/listener.lisp0000644000175000017500000002613711545400562014773 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: listener.lisp ;;;; Purpose: Listener and worker processes ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Jun 2003 ;;;; ;;;; 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) (socket :initarg :socket :accessor socket :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) (socket worker)) (errorset (close-active-socket (socket worker)) nil) (setf (connection worker) nil) (setf (socket 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 socket name &allow-other-keys) (flet ((do-work () (apply (listener-function listener) connection (function-args listener)))) (unless connection (error "connection not provided to modlisp-worker")) (unless socket (error "socket 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 'socket) socket) (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 socket) t) (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 socket) nil) (setq conn nil socket nil)) (values conn socket))) (defun start-socket-server (listener) (unwind-protect (loop (multiple-value-bind (connection socket) (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 :socket socket :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))))))) cl-kmrcl-1.109/sockets.lisp0000644000175000017500000001670311362627540014623 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: sockets.lisp ;;;; Purpose: Socket functions ;;;; Programmer: Kevin M. Rosenberg with excerpts from portableaserve ;;;; Date Started: Jun 2003 ;;;; ************************************************************************* (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" (declare (ignore kind)) (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) ) cl-kmrcl-1.109/random.lisp0000644000175000017500000000313711362627540014425 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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)))) cl-kmrcl-1.109/README0000644000175000017500000000026012570246522013125 0ustar kevinkevinKMRCL 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.kpe.io/kmrcl/ cl-kmrcl-1.109/btree.lisp0000644000175000017500000001107011362627333014241 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: btree.lisp ;;;; Purpose: Binary tree search function ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2010 ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2010 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 def-string-tricmp (fn simple) "Defines a string tri-valued compare function. Can choose optimized version for simple-string." `(defun ,fn (a b) ,(format nil "Compares two ~Astrings. Returns (VALUES CMP MAX-MATCHED). ~ CMP is -1 if aa. ~ MAX-MATCHED is maximum numbers of letters of A ~ successfully compared." (if simple "simple " "")) (declare ,(if simple '(simple-string a b) '(string a b)) (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0) (space 0))) (let ((alen (length a)) (blen (length b))) (declare (fixnum alen blen)) (dotimes (i alen) (declare (fixnum i)) (when (>= i blen) ;; At this point, A and B have matched, but A has more letters and B does not (return-from ,fn (values 1 i))) (let ((ac (,(if simple 'schar 'char) a i)) (bc (,(if simple 'schar 'char) b i))) (cond ((char-lessp ac bc) (return-from ,fn (values -1 i))) ((char-greaterp ac bc) (return-from ,fn (values 1 i)))))) ;; At this point, A and B are equal up to the length of A (when (= alen blen) (return-from ,fn (values 0 alen))) ;; B is greater than A length, so A is less (values -1 alen)))) (def-string-tricmp string-tricmp nil) (def-string-tricmp simple-string-tricmp t) (defun number-tricmp (a b) "Compares two numbers. Returns -1 if aa." (declare (real a b) (optimize (speed 3) (space 0) (debug 0) (compilation-speed 0))) (cond ((< a b) -1) ((> a b) 1) (t 0))) (defun complex-number-tricmp (a b) "Compares the magnitude of two complex numbers. Returns -1 if aa." (declare (number a b) (optimize (speed 3) (space 0) (debug 0) (compilation-speed 0))) (let ((a-mag2 (+ (* (realpart a) (realpart a)) (* (imagpart a) (imagpart a)))) (b-mag2 (+ (* (realpart b) (realpart b)) (* (imagpart b) (imagpart b))))) (declare (real a-mag2 b-mag2)) (cond ((< a-mag2 b-mag2) -1) ((> a-mag2 b-mag2) 1) (t 0)))) (defun sorted-vector-find (key-val sorted-vector &key test key trace) "Finds index of element in sorted vector using a binary tree search. ~ Order log2(N). Returns (VALUES POS LAST-VALUE LAST-POS COUNT). POS is NIL if not found." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) (compilation-speed 0))) (unless test (setq test (etypecase key-val (simple-string #'simple-string-tricmp) (string #'string-tricmp) (complex #'complex-number-tricmp) (number #'number-tricmp)))) (when (zerop (length sorted-vector)) (return-from sorted-vector-find (values nil nil nil 0))) (do* ((len (length sorted-vector)) (last (1- len)) (pos (floor len 2)) (last-width 0 width) (last2-width last-width last-width) (width (1+ (ceiling pos 2)) (ceiling width 2)) (count 1 (1+ count)) (cur-raw (aref sorted-vector pos) (aref sorted-vector pos)) (cur (if key (funcall key cur-raw) cur-raw) (if key (funcall key cur-raw) cur-raw)) (cmp (funcall test key-val cur) (funcall test key-val cur))) ((or (zerop cmp) (= 1 last2-width)) (when trace (format trace "~A ~A ~A ~A ~A~%" cur pos width last-width cmp)) (values (if (zerop cmp) pos nil) cur-raw pos count)) (declare (fixnum len last pos last-width width count cmp)) (when trace (format trace "~A ~A ~A ~A ~A~%" cur pos width last-width cmp)) (case cmp (-1 ;; str < cur (decf pos width) (when (minusp pos) (setq pos 0))) (1 ;; str > cur (incf pos width) (when (> pos last) (setq pos last)))))) cl-kmrcl-1.109/kmrcl.asd0000644000175000017500000000531511577741076014066 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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 " :maintainer "Kevin M. Rosenberg " :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")) (:file "btree" :depends-on ("macros")) (:file "hash" :depends-on ("macros")) )) (defmethod perform ((o test-op) (c (eql (find-system 'kmrcl)))) (operate 'load-op 'kmrcl-tests) (operate 'test-op 'kmrcl-tests :force t)) cl-kmrcl-1.109/repl.lisp0000644000175000017500000000523511362627540014110 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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))))) cl-kmrcl-1.109/signals.lisp0000644000175000017500000000576611362627540014617 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; 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."))) cl-kmrcl-1.109/docbook.lisp0000644000175000017500000000761610667175455014605 0ustar kevinkevin(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 " " stream) (write-char #\Newline stream) (write-string "" 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 "" 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)) cl-kmrcl-1.109/attrib-class.lisp0000644000175000017500000000766011362627540015542 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10-*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: attrib-class.lisp ;;;; Purpose: Defines metaclass allowing use of attributes on slots ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 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 ccl) (defmethod kmr-mop:validate-superclass ((class attributes-class) (superclass kmr-mop:standard-class)) t) (defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmrcl::normal-dsdc &rest initargs) (declare (ignore initargs)) (kmr-mop:find-class 'attributes-dsd)) (defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmrcl::normal-dsdc &rest initargs) (declare (ignore initargs)) (kmr-mop:find-class 'attributes-esd)) (defmethod kmr-mop:compute-effective-slot-definition ((cl attributes-class) #+kmrcl::normal-cesd name dsds) #+kmrcl::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))) cl-kmrcl-1.109/strings.lisp0000644000175000017500000006111711603647463014644 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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))))) (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 remove-char-string (char str) (declare (character char) (string str)) (do* ((len (length str)) (out (make-string len)) (pos 0 (1+ pos)) (opos 0)) ((= pos len) (subseq out 0 opos)) (declare (fixnum pos opos len) (simple-string out)) (let ((c (char str pos))) (declare (character c)) (when (char/= c char) (setf (schar out opos) c) (incf opos))))) (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)))))) (defun safely-read-from-string (str &rest read-from-string-args) "Read an expression from the string STR, with *READ-EVAL* set to NIL. Any unsafe expressions will be replaced by NIL in the resulting S-Expression." (let ((*read-eval* nil)) (ignore-errors (apply 'read-from-string str read-from-string-args)))) (defun parse-float (f) (let ((*read-default-float-format* 'double-float)) (coerce (safely-read-from-string f) 'double-float))) cl-kmrcl-1.109/package.lisp0000644000175000017500000001611311603647463014542 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 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 #:common-lisp) (: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 #:remove-char-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 #:def-unsigned-int-io #:make-unsigned-int-io-fn #:read-uint2-le #:read-uint2-be #:write-uint2-le #:write-uint2-be #:read-uint3-le #:read-uint3-be #:write-uint3-le #:write-uint3-be #:read-uint4-le #:read-uint4-be #:write-uint4-le #:write-uint4-be #:read-uint5-le #:read-uint5-be #:write-uint5-le #:write-uint5-be #:read-uint6-le #:read-uint6-be #:write-uint6-le #:write-uint6-be #:read-uint7-le #:read-uint7-be #:write-uint7-le #:write-uint7-be #:read-uint8-le #:read-uint8-be #:write-uint8-le #:write-uint8-be ;; 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 #:remove-alist #:delete-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 #:safely-read-from-string #:parse-float ;; 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 #:seconds-to-condensed-time-string ;; 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 ;; btree.lisp #:sorted-vector-find #:string-tricmp #:simple-string-tricmp #:number-tricmp #:complex-number-tricmp ;; mop.lisp #:short-arg-cesd #:short-arg-dsdc ;; hash.lisp #:print-hash )) cl-kmrcl-1.109/equal.lisp0000644000175000017500000001146211362627540014254 0ustar kevinkevin;;;; -*- 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 ;;;; ;;;; 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)))))) cl-kmrcl-1.109/tests.lisp0000644000175000017500000005123411602016323014274 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: kmrcl-tests.lisp ;;;; Purpose: kmrcl tests file ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; ;;;; This file is Copyright (c) 2000-2010 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" "Test") nil nil nil) (deftest :pxml.2 (xml-tag-contents "tag" "Test") "Test" 15 nil) (deftest :pxml.3 (xml-tag-contents "tag" "Test") "Test" 17 nil) (deftest :pxml.4 (xml-tag-contents "tag" "") "" 17 ("a=\"b\"")) (deftest :pxml.5 (xml-tag-contents "tag" "Test") "Test" 22 ("a=\"b\"")) (deftest :pxml.6 (xml-tag-contents "tag" "Test") "Test" 29 ("a=\"b\"" "c=\"ab\"")) (deftest :pxml.7 (xml-tag-contents "tag" "Test") nil nil nil) (deftest :pxml.8 (xml-tag-contents "tag" "Testab") "ab" 37 nil) (deftest :pxml.9 (xml-tag-contents "tag" "Testab") 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") (deftest :rcs.1 (remove-char-string #\space "") "") (deftest :rcs.2 (remove-char-string #\space "a") "a") (deftest :rcs.3 (remove-char-string #\space "ab") "ab") (deftest :rcs.4 (remove-char-string #\space "a b") "ab") (deftest :rcs.5 (remove-char-string #\space " a b") "ab") (deftest :rcs.6 (remove-char-string #\space "a b ") "ab") (deftest :rcs.7 (remove-char-string #\space "a b c ") "abc") (deftest :rcs.8 (remove-char-string #\space "a b c d") "abcd") (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 :sts.1 (seconds-to-condensed-time-string 0) "0s") (deftest :sts.2 (seconds-to-condensed-time-string 60) "1m0s") (deftest :sts.3 (seconds-to-condensed-time-string 65) "1m5s") (deftest :sts.4 (seconds-to-condensed-time-string 3600) "1h0m0s") (deftest :sts.5 (seconds-to-condensed-time-string 36000) "10h0m0s") (deftest :sts.6 (seconds-to-condensed-time-string 86400) "1d0h0m0s") (deftest :sts.7 (seconds-to-condensed-time-string (* 7 86400)) "1w0d0h0m0s") (deftest :sts.8 (seconds-to-condensed-time-string (* 21 86400)) "3w0d0h0m0s") (deftest :sts.9 (seconds-to-condensed-time-string (+ 86400 7200 120 50 (* 21 86400))) "3w1d2h2m50s") (deftest :sts.10 (seconds-to-condensed-time-string (+ .1 86400 7200 120 50 (* 21 86400)) :dp-digits 1) "3w1d2h2m50.1s") (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") ;;; Binary tree search tests (defvar *btree-vector*) (defun init-btree-vector (len) (make-random-state t) (setq *btree-vector* (make-array (list len) :element-type 'fixnum :initial-element 0)) (dotimes (i (length *btree-vector*)) (do ((rand (random most-positive-fixnum) (random most-positive-fixnum))) ((not (find rand *btree-vector* :end i)) (setf (aref *btree-vector* i) rand)))) (setq *btree-vector* (sort *btree-vector* #'<))) (defun test-btree-vector (len) (init-btree-vector len) (dotimes (i (length *btree-vector*) t) (let ((stored (aref *btree-vector* i))) (multiple-value-bind (pos value last-pos count) (sorted-vector-find stored *btree-vector*) (declare (ignore last-pos)) (when (or (not (eql i pos)) (not (eql stored value))) (format t "~&Error: btree value ~D at pos ~D: found ~D at pos ~D [count ~D].~%" stored i value pos count) (return nil)))))) (deftest :btree.1 (dotimes (i 1000 t) (test-btree-vector i)) t) (defun time-btree (&optional (fn #'sorted-vector-find) (return-on-error nil)) (time (let ((total-count 0)) (declare (fixnum total-count)) (dotimes (i (length *btree-vector*) t) (let ((stored (aref *btree-vector* i))) (multiple-value-bind (value pos count) (funcall fn stored *btree-vector*) (incf total-count count) (when (or (/= i pos) (/= stored value)) (format t "~&Error: btree value ~D at pos ~D: found ~D at pos ~D [count ~D].~%" stored i value pos count) (when return-on-error (return-from time-btree nil)))))) (float (/ total-count (length *btree-vector*)))))) ;;; 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