From f49b4a466908d2128bb73ce3cb602c0848d0ab51 Mon Sep 17 00:00:00 2001 From: David Lichteblau Date: Sun, 7 Oct 2007 20:09:56 +0200 Subject: [PATCH] Shrink glisp. * src/glisp/util.lisp: Removed commented-out code. (vector-output-stream and its methods): Removed. (NEQ, TRUE, FALSE, PROMISE, PRINT-PROMISE, FORCE, MAXF, MINF, NCONCF, MAX*, MIN*, SHOW, CURRENT-FUNCTION-NAME, MULTIPLE-VALUE-SOME, SPLIT-BY-IF, SPLIT-BY, SPLIT-BY-MEMBER, SANIFY-STRING, SANIFY-ROD, SPLIT-STRING, STRING-BEGIN-EQUAL, STRING-BEGIN=, MAP-ARRAY, *ALL-TEMPORARY-FILES*, FIND-TEMPORARY-FILE, DELETE-TEMPORARY-FILE, WITH-TEMPORARY-FILE, NOP, WITH-STRUCTURE-SLOTS, COMPILE-FUNCALL, FUNCALL*, MAPC*, VREDUCE*, LREDUCE*, WITH-UNIQUE-NAMES, GSTREAM-AS-STRING, G/HASH-TABLE, G/MAKE-HASH-TABLE, G/HASHGET, RESIZE-HASH-TABLE, G/CLRHASH, +FIXNUM-BITS+, +FIXNUM-MASK+, STIR-HASH-CODES, HASH-SEQUENCE, HASH/STRING-EQUAL, MAKE-STRING-EQUAL-HASH-TABLE, PRIMEP, NEAREST-GREATER-PRIME, GRIND-DOCUMENTATION-STRING, AP): Removed. * src/glisp/package.lisp: Deleted. --- src/glisp/package.lisp | 129 ----- src/glisp/util.lisp | 1466 ++++++++++++------------------------------------ 2 files changed, 364 insertions(+), 1231 deletions(-) delete mode 100644 src/glisp/package.lisp rewrite src/glisp/util.lisp (67%) diff --git a/src/glisp/package.lisp b/src/glisp/package.lisp deleted file mode 100644 index 376ff06..0000000 --- a/src/glisp/package.lisp +++ /dev/null @@ -1,129 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP-TEMP; -*- -;;; --------------------------------------------------------------------------- -;;; Title: Generating a sane DEFPACKAGE for GLISP -;;; Created: 1999-05-25 -;;; Author: Gilbert Baumann -;;; License: MIT style (see below) -;;; --------------------------------------------------------------------------- -;;; (c) copyright 1999,2000 by Gilbert Baumann - -;;; Permission is hereby granted, free of charge, to any person obtaining -;;; a copy of this software and associated documentation files (the -;;; "Software"), to deal in the Software without restriction, including -;;; without limitation the rights to use, copy, modify, merge, publish, -;;; distribute, sublicense, and/or sell copies of the Software, and to -;;; permit persons to whom the Software is furnished to do so, subject to -;;; the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be -;;; included in all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -(in-package :cl-user) - -(defpackage "GLISP" - (:use :cl) - (:export "DEFSUBST" - "G/MAKE-STRING" - "WITH-TIMEOUT" - - ;; util.lisp : - "ALWAYS" - "CL-BYTE-STREAM" - "CL-CHAR-STREAM" - "CL-STREAM" - "COMPOSE" - "CURRY" - "FALSE" - "FORCE" - "G/CLOSE" - "G/FINISH-OUTPUT" - "G/PEEK-CHAR" - "G/READ-BYTE" - "G/READ-BYTE-SEQUENCE" - "G/READ-CHAR" - "G/READ-CHAR-SEQUENCE" - "G/READ-LINE" - "G/READ-LINE*" - "G/UNREAD-BYTE" - "G/UNREAD-CHAR" - "G/WRITE-BYTE" - "G/WRITE-BYTE-SEQUENCE" - "G/WRITE-CHAR" - "G/WRITE-STRING" - "GSTREAM" - "MAP-ARRAY" - "MAPFCAR" - "MAX*" - "MAXF" - "MIN*" - "MINF" - "MULTIPLE-VALUE-OR" - "MULTIPLE-VALUE-SOME" - "NCONCF" - "NEQ" - "PROMISE" - "RCURRY" - "SANIFY-STRING" - "SHOW" - "SPLIT-BY" - "SPLIT-BY-IF" - "SPLIT-BY-MEMBER" - "SPLIT-STRING" - "STRING-BEGIN-EQUAL" - "TRUE" - "UNTIL" - "USE-BYTE-FOR-CHAR-STREAM-FLAVOUR" - "USE-CHAR-FOR-BYTE-STREAM-FLAVOUR" - "WHILE" - "WHITE-SPACE-P" - - "CL-BYTE-STREAM->GSTREAM" - "CL-CHAR-STREAM->GSTREAM" - - "FIND-TEMPORARY-FILE" - "DELETE-TEMPORARY-FILE" - "WITH-TEMPORARY-FILE" - - "SET-EQUAL" - "MAYBE-PARSE-INTEGER" - "NOP" - "WITH-STRUCTURE-SLOTS" - - "COMPILE-FUNCALL" - "FUNCALL*" - "MAPC*" - "VREDUCE*" - "LREDUCE*" - "WITH-UNIQUE-NAMES" - - "G/MAKE-HASH-TABLE" - "G/HASHGET" - "G/CLRHASH" - "STIR-HASH-CODES" - "HASH-SEQUENCE" - "HASH/STRING-EQUAL" - "MAKE-STRING-EQUAL-HASH-TABLE" - - "PRIMEP" - - ;; match.lisp - "DEFINE-MATCH-MACRO" - "IF-MATCH" - "GSTREAM-AS-STRING" - - ;; dep-* - "READ-BYTE-SEQUENCE" - "READ-CHAR-SEQUENCE" - "RUN-UNIX-SHELL-COMMAND" - "GETENV")) - -(defpackage "GLUSER" - (:use "CL" "GLISP")) diff --git a/src/glisp/util.lisp b/src/glisp/util.lisp dissimilarity index 67% index 610ff72..56516de 100644 --- a/src/glisp/util.lisp +++ b/src/glisp/util.lisp @@ -1,1102 +1,364 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*- -;;; --------------------------------------------------------------------------- -;;; Title: Some common utilities for the Closure browser -;;; Created: 1997-12-27 -;;; Author: Gilbert Baumann -;;; License: MIT style (see below) -;;; --------------------------------------------------------------------------- -;;; (c) copyright 1997-1999 by Gilbert Baumann - -;;; Permission is hereby granted, free of charge, to any person obtaining -;;; a copy of this software and associated documentation files (the -;;; "Software"), to deal in the Software without restriction, including -;;; without limitation the rights to use, copy, modify, merge, publish, -;;; distribute, sublicense, and/or sell copies of the Software, and to -;;; permit persons to whom the Software is furnished to do so, subject to -;;; the following conditions: -;;; -;;; The above copyright notice and this permission notice shall be -;;; included in all copies or substantial portions of the Software. -;;; -;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -;; Changes -;; -;; When Who What -;; ---------------------------------------------------------------------------- -;; 1999-08-24 GB = fixed MULTIPLE-VALUE-OR it now takes any number of -;; subforms -;; - -(in-package :GLISP) - -(defun neq (x y) (not (eq x y))) - -(define-compiler-macro neq (x y) - `(not (eq ,x ,y))) - -;;; -------------------------------------------------------------------------------- -;;; Meta functions - -(defun curry (fun &rest args) - #'(lambda (&rest more) - (apply fun (append args more)))) - -(defun rcurry (fun &rest args) - #'(lambda (&rest more) - (apply fun (append more args)))) - -(defun compose (f g) - #'(lambda (&rest args) - (funcall f (apply g args)))) - -(defun always (value) - #'(lambda (&rest args) - (declare (ignore args)) - value)) - -(defun true (&rest x) - (declare (ignore x)) - t) - -(defun false (&rest x) - (declare (ignore x)) - nil) - -;;; -------------------------------------------------------------------------------- -;;; Promises - -(defstruct (promise (:print-function print-promise)) - forced? value fun) - -(defun print-promise (self sink depth) - (declare (ignore depth)) - (if (promise-forced? self) - (format sink "#<~S ~S ~S>" 'promise :forced (promise-value self)) - (format sink "#<~S ~S>" 'promise :lazy))) - -(defmacro promise (form) - `(make-promise :forced? nil :fun #'(lambda () ,form))) - -(defun force (x) - (if (promise-forced? x) - (promise-value x) - (setf (promise-forced? x) t - (promise-value x) (funcall (promise-fun x))))) - -;;; -------------------------------------------------------------------------------- -;;; Some additional f macros - -(define-modify-macro maxf (&rest nums) max) -(define-modify-macro minf (&rest nums) min) -(define-modify-macro nconcf (&rest args) nconc) - -;; Man sollte mal ein generelles f macro definieren, in etwa so -;; (funcallf #'nconc x 10) - -;;; Modifizierte Version von max / min. - -(defun max* (&rest nums) - (reduce (lambda (x y) - (cond ((null x) y) - ((null y) x) - (t (max x y)))) - nums :initial-value nil)) - -(defun min* (&rest nums) - (reduce (lambda (x y) - (cond ((null x) y) - ((null y) x) - (t (min x y)))) - nums :initial-value nil)) - -;;; -------------------------------------------------------------------------------- -;;; Debuging aids - -(defmacro show (&rest exprs) - `(format T "~&** [~S]~{~#[~:; ~] ~A = ~S~}." ',(current-function-name) - (list ,@(mapcan (lambda (x) - (list (let ((*print-case* :downcase)) - (prin1-to-string x)) - x)) - exprs)))) - -#+ALLEGRO -(defun current-function-name () - (car COMPILER::.FUNCTIONS-DEFINED.)) - -#-ALLEGRO -(defun current-function-name () - 'ANONYMOUS) - -;;; -------------------------------------------------------------------------------- -;;; Multiple values - -(defmacro multiple-value-or (&rest xs) - (cond ((null xs) - nil) - ((null (cdr xs)) - (car xs)) - (t - (let ((g (gensym))) - `(LET ((,g (MULTIPLE-VALUE-LIST ,(car xs)))) - (IF (CAR ,g) - (VALUES-LIST ,g) - (MULTIPLE-VALUE-OR ,@(cdr xs)))))))) - -(defun multiple-value-some (predicate &rest sequences) - (values-list - (apply #'some (lambda (&rest args) - (let ((res (multiple-value-list (apply predicate args)))) - (if (car res) - res - nil))) - sequences))) - -;;; -------------------------------------------------------------------------------- -;;; while and until - -(defmacro while (test &body body) - `(until (not ,test) ,@body)) - -(defmacro until (test &body body) - `(do () (,test) ,@body)) - -;;; -------------------------------------------------------------------------------- -;;; Sequences - -(defun split-by-if (predicate seq &key (start 0) (nuke-empty-p nil)) - (let ((p0 (position-if predicate seq :start start))) - (if p0 - (if (and nuke-empty-p (= start p0)) - (split-by-if predicate seq :start (+ p0 1) :nuke-empty-p nuke-empty-p) - (cons (subseq seq start p0) - (split-by-if predicate seq :start (+ p0 1) :nuke-empty-p nuke-empty-p))) - (if (and nuke-empty-p (= start (length seq))) - nil - (list (subseq seq start)))))) - -(defun split-by (item &rest args) - (apply #'split-by-if (curry #'eql item) args)) - -(defun split-by-member (items &rest args) - (apply #'split-by-if (rcurry #'member items) args)) - -;;; -------------------------------------------------------------------------------- -;;; Strings - -(defun white-space-p (ch) - ;;(declare #.cl-user:+optimize-very-fast-trusted+) - (or (eq ch #\Return) - (eq ch #\Newline) - (eq ch #\Space) - (eq ch #\Tab) - (eq ch #\Page))) - -(define-compiler-macro white-space-p (ch) - `(member ,ch '(#\Return #\Newline #\Space #\Tab #\Page)) ) - -(defun sanify-string (string &optional (begin? t) (end? t) - (start 0)) - (let ((i (position-if #'white-space-p string :start start))) - (cond (i - (let ((j (position-if-not #'white-space-p string :start i))) - (if j - (concatenate 'string (subseq string start i) - (if (and (= i start) begin?) "" " ") - (sanify-string string nil end? j)) - (concatenate 'string (subseq string start i) - (if (not end?) " " ""))))) - (t (subseq string start))))) - -(defun sanify-rod (string &optional (begin? t) (end? t) (start 0)) - (let ((i (position-if #'runes:white-space-rune-p string :start start))) - (cond (i - (let ((j (position-if-not #'runes:white-space-rune-p - string - :start i))) - (if j - (concatenate 'runes:rod (subseq string start i) - (if (and (= i start) begin?) '#() '#(32)) - (sanify-rod string nil end? j)) - (concatenate 'runes:rod (subseq string start i) - (if (not end?) '#(32) '#()))))) - (t (subseq string start))))) - -(defun split-string (bag string) - (setq string (string-trim bag string)) - (cond ((= (length string) 0) nil) - (t - (let ((p (position bag string :test #'(lambda (x y) (member y x))))) - (if p - (cons (subseq string 0 p) (split-string bag (subseq string p))) - (list string))) ))) - -(defun string-begin-equal (a b) - "Returns non-NIL if the beginning of 'a' matches 'b'" - (and (>= (length a) (length b)) - (string-equal a b :end1 (length b))) ) - -(defun string-begin= (a b) - "Returns non-NIL if the beginning of 'a' matches 'b'" - (and (>= (length a) (length b)) - (string= a b :end1 (length b))) ) - - -;;; ------------------------------------------------------------------------------------------ -;;; Futures -;;; - -#|| -(defstruct (future (:print-function print-future)) - (read-lock (mp/make-lock)) - (guess-lock (mp/make-lock)) - value) - -(defun print-future (self sink depth) - (if (future-guess-lock self) - (format sink "#<~S unpredicted>" (type-of self)) - (if (and *print-level* (>= depth *print-level*)) - (format sink "#<~S predicted as ...>" (type-of self)) - (format sink "#<~S predicted as ~S>" (type-of self) (future-value self))))) - -(defun future () - (let ((res (make-future))) - (mp/seize-lock (future-guess-lock res)) - res)) - -(defun guess (future) - (mp/with-lock ((future-read-lock future)) - (let ((lock (future-guess-lock future))) - (when lock - (mp/seize-lock lock)) - (future-value future)))) - -(defun predict (future value) - (setf (future-value future) value) - (let ((lock (future-guess-lock future))) - (setf (future-guess-lock future) nil) - (mp/release-lock lock)) - value) - -;;; Future lists - -(defun fcar (x) (car (guess x))) -(defun fcdr (x) (cdr (guess x))) -(defun fnull (x) (null (guess x))) -(defun fendp (x) (endp (guess x))) - -(defmacro doflist ((var list &optional res) &body body) - (let ((q (make-symbol "Q"))) - `(do ((,q ,list (fcdr ,q))) - ((fendp ,q) ,res) - (let ((,var (fcar ,q))) - ,@body)))) - -(defun mapfcar (fun flist) - (cond ((fendp flist) nil) - ((cons (funcall fun (fcar flist)) (mapfcar fun (fcdr flist)))))) - -||# - -;; Example: - -;; (setq f (future)) - -;; Thread 1: -;; (doflist (k f) (print k)) - -;; Thread 2: -;; (setq f (cdr (predict f (cons 'foo (future))))) -;; (setq f (cdr (predict f (cons 'bar (future))))) -;; (predict f nil) -;; - -;;;; ----------------------------------------------------------------------------------------- -;;;; Homebrew stream classes -;;;; - -;; I am really tired of standard Common Lisp streams and thier incompatible implementations. - -;; A gstream is an objects with obeys to the following protocol: - -;; g/read-byte stream &optional (eof-error-p t) eof-value -;; g/unread-byte byte stream -;; g/read-char stream &optional (eof-error-p t) eof-value -;; g/unread-char char stream -;; g/write-char char stream -;; g/write-byte byte stream -;; g/finish-output stream -;; g/close stream &key abort - -;; Additionally the follwing generic functions are implemented based -;; on the above protocol and may be reimplemented for any custom -;; stream class for performance. - -;; g/write-string string stream &key start end -;; g/read-line stream &optional (eof-error-p t) eof-value -;; g/read-line* stream &optional (eof-error-p t) eof-value -;; g/read-byte-sequence sequence stream &key start end -;; g/read-char-sequence sequence stream &key start end -;; g/write-byte-sequence sequence stream &key start end -;; g/write-char-sequence sequence stream &key start end - - -;; The following classes exists - -;; gstream -;; use-char-for-byte-stream-flavour -;; use-byte-for-char-stream-flavour -;; cl-stream -;; cl-byte-stream -;; cl-char-stream - -(defclass gstream () ()) - -;;; use-char-for-byte-stream-flavour - -(defclass use-char-for-byte-stream-flavour () ()) - -(defmethod g/read-byte ((self use-char-for-byte-stream-flavour) &optional (eof-error-p t) eof-value) - (let ((r (g/read-char self eof-error-p :eof))) - (if (eq r :eof) - eof-value - (char-code r)))) - -(defmethod g/unread-byte (byte (self use-char-for-byte-stream-flavour)) - (g/unread-char (or (and #+CMU (<= byte char-code-limit) (code-char byte)) - (error "Cannot stuff ~D. into a character." byte)) - self)) - -(defmethod g/write-byte (byte (self use-char-for-byte-stream-flavour)) - (g/write-char (or (and #+CMU (<= byte char-code-limit) (code-char byte)) - (error "Cannot stuff ~D. into a character." byte)) - self)) - -;;; use-byte-for-char-stream-flavour - -(defclass use-byte-for-char-stream-flavour () ()) - -(defmethod g/read-char ((self use-byte-for-char-stream-flavour) &optional (eof-error-p t) eof-value) - (let ((byte (g/read-byte self eof-error-p :eof))) - (if (eq byte :eof) - eof-value - (let ((res (and #+CMU (<= byte char-code-limit) (code-char byte)))) - (or res - (error "The byte ~D. could not been represented as character in your LISP implementation." byte)))))) - -(defmethod g/unread-char (char (self use-byte-for-char-stream-flavour)) - (g/unread-byte (char-code char) self)) - -(defmethod g/write-char (char (self use-byte-for-char-stream-flavour)) - (g/write-byte (char-code char) self)) - -;;; ------------------------------------------------------------ -;;; Streams made up out of Common Lisp streams - -;;; cl-stream - -(defclass cl-stream (gstream) - ((cl-stream :initarg :cl-stream))) - -(defmethod g/finish-output ((self cl-stream)) - (with-slots (cl-stream) self - (finish-output cl-stream))) - -(defmethod g/close ((self cl-stream) &key abort) - (with-slots (cl-stream) self - (close cl-stream :abort abort))) - -;;; cl-byte-stream - -(defclass cl-byte-stream (use-byte-for-char-stream-flavour cl-stream) - ((lookahead :initform nil))) - -(defmethod g/read-byte ((self cl-byte-stream) &optional (eof-error-p t) eof-value) - (with-slots (cl-stream lookahead) self - (if lookahead - (prog1 lookahead - (setf lookahead nil)) - (read-byte cl-stream eof-error-p eof-value)))) - -(defmethod g/unread-byte (byte (self cl-byte-stream)) - (with-slots (cl-stream lookahead) self - (if lookahead - (error "You cannot unread twice.") - (setf lookahead byte)))) - -(defmethod g/write-byte (byte (self cl-byte-stream)) - (with-slots (cl-stream) self - (write-byte byte cl-stream))) - -(defmethod g/read-byte-sequence (sequence (input cl-byte-stream) &key (start 0) (end (length sequence))) - (with-slots (cl-stream) input - (read-sequence sequence cl-stream :start start :end end))) - -(defmethod g/write-byte-sequence (sequence (sink cl-byte-stream) &key (start 0) (end (length sequence))) - (with-slots (cl-stream) sink - (cl:write-sequence sequence cl-stream :start start :end end))) - -;;; cl-char-stream - -(defclass cl-char-stream (use-char-for-byte-stream-flavour cl-stream) - ()) - -(defmethod g/read-char ((self cl-char-stream) &optional (eof-error-p t) eof-value) - (with-slots (cl-stream) self - (read-char cl-stream eof-error-p eof-value))) - -(defmethod g/unread-char (char (self cl-char-stream)) - (with-slots (cl-stream) self - (unread-char char cl-stream))) - -(defmethod g/write-char (char (self cl-char-stream)) - (with-slots (cl-stream) self - (write-char char cl-stream))) - -;;; ------------------------------------------------------------ -;;; General or fall back stream methods - -(defmethod g/write-string (string (stream t) &key (start 0) (end (length string))) - (do ((i start (+ i 1))) - ((>= i end)) - (g/write-char (char string i) stream))) - -(defmethod g/read-line ((stream t) &optional (eof-error-p t) eof-value) - (let ((res nil)) - (do ((c (g/read-char stream eof-error-p :eof) - (g/read-char stream nil :eof))) - ((or (eq c :eof) (char= c #\newline)) - (cond ((eq c :eof) - (values (if (null res) eof-value (coerce (nreverse res) 'string)) - t)) - (t - (values (coerce (nreverse res) 'string) - nil)))) - (push c res)))) - -(defmethod g/read-line* ((stream t) &optional (eof-error-p t) eof-value) - ;; Like read-line, but accepts CRNL, NL, CR as line termination - (let ((res nil)) - (do ((c (g/read-char stream eof-error-p :eof) - (g/read-char stream nil :eof))) - ((or (eq c :eof) (char= c #\newline) (char= c #\return)) - (cond ((eq c :eof) - (values (if (null res) eof-value (coerce (nreverse res) 'string)) - t)) - (t - (when (char= c #\return) - (let ((d (g/read-char stream nil :eof))) - (unless (or (eq d :eof) (char= d #\newline)) - (g/unread-char d stream)))) - (values (coerce (nreverse res) 'string) - nil)))) - (push c res)))) - -(defmethod g/read-byte-sequence (sequence (input t) &key (start 0) (end (length sequence))) - (let ((i start) c) - (loop - (when (>= i end) - (return i)) - (setf c (g/read-byte input nil :eof)) - (when (eq c :eof) - (return i)) - (setf (elt sequence i) c) - (incf i)))) - -(defmethod g/read-char-sequence (sequence (input t) &key (start 0) (end (length sequence))) - (let ((i start) c) - (loop - (when (>= i end) - (return i)) - (setf c (g/read-char input nil :eof)) - (when (eq c :eof) - (return i)) - (setf (elt sequence i) c) - (incf i)))) - -(defmethod g/write-byte-sequence (sequence (sink t) &key (start 0) (end (length sequence))) - (do ((i start (+ i 1))) - ((>= i end) i) - (g/write-byte (aref sequence i) sink))) - -;;; ---------------------------------------------------------------------------------------------------- -;;; Vector streams -;;; - -;; Output - -(defclass vector-output-stream (use-byte-for-char-stream-flavour) - ((buffer :initarg :buffer))) - -(defun g/make-vector-output-stream (&key (initial-size 100)) - (make-instance 'vector-output-stream - :buffer (make-array initial-size :element-type '(unsigned-byte 8) - :fill-pointer 0 - :adjustable t))) - -(defmethod g/close ((self vector-output-stream) &key abort) - (declare (ignorable self abort)) - nil) - -(defmethod g/finish-output ((self vector-output-stream)) - nil) - -(defmethod g/write-byte (byte (self vector-output-stream)) - (with-slots (buffer) self - (vector-push-extend byte buffer 100))) - -(defmethod g/write-byte-sequence (sequence (self vector-output-stream) &key (start 0) (end (length sequence))) - (with-slots (buffer) self - (adjust-array buffer (+ (length buffer) (- end start))) - (replace buffer sequence :start1 (length buffer) :start2 start :end2 end) - (setf (fill-pointer buffer) (+ (length buffer) (- end start))) - end)) - -;;; ---------------------------------------------------------------------------------------------------- -;;; Echo streams - -#|| -(defclass echo-stream (use-byte-for-char-stream-flavour) - ((echoed-to :initarg :echoed-to))) - -(defun g/make-echo-stream (echoed-to) - (make-instance 'echo-stream :echoed-to echoed-to)) -||# - -#|| - -Hmm unter PCL geht das nicht ;-( - -(defmethod g/read-byte ((stream stream) &optional (eof-error-p t) eof-value) - (read-byte stream eof-error-p eof-value)) - -(defmethod g/read-char ((stream stream) &optional (eof-error-p t) eof-value) - (read-char stream eof-error-p eof-value)) - -(defmethod g/unread-char (char (stream stream)) - (unread-char char stream)) - -(defmethod g/write-char (char (stream stream)) - (write-char char stream)) - -(defmethod g/write-byte (byte (stream stream)) - (write-byte byte stream)) - -(defmethod g/finish-output ((stream stream)) - (finish-output stream)) - -(defmethod g/close ((stream stream) &key abort) - (close stream :abort abort)) - -||# - -;;;; ---------------------------------------------------------------------------------------------------- - -#|| -(let ((null (make-symbol "NULL"))) - - (defstruct (future (:print-function print-future)) - (value null) - (awaited-by nil)) - - (defun print-future (self sink depth) - (if (eq (future-value self) null) - (format sink "#<~S unpredicted>" (type-of self)) - (if (and *print-level* (>= depth *print-level*)) - (format sink "#<~S predicted as ...>" (type-of self)) - (format sink "#<~S predicted as ~S>" (type-of self) (future-value self))))) - - (defun future () - (make-future)) - - (defun guess (future) - (when (eq (future-value future) null) - (setf (future-awaited-by future) (mp/current-process)) - (mp/process-wait "Awaiting future" (lambda () (not (eq (future-value future) null)))) - (setf (future-awaited-by future) nil)) - (future-value future)) - - (defun predict (future value) - (setf (future-value future) value) - (let ((aw (future-awaited-by future))) - (when aw (mp/process-allow-schedule aw))) - value) - ) -||# - -(defun map-array (fun array &rest make-array-options) - (let ((res (apply #'make-array (array-dimensions array) make-array-options))) - (dotimes (i (array-total-size array)) - (setf (row-major-aref res i) (funcall fun (row-major-aref array i)))) - res)) - -;;---------------------------------------------------------------------------------------------------- - -(defun g/peek-char (&optional (peek-type nil) (source *standard-input*) - (eof-error-p T) eof-value) - (cond ((eq peek-type T) - (do ((ch (g/read-char source eof-error-p '%the-eof-object%) - (g/read-char source eof-error-p '%the-eof-object%))) - ((or (eq ch '%the-eof-object%) - (not (white-space-p ch))) - (cond ((eq ch '%the-eof-object%) eof-value) - (t (g/unread-char ch source) ch)) ))) - ((eq peek-type NIL) - (let ((ch (g/read-char source eof-error-p '%the-eof-object%))) - (cond ((eq ch '%the-eof-object%) eof-value) - (t (g/unread-char ch source) - ch)))) - ((characterp peek-type) - (do ((ch (g/read-char source eof-error-p '%the-eof-object%) - (g/read-char source eof-error-p '%the-eof-object%))) - ((or (eq ch '%the-eof-object%) (eql ch peek-type)) - (cond ((eq ch '%the-eof-object%) eof-value) - (t (g/unread-char ch source) ch)) )) ) )) - - - -(defun cl-byte-stream->gstream (stream) - (make-instance 'cl-byte-stream :cl-stream stream)) - -(defun cl-char-stream->gstream (stream) - (make-instance 'cl-char-stream :cl-stream stream)) - -;;; ---------------------------------------------------------------------------------------------------- - -(defvar *all-temporary-files* nil - "List of all temporary files.") - -(defun find-temporary-file (&key (type nil)) - (let ((temp-dir "/tmp/*") ;since Motif is only available on unix, we subtly assume a unix host. - (stream nil)) - (labels ((invent-name () - (merge-pathnames (make-pathname - :type type - :name - (let ((*print-base* 35)) - (format nil "ws_~S" (random (expt 36 7))))) - temp-dir))) - (unwind-protect - (do ((name (invent-name) (invent-name))) - ((setq stream (open name :direction :output :if-exists nil)) - (push name *all-temporary-files*) ;remember this file - name)) - (when stream - (close stream)) )))) - -(defun delete-temporary-file (filename) - (setf *all-temporary-files* (delete filename *all-temporary-files*)) - (ignore-errors (delete-file filename))) - -(defmacro with-temporary-file ((name-var &key type) &body body) - (let ((name (gensym))) - `(let* ((,name (find-temporary-file :type ,type)) - (,name-var ,name)) - (unwind-protect - (progn ,@body) - (when (open ,name :direction :probe) - (delete-temporary-file ,name)))) )) - -;;;; - -(defun set-equal (x y &rest options) - (null (apply #'set-exclusive-or x y options))) - -;;;; - -(defun maybe-parse-integer (string &key (radix 10)) - (cond ((not (stringp string)) nil) - (t - (let ((len (length string))) - (cond ((= len 0) nil) - (t - (let ((start 0) - (vz +1) - (res 0)) - (cond ((and (> len 1) (char= (char string 0) #\+)) - (incf start)) - ((and (> len 1) (char= (char string 0) #\-)) - (setf vz -1) - (incf start))) - (do ((i start (+ i 1))) - ((= i len) (* vz res)) - (let ((d (digit-char-p (char string i) radix))) - (if d - (setf res (+ (* radix res) d)) - (return nil))))))))))) - -;;; - -(defun nop (&rest ignore) - (declare (ignore ignore)) - nil) - -(defmacro with-structure-slots ((type &rest slots) obj &body body) - ;; Something like 'with-slots' but for structures. Assumes that the structure - ;; slot accessors have the default name. Note that the structure type must - ;; been provided. - (let ((obj-var (make-symbol "OBJ"))) - `(LET ((,obj-var ,obj)) - (SYMBOL-MACROLET ,(mapcar (lambda (slot) - (list slot - `(,(intern (concatenate 'string (symbol-name type) "-" (symbol-name slot)) - (symbol-package type)) - ,obj-var))) - slots) - ,@body)))) - -;;;; ---------------------------------------------------------------------------------------------------- - -;; Wir helfen den Compiler mal etwas auf die Spruenge ... -(defun compile-funcall (fn args) - (cond ((eq fn '#'identity) - (car args)) - ((eq fn '#'nop) - `(progn ,args nil)) - ((and (consp fn) (eq (car fn) 'function)) - `(,(cadr fn) .,args)) - ((and (consp fn) (eq (car fn) 'lambda)) - `(,fn .,args)) - ((and (consp fn) (eq (car fn) 'curry)) - (compile-funcall (cadr fn) (append (cddr fn) args))) - ((and (consp fn) (eq (car fn) 'rcurry)) - (compile-funcall (cadr fn) (append args (cddr fn)))) - (t - (warn "Unable to inline funcall to ~S." fn) - `(funcall ,fn .,args)) )) - -(defmacro funcall* (fn &rest args) - (compile-funcall fn args)) - -;; Ich mag mapc viel lieber als dolist, nur viele Compiler optimieren -;; das nicht, deswegen das Macro hier. Einige Compiler haben auch kein -;; DEFINE-COMPILER-MACRO :-( - -(defmacro mapc* (fn list) - (let ((g (gensym))) - `(dolist (,g ,list) - ,(compile-funcall fn (list g))))) - -;; Das gleiche mit REDUCE und MAPCAR. - -;; REDUCE arbeitet sowohl fuer Vectoren als auch fuer Listen. Wir -;; haben allerdings leider keinen vernuenftigen Zugriff auf -;; Deklarationen; Man koennte mit TYPEP herangehen und hoffen, dass -;; der Compiler das optimiert, ich fuerchte aber dass das nicht -;; funktionieren wird. Und CLISP verwirft Deklarationen ja total. Also -;; zwei Versionen: LREDUCE* und VREDUCE* - -(defmacro vreduce* (fun seq &rest rest &key (key '#'identity) from-end start end - (initial-value nil initial-value?)) - (declare (ignore rest)) - (let (($start (make-symbol "start")) - ($end (make-symbol "end")) - ($i (make-symbol "i")) - ($accu (make-symbol "accu")) - ($seq (make-symbol "seq"))) - (cond (from-end - (cond (initial-value? - `(LET* ((,$seq ,seq) - (,$start ,(or start 0)) - (,$end ,(or end `(LENGTH ,$seq))) - (,$accu ,initial-value)) - (DECLARE (TYPE FIXNUM ,$start ,$end)) - (DO ((,$i (- ,$end 1) (THE FIXNUM (- ,$i 1)))) - ((< ,$i ,$start) ,$accu) - (DECLARE (TYPE FIXNUM ,$i)) - (SETF ,$accu (FUNCALL* ,fun (FUNCALL* ,key (AREF ,$seq ,$i)) ,$accu)) ))) - (t - `(LET* ((,$seq ,seq) - (,$start ,(or start 0)) - (,$end ,(or end `(LENGTH ,$seq)))) - (DECLARE (TYPE FIXNUM ,$start ,$end)) - (COND ((= 0 (- ,$end ,$start)) - (FUNCALL* ,fun)) - (T - (LET ((,$accu (FUNCALL* ,key (AREF ,$seq (- ,$end 1))))) - (DO ((,$i (- ,$end 2) (THE FIXNUM (- ,$i 1)))) - ((< ,$i ,$start) ,$accu) - (DECLARE (TYPE FIXNUM ,$i)) - (SETF ,$accu (FUNCALL* ,fun (FUNCALL* ,key (AREF ,$seq ,$i)) ,$accu)))))))) )) - (t - (cond (initial-value? - `(LET* ((,$seq ,seq) - (,$start ,(or start 0)) - (,$end ,(or end `(LENGTH ,$seq))) - (,$accu ,initial-value)) - (DECLARE (TYPE FIXNUM ,$start ,$end)) - (DO ((,$i ,$start (THE FIXNUM (+ ,$i 1)))) - ((>= ,$i ,$end) ,$accu) - (DECLARE (TYPE FIXNUM ,$i)) - (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key (AREF ,$seq ,$i)))) ))) - (t - `(let* ((,$seq ,seq) - (,$start ,(or start 0)) - (,$end ,(or end `(LENGTH ,$seq)))) - (DECLARE (TYPE FIXNUM ,$start ,$end)) - (COND ((= 0 (- ,$end ,$start)) - (FUNCALL* ,fun)) - (T - (LET ((,$accu (FUNCALL* ,key (AREF ,$seq ,$start)))) - (DO ((,$i (+ ,$start 1) (+ ,$i 1))) - ((>= ,$i ,$end) ,$accu) - (DECLARE (TYPE FIXNUM ,$i)) - (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key (AREF ,$seq ,$i))))))))))))))) - -(defmacro lreduce* (fun seq &rest rest &key (key '#'identity) from-end start end - (initial-value nil initial-value?)) - (cond ((or start end from-end) - `(reduce ,fun ,seq .,rest)) - (t - (cond (initial-value? - (let (($accu (make-symbol "accu")) - ($k (make-symbol "k"))) - `(LET* ((,$accu ,initial-value)) - (DOLIST (,$k ,seq ,$accu) - (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key ,$k))))))) - (t - (let (($accu (make-symbol "accu")) - ($seq (make-symbol "seq")) - ($k (make-symbol "k"))) - `(LET* ((,$seq ,seq)) - (IF (NULL ,$seq) - (FUNCALL* ,fun) - (LET ((,$accu (FUNCALL* ,key (CAR ,$seq)))) - (DOLIST (,$k (CDR ,$seq) ,$accu) - (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key ,$k)))))))) ))) )) - - -;;; Wenn wir so weiter machen, koennen wir bald gleich unseren eigenen -;;; Compiler schreiben ;-) - -#|| -(defmacro lreduce* (fun seq &rest x &key key &allow-other-keys) - (let ((q (copy-list x))) - (remf q :key) - (cond (key - `(reduce ,fun (map 'vector ,key ,seq) .,q)) - (t - `(reduce ,fun ,seq .,q))))) - -(defmacro vreduce* (fun seq &rest x &key key &allow-other-keys) - (let ((q (copy-list x))) - (remf q :key) - (cond (key - `(reduce ,fun (map 'vector ,key ,seq) .,q)) - (t - `(reduce ,fun ,seq .,q))))) - -||# - -;; Stolen from Eclipse (http://elwoodcorp.com/eclipse/unique.htm - -(defmacro with-unique-names ((&rest names) &body body) - `(let (,@(mapcar (lambda (x) (list x `(gensym ',(concatenate 'string (symbol-name x) "-")))) names)) - .,body)) - - -(defun gstream-as-string (gstream &optional (buffer-size 4096)) - (let ((buffer (make-array buffer-size - :element-type 'character - :adjustable t))) - (do* ((i 0 j) - (j (g/read-char-sequence buffer gstream :start 0 :end buffer-size) - (g/read-char-sequence buffer gstream :start i :end (+ i buffer-size)) )) - ((= j i) (subseq buffer 0 j)) - (adjust-array buffer (list (+ j buffer-size))) ))) - -;;;; Generic hash tables - -;; TODO: -;; - automatic size adjustment -;; - sensible printer -;; - make-load-form?! - -(defstruct g/hash-table - hash-function ;hash function - compare-function ;predicate to test for equality - table ;simple vector of chains - size ;size of hash table - (nitems 0)) ;number of items - -(defun g/make-hash-table (&key (size 100) (hash-function #'sxhash) (compare-function #'eql)) - "Creates a generic hashtable; - `size' is the default size of the table. - `hash-function' (default #'sxhash) is a specific hash function - `compare-function' (default #'eql) is a predicate to test for equality." - (setf size (nearest-greater-prime size)) - (make-g/hash-table :hash-function hash-function - :compare-function compare-function - :table (make-array size :initial-element nil) - :size size - :nitems 0)) - -(defun g/hashget (hashtable key &optional (default nil)) - "Looks up the key `key' in the generic hash table `hashtable'. - Returns three values: - value - value, which as associated with the key, or `default' is no value - present. - successp - true, iff the key was found. - key - the original key in the hash table." - ;; -> value ; successp ; key - (let ((j (mod (funcall (g/hash-table-hash-function hashtable) key) - (g/hash-table-size hashtable)))) - (let ((q (assoc key (aref (g/hash-table-table hashtable) j) - :test (g/hash-table-compare-function hashtable)))) - (if q - (values (cdr q) t (car q)) - (values default nil))))) - -(defun (setf g/hashget) (new-value hashtable key &optional (default nil)) - (declare (ignore default)) - (let ((j (mod (funcall (g/hash-table-hash-function hashtable) key) - (g/hash-table-size hashtable)))) - (let ((q (assoc key (aref (g/hash-table-table hashtable) j) - :test (g/hash-table-compare-function hashtable)))) - (cond ((not (null q)) - (setf (cdr q) new-value)) - (t - (push (cons key new-value) - (aref (g/hash-table-table hashtable) j)) - (incf (g/hash-table-nitems hashtable)))))) - new-value) - -(defun resize-hash-table (hashtable new-size) - "Adjust the size of a generic hash table. (the size is round to the next greater prime number)." - (setf new-size (nearest-greater-prime new-size)) - (let ((new-table (make-array new-size :initial-element nil))) - (dotimes (i (g/hash-table-size hashtable)) - (dolist (k (aref (g/hash-table-table hashtable) i)) - (push k (aref new-table - (mod (funcall (g/hash-table-hash-function hashtable) (car k)) - new-size))))) - (setf (g/hash-table-table hashtable) new-table - (g/hash-table-size hashtable) new-size) - hashtable)) - -(defun g/clrhash (hashtable) - "Clears a generic hash table." - (dotimes (i (g/hash-table-size hashtable)) - (setf (aref (g/hash-table-table hashtable) i) nil)) - (setf (g/hash-table-nitems hashtable) nil) - hashtable) - -;; hash code utilities - -(defconstant +fixnum-bits+ - (1- (integer-length most-positive-fixnum)) - "Pessimistic approximation of the number of bits of fixnums.") - -(defconstant +fixnum-mask+ - (1- (expt 2 +fixnum-bits+)) - "Pessimistic approximation of the largest bit-mask, still being a fixnum.") - -(defun stir-hash-codes (a b) - "Stirs two hash codes together; always returns a fixnum. - When applied sequenitally the first argument should be used as accumulator." - ;; ich mach das mal wie Bruno - (logand +fixnum-mask+ - (logxor (logior (logand +fixnum-mask+ (ash a 5)) - (logand +fixnum-mask+ (ash a (- 5 +fixnum-bits+)))) - b))) - -(defun hash-sequence (sequence hash-function &optional (accu 0)) - "Applies the hash function `hash-function' to each element of `sequence' and - stirs the resulting hash codes together using STIR-HASH-CODE starting from - `accu'." - (map nil (lambda (item) - (setf accu (stir-hash-codes accu (funcall hash-function item)))) - sequence) - accu) - -;; some specific hash functions - -(defun hash/string-equal (string) - "Hash function compatible with STRING-EQUAL." - (hash-sequence string (lambda (char) - (sxhash (char-upcase char))))) - -;; some specific hash tables - -(defun make-string-equal-hash-table (&rest options) - "Constructs a new generic hash table using STRING-EQUAL as predicate." - (apply #'g/make-hash-table - :hash-function #'hash/string-equal - :compare-function #'string-equal - options)) - -;; prime numbers - -(defun primep (n) - "Returns true, iff `n' is prime." - (and (> n 2) - (do ((i 2 (+ i 1))) - ((> (* i i) n) t) - (cond ((zerop (mod n i)) (return nil)))))) - -(defun nearest-greater-prime (n) - "Returns the smallest prime number no less than `n'." - (cond ((primep n) n) - ((nearest-greater-prime (+ n 1))))) - - -;;; - -(defun grind-documentation-string (string &optional (sink *standard-output*)) - ;; some people say: - ;; (defun foo () - ;; "This function - ;; frobinates its two arguments.") - ;; some say: - ;; (defun foo () - ;; "This function - ;; frobinates its two arguments.") - ;; instead. - (let ((min-indention nil)) - ;; We sort this out by finding the minimum indent in all but the first line. - (with-input-from-string (in string) - (read-line in nil nil) ;ignore first line - (do ((x (read-line in nil nil) (read-line in nil nil))) - ((null x)) - (let ((p (position-if-not (curry #'char= #\space) x))) - (when p - (setf min-indention (min* min-indention p)))))) - (setf min-indention (or min-indention 0)) - ;; Now we could dump the string - (with-input-from-string (in string) - ;; first line goes unindented - (let ((x (read-line in nil nil))) - (when x - (fresh-line sink) - (write-string x sink))) - (do ((x (read-line in nil nil) (read-line in nil nil))) - ((null x)) - (terpri sink) - (when (< min-indention (length x)) - (write-string x sink :start min-indention))))) - (values)) - -(defun ap (&rest strings) - "A new apropos." - (let ((res nil)) - (do-all-symbols (symbol) - (unless (member symbol res) - (when (every (lambda (string) - (search string (symbol-name symbol))) - strings) - (push symbol res)))) - (dolist (k res) - (print k) - (when (fboundp k) - (princ ", function")) - (when (boundp k) - (princ ", variable")) - ))) - +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Some common utilities for the Closure browser +;;; Created: 1997-12-27 +;;; Author: Gilbert Baumann +;;; License: MIT style (see below) +;;; --------------------------------------------------------------------------- +;;; (c) copyright 1997-1999 by Gilbert Baumann + +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;; Changes +;; +;; When Who What +;; ---------------------------------------------------------------------------- +;; 1999-08-24 GB = fixed MULTIPLE-VALUE-OR it now takes any number of +;; subforms +;; + +(in-package :GLISP) + +;;; -------------------------------------------------------------------------------- +;;; Meta functions + +(defun curry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append args more)))) + +(defun rcurry (fun &rest args) + #'(lambda (&rest more) + (apply fun (append more args)))) + +(defun compose (f g) + #'(lambda (&rest args) + (funcall f (apply g args)))) + +(defun always (value) + #'(lambda (&rest args) + (declare (ignore args)) + value)) + + +;;; -------------------------------------------------------------------------------- +;;; Multiple values + +(defmacro multiple-value-or (&rest xs) + (cond ((null xs) + nil) + ((null (cdr xs)) + (car xs)) + (t + (let ((g (gensym))) + `(LET ((,g (MULTIPLE-VALUE-LIST ,(car xs)))) + (IF (CAR ,g) + (VALUES-LIST ,g) + (MULTIPLE-VALUE-OR ,@(cdr xs)))))))) + + +;;; -------------------------------------------------------------------------------- +;;; while and until + +(defmacro while (test &body body) + `(until (not ,test) ,@body)) + +(defmacro until (test &body body) + `(do () (,test) ,@body)) + + +;;; -------------------------------------------------------------------------------- +;;; Strings + +(defun white-space-p (ch) + ;;(declare #.cl-user:+optimize-very-fast-trusted+) + (or (eq ch #\Return) + (eq ch #\Newline) + (eq ch #\Space) + (eq ch #\Tab) + (eq ch #\Page))) + +(define-compiler-macro white-space-p (ch) + `(member ,ch '(#\Return #\Newline #\Space #\Tab #\Page)) ) + + +;;;; ----------------------------------------------------------------------------------------- +;;;; Homebrew stream classes +;;;; + +;; I am really tired of standard Common Lisp streams and thier incompatible implementations. + +;; A gstream is an objects with obeys to the following protocol: + +;; g/read-byte stream &optional (eof-error-p t) eof-value +;; g/unread-byte byte stream +;; g/read-char stream &optional (eof-error-p t) eof-value +;; g/unread-char char stream +;; g/write-char char stream +;; g/write-byte byte stream +;; g/finish-output stream +;; g/close stream &key abort + +;; Additionally the follwing generic functions are implemented based +;; on the above protocol and may be reimplemented for any custom +;; stream class for performance. + +;; g/write-string string stream &key start end +;; g/read-line stream &optional (eof-error-p t) eof-value +;; g/read-line* stream &optional (eof-error-p t) eof-value +;; g/read-byte-sequence sequence stream &key start end +;; g/read-char-sequence sequence stream &key start end +;; g/write-byte-sequence sequence stream &key start end +;; g/write-char-sequence sequence stream &key start end + + +;; The following classes exists + +;; gstream +;; use-char-for-byte-stream-flavour +;; use-byte-for-char-stream-flavour +;; cl-stream +;; cl-byte-stream +;; cl-char-stream + +(defclass gstream () ()) + +;;; use-char-for-byte-stream-flavour + +(defclass use-char-for-byte-stream-flavour () ()) + +(defmethod g/read-byte ((self use-char-for-byte-stream-flavour) &optional (eof-error-p t) eof-value) + (let ((r (g/read-char self eof-error-p :eof))) + (if (eq r :eof) + eof-value + (char-code r)))) + +(defmethod g/unread-byte (byte (self use-char-for-byte-stream-flavour)) + (g/unread-char (or (and #+CMU (<= byte char-code-limit) (code-char byte)) + (error "Cannot stuff ~D. into a character." byte)) + self)) + +(defmethod g/write-byte (byte (self use-char-for-byte-stream-flavour)) + (g/write-char (or (and #+CMU (<= byte char-code-limit) (code-char byte)) + (error "Cannot stuff ~D. into a character." byte)) + self)) + +;;; use-byte-for-char-stream-flavour + +(defclass use-byte-for-char-stream-flavour () ()) + +(defmethod g/read-char ((self use-byte-for-char-stream-flavour) &optional (eof-error-p t) eof-value) + (let ((byte (g/read-byte self eof-error-p :eof))) + (if (eq byte :eof) + eof-value + (let ((res (and #+CMU (<= byte char-code-limit) (code-char byte)))) + (or res + (error "The byte ~D. could not been represented as character in your LISP implementation." byte)))))) + +(defmethod g/unread-char (char (self use-byte-for-char-stream-flavour)) + (g/unread-byte (char-code char) self)) + +(defmethod g/write-char (char (self use-byte-for-char-stream-flavour)) + (g/write-byte (char-code char) self)) + +;;; ------------------------------------------------------------ +;;; Streams made up out of Common Lisp streams + +;;; cl-stream + +(defclass cl-stream (gstream) + ((cl-stream :initarg :cl-stream))) + +(defmethod g/finish-output ((self cl-stream)) + (with-slots (cl-stream) self + (finish-output cl-stream))) + +(defmethod g/close ((self cl-stream) &key abort) + (with-slots (cl-stream) self + (close cl-stream :abort abort))) + +;;; cl-byte-stream + +(defclass cl-byte-stream (use-byte-for-char-stream-flavour cl-stream) + ((lookahead :initform nil))) + +(defmethod g/read-byte ((self cl-byte-stream) &optional (eof-error-p t) eof-value) + (with-slots (cl-stream lookahead) self + (if lookahead + (prog1 lookahead + (setf lookahead nil)) + (read-byte cl-stream eof-error-p eof-value)))) + +(defmethod g/unread-byte (byte (self cl-byte-stream)) + (with-slots (cl-stream lookahead) self + (if lookahead + (error "You cannot unread twice.") + (setf lookahead byte)))) + +(defmethod g/write-byte (byte (self cl-byte-stream)) + (with-slots (cl-stream) self + (write-byte byte cl-stream))) + +(defmethod g/read-byte-sequence (sequence (input cl-byte-stream) &key (start 0) (end (length sequence))) + (with-slots (cl-stream) input + (read-sequence sequence cl-stream :start start :end end))) + +(defmethod g/write-byte-sequence (sequence (sink cl-byte-stream) &key (start 0) (end (length sequence))) + (with-slots (cl-stream) sink + (cl:write-sequence sequence cl-stream :start start :end end))) + +;;; cl-char-stream + +(defclass cl-char-stream (use-char-for-byte-stream-flavour cl-stream) + ()) + +(defmethod g/read-char ((self cl-char-stream) &optional (eof-error-p t) eof-value) + (with-slots (cl-stream) self + (read-char cl-stream eof-error-p eof-value))) + +(defmethod g/unread-char (char (self cl-char-stream)) + (with-slots (cl-stream) self + (unread-char char cl-stream))) + +(defmethod g/write-char (char (self cl-char-stream)) + (with-slots (cl-stream) self + (write-char char cl-stream))) + +;;; ------------------------------------------------------------ +;;; General or fall back stream methods + +(defmethod g/write-string (string (stream t) &key (start 0) (end (length string))) + (do ((i start (+ i 1))) + ((>= i end)) + (g/write-char (char string i) stream))) + +(defmethod g/read-line ((stream t) &optional (eof-error-p t) eof-value) + (let ((res nil)) + (do ((c (g/read-char stream eof-error-p :eof) + (g/read-char stream nil :eof))) + ((or (eq c :eof) (char= c #\newline)) + (cond ((eq c :eof) + (values (if (null res) eof-value (coerce (nreverse res) 'string)) + t)) + (t + (values (coerce (nreverse res) 'string) + nil)))) + (push c res)))) + +(defmethod g/read-line* ((stream t) &optional (eof-error-p t) eof-value) + ;; Like read-line, but accepts CRNL, NL, CR as line termination + (let ((res nil)) + (do ((c (g/read-char stream eof-error-p :eof) + (g/read-char stream nil :eof))) + ((or (eq c :eof) (char= c #\newline) (char= c #\return)) + (cond ((eq c :eof) + (values (if (null res) eof-value (coerce (nreverse res) 'string)) + t)) + (t + (when (char= c #\return) + (let ((d (g/read-char stream nil :eof))) + (unless (or (eq d :eof) (char= d #\newline)) + (g/unread-char d stream)))) + (values (coerce (nreverse res) 'string) + nil)))) + (push c res)))) + +(defmethod g/read-byte-sequence (sequence (input t) &key (start 0) (end (length sequence))) + (let ((i start) c) + (loop + (when (>= i end) + (return i)) + (setf c (g/read-byte input nil :eof)) + (when (eq c :eof) + (return i)) + (setf (elt sequence i) c) + (incf i)))) + +(defmethod g/read-char-sequence (sequence (input t) &key (start 0) (end (length sequence))) + (let ((i start) c) + (loop + (when (>= i end) + (return i)) + (setf c (g/read-char input nil :eof)) + (when (eq c :eof) + (return i)) + (setf (elt sequence i) c) + (incf i)))) + +(defmethod g/write-byte-sequence (sequence (sink t) &key (start 0) (end (length sequence))) + (do ((i start (+ i 1))) + ((>= i end) i) + (g/write-byte (aref sequence i) sink))) + + +(defun g/peek-char (&optional (peek-type nil) (source *standard-input*) + (eof-error-p T) eof-value) + (cond ((eq peek-type T) + (do ((ch (g/read-char source eof-error-p '%the-eof-object%) + (g/read-char source eof-error-p '%the-eof-object%))) + ((or (eq ch '%the-eof-object%) + (not (white-space-p ch))) + (cond ((eq ch '%the-eof-object%) eof-value) + (t (g/unread-char ch source) ch)) ))) + ((eq peek-type NIL) + (let ((ch (g/read-char source eof-error-p '%the-eof-object%))) + (cond ((eq ch '%the-eof-object%) eof-value) + (t (g/unread-char ch source) + ch)))) + ((characterp peek-type) + (do ((ch (g/read-char source eof-error-p '%the-eof-object%) + (g/read-char source eof-error-p '%the-eof-object%))) + ((or (eq ch '%the-eof-object%) (eql ch peek-type)) + (cond ((eq ch '%the-eof-object%) eof-value) + (t (g/unread-char ch source) ch)) )) ) )) + + +(defun cl-byte-stream->gstream (stream) + (make-instance 'cl-byte-stream :cl-stream stream)) + +(defun cl-char-stream->gstream (stream) + (make-instance 'cl-char-stream :cl-stream stream)) + +;;;; + +(defun set-equal (x y &rest options) + (null (apply #'set-exclusive-or x y options))) + +;;;; + +(defun maybe-parse-integer (string &key (radix 10)) + (cond ((not (stringp string)) nil) + (t + (let ((len (length string))) + (cond ((= len 0) nil) + (t + (let ((start 0) + (vz +1) + (res 0)) + (cond ((and (> len 1) (char= (char string 0) #\+)) + (incf start)) + ((and (> len 1) (char= (char string 0) #\-)) + (setf vz -1) + (incf start))) + (do ((i start (+ i 1))) + ((= i len) (* vz res)) + (let ((d (digit-char-p (char string i) radix))) + (if d + (setf res (+ (* radix res) d)) + (return nil))))))))))) -- 2.11.4.GIT