diff --git a/characters.lisp b/characters.lisp index a8fa7e9..828a40c 100644 --- a/characters.lisp +++ b/characters.lisp @@ -24,35 +24,35 @@ (in-package :runes) -(deftype rune () 'base-char) -(deftype rod () 'base-string) -(deftype simple-rod () 'simple-string) +(deftype rune () 'character) +(deftype rod () '(vector character)) +(deftype simple-rod () '(simple-array character)) -(defsubst rune (rod index) +(definline rune (rod index) (char rod index)) (defun (setf rune) (new rod index) (setf (char rod index) new)) -(defsubst %rune (rod index) +(definline %rune (rod index) (aref (the simple-string rod) (the fixnum index))) -(defsubst (setf %rune) (new rod index) +(definline (setf %rune) (new rod index) (setf (aref (the simple-string rod) (the fixnum index)) new)) (defun rod-capitalize (rod) (string-upcase rod)) -(defsubst code-rune (x) (code-char x)) -(defsubst rune-code (x) (char-code x)) +(definline code-rune (x) (code-char x)) +(definline rune-code (x) (char-code x)) -(defsubst rune= (x y) +(definline rune= (x y) (char= x y)) (defun rune-downcase (rune) (char-downcase rune)) -(defsubst rune-upcase (rune) +(definline rune-upcase (rune) (char-upcase rune)) (defun rune-upper-case-letter-p (rune) @@ -70,13 +70,13 @@ (defun rod-upcase (rod) (string-upcase rod)) -(defsubst white-space-rune-p (char) +(definline white-space-rune-p (char) (or (char= char #\tab) (char= char #.(code-char 10)) ;Linefeed (char= char #.(code-char 13)) ;Carriage Return (char= char #\space))) -(defsubst digit-rune-p (char &optional (radix 10)) +(definline digit-rune-p (char &optional (radix 10)) (digit-char-p char radix)) (defun rod (x) @@ -100,7 +100,7 @@ (defun rod-equal (x y) (string-equal x y)) -(defsubst make-rod (size) +(definline make-rod (size) (make-string size)) (defun char-rune (char) @@ -134,9 +134,6 @@ (defun rodp (object) (stringp object)) -(defun really-rod-p (object) - (stringp object)) - (defun rod-subseq (source start &optional (end (length source))) (unless (stringp source) (error "~S is not of type ~S." source 'rod)) diff --git a/dep-acl.lisp b/dep-acl.lisp index 5bbda45..efd67b0 100644 --- a/dep-acl.lisp +++ b/dep-acl.lisp @@ -28,13 +28,13 @@ ;; Unfortunately it is also incapable to declaim such functions inline. ;; So we revoke the DEFUN hack from dep-gcl here. -(defmacro runes::defsubst (fun args &body body) +(defmacro runes::definline (fun args &body body) (if (and (consp fun) (eq (car fun) 'setf)) (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") (symbol-package (cadr fun))))) `(progn (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) - (runes::defsubst ,fnam ,args .,body))) + (runes::definline ,fnam ,args .,body))) `(progn (defun ,fun ,args .,body) (define-compiler-macro ,fun (&rest .args.) diff --git a/dep-acl5.lisp b/dep-acl5.lisp index 64534d9..a597064 100644 --- a/dep-acl5.lisp +++ b/dep-acl5.lisp @@ -40,13 +40,13 @@ ;; Unfortunately it is also incapable to declaim such functions inline. ;; So we revoke the DEFUN hack from dep-gcl here. -(defmacro runes::defsubst (fun args &body body) +(defmacro runes::definline (fun args &body body) (if (and (consp fun) (eq (car fun) 'setf)) (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") (symbol-package (cadr fun))))) `(progn (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) - (runes::defsubst ,fnam ,args .,body))) + (runes::definline ,fnam ,args .,body))) (labels ((declp (x) (and (consp x) (eq (car x) 'declare)))) `(progn diff --git a/dep-clisp.lisp b/dep-clisp.lisp index 2d9216b..e8fa296 100644 --- a/dep-clisp.lisp +++ b/dep-clisp.lisp @@ -30,30 +30,30 @@ (if (fboundp 'cl::define-compiler-macro) (pushnew 'define-compiler-macro *features*))) -(setq lisp:*load-paths* '(#P"./")) +;;;(setq lisp:*load-paths* '(#P"./")) +;;; +;;;#+DEFINE-COMPILER-MACRO +;;;(cl:define-compiler-macro ldb (bytespec value &whole whole) +;;; (let (pos size) +;;; (cond ((and (consp bytespec) +;;; (= (length bytespec) 3) +;;; (eq (car bytespec) 'byte) +;;; (constantp (setq size (second bytespec))) +;;; (constantp (setq pos (third bytespec)))) +;;; `(logand ,(if (eql pos 0) value `(ash ,value (- ,pos))) +;;; (1- (ash 1 ,size)))) +;;; (t +;;; whole)))) +;;; +;;;#-DEFINE-COMPILER-MACRO +;;;(progn +;;; (export 'runes::define-compiler-macro :runes) +;;; (defmacro runes::define-compiler-macro (name args &body body) +;;; (declare (ignore args body)) +;;; `(progn +;;; ',name))) -#+DEFINE-COMPILER-MACRO -(cl:define-compiler-macro ldb (bytespec value &whole whole) - (let (pos size) - (cond ((and (consp bytespec) - (= (length bytespec) 3) - (eq (car bytespec) 'byte) - (constantp (setq size (second bytespec))) - (constantp (setq pos (third bytespec)))) - `(logand ,(if (eql pos 0) value `(ash ,value (- ,pos))) - (1- (ash 1 ,size)))) - (t - whole)))) - -#-DEFINE-COMPILER-MACRO -(progn - (export 'runes::define-compiler-macro :runes) - (defmacro runes::define-compiler-macro (name args &body body) - (declare (ignore args body)) - `(progn - ',name))) - -(defmacro runes::defsubst (name args &body body) +(defmacro runes::definline (name args &body body) `(progn (declaim (inline ,name)) (defun ,name ,args .,body))) diff --git a/dep-cmucl-dtc.lisp b/dep-cmucl-dtc.lisp index 2e080c3..2f6cb29 100644 --- a/dep-cmucl-dtc.lisp +++ b/dep-cmucl-dtc.lisp @@ -24,7 +24,7 @@ ;;; superseded by a newer version) or write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(defmacro runes::defsubst (name args &body body) +(defmacro runes::definline (name args &body body) `(progn (declaim (inline ,name)) (defun ,name ,args .,body))) diff --git a/dep-cmucl.lisp b/dep-cmucl.lisp index 2e080c3..2f6cb29 100644 --- a/dep-cmucl.lisp +++ b/dep-cmucl.lisp @@ -24,7 +24,7 @@ ;;; superseded by a newer version) or write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(defmacro runes::defsubst (name args &body body) +(defmacro runes::definline (name args &body body) `(progn (declaim (inline ,name)) (defun ,name ,args .,body))) diff --git a/dep-openmcl.lisp b/dep-openmcl.lisp index 3ff2c6f..f5bb8a9 100644 --- a/dep-openmcl.lisp +++ b/dep-openmcl.lisp @@ -5,7 +5,7 @@ ;;;; ;;;; (c) copyright 1999 by Gilbert Baumann -(defmacro runes::defsubst (fun args &body body) +(defmacro runes::definline (fun args &body body) (if (consp fun) `(defun ,fun ,args ,@body) diff --git a/dep-sbcl.lisp b/dep-sbcl.lisp index 9431fb3..c111a17 100644 --- a/dep-sbcl.lisp +++ b/dep-sbcl.lisp @@ -24,7 +24,7 @@ ;;; superseded by a newer version) or write to the Free Software ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -(defmacro runes::defsubst (name args &body body) +(defmacro runes::definline (name args &body body) `(progn (declaim (inline ,name)) (defun ,name ,args .,body))) diff --git a/package.lisp b/package.lisp index 921c457..d92ed60 100644 --- a/package.lisp +++ b/package.lisp @@ -10,15 +10,8 @@ (defpackage :runes (:use :cl) - (:export #:defsubst + (:export #:definline - ;; util.lisp : - #:compose - #:curry - #:rcurry - #:until - #:while - ;; runes.lisp #:rune #:rod @@ -47,4 +40,29 @@ #:rod-string #:string-rod #:rod-subseq - #:rod<)) + #:rod< + + ;; xstream.lisp + #:make-xstream + #:make-rod-xstream + #:close-xstream + #:xstream-p + #:read-rune + #:peek-rune + #:fread-rune + #:fpeek-rune + #:consume-rune + #:unread-rune + #:xstream-position + #:xstream-line-number + #:xstream-column-number + #:xstream-plist + #:xstream-encoding + #:set-to-full-speed + #:xstream-name)) + +(defpackage :encoding + (:use :cl :runes) + (:export + #:find-encoding + #:decode-sequence)) diff --git a/runes.lisp b/runes.lisp index 7aed6d0..620bb79 100644 --- a/runes.lisp +++ b/runes.lisp @@ -42,26 +42,26 @@ (deftype rod () '(array rune (*))) (deftype simple-rod () '(simple-array rune (*))) -(defsubst rune (rod index) +(definline rune (rod index) (aref rod index)) (defun (setf rune) (new rod index) (setf (aref rod index) new)) -(defsubst %rune (rod index) +(definline %rune (rod index) (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index))) -(defsubst (setf %rune) (new rod index) +(definline (setf %rune) (new rod index) (setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new)) (defun rod-capitalize (rod) (warn "~S is not implemented." 'rod-capitalize) rod) -(defsubst code-rune (x) x) -(defsubst rune-code (x) x) +(definline code-rune (x) x) +(definline rune-code (x) x) -(defsubst rune= (x y) +(definline rune= (x y) (= x y)) (defun rune-downcase (rune) @@ -70,7 +70,7 @@ ((<= #x00c0 rune #x00de) (+ rune #x20)) (t rune))) -(defsubst rune-upcase (rune) +(definline rune-upcase (rune) (cond ((<= #x0061 rune #x007a) (- rune #x20)) ((= rune #x00f7) rune) ((<= #x00e0 rune #x00fe) (- rune #x20)) @@ -89,21 +89,19 @@ (defun rod-downcase (rod) ;; FIXME - (register-rod - (map '(simple-array (unsigned-byte 16) (*)) #'rune-downcase rod))) + (map '(simple-array (unsigned-byte 16) (*)) #'rune-downcase rod)) (defun rod-upcase (rod) ;; FIXME - (register-rod - (map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod))) + (map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod)) -(defsubst white-space-rune-p (char) +(definline white-space-rune-p (char) (or (= char 9) ;TAB (= char 10) ;Linefeed (= char 13) ;Carriage Return (= char 32))) ;Space -(defsubst digit-rune-p (char &optional (radix 10)) +(definline digit-rune-p (char &optional (radix 10)) (cond ((<= #.(char-code #\0) char #.(char-code #\9)) (and (< (- char #.(char-code #\0)) radix) (- char #.(char-code #\0)))) @@ -115,11 +113,11 @@ (- char #.(char-code #\a) -10))) )) (defun rod (x) - (cond ((stringp x) (register-rod (map 'rod #'char-code x))) + (cond ((stringp x) (map 'rod #'char-code x)) ((symbolp x) (rod (string x))) ((characterp x) (rod (string x))) - ((vectorp x) (register-rod (coerce x 'rod))) - ((integerp x) (register-rod (map 'rod #'identity (list x)))) + ((vectorp x) (coerce x 'rod)) + ((integerp x) (map 'rod #'identity (list x))) (t (error "Cannot convert ~S to a ~S" x 'rod)))) (defun runep (x) @@ -143,19 +141,16 @@ (unless (rune-equal (rune x i) (rune y i)) (return nil))))) -(defsubst make-rod (size) - (let ((res (make-array size :element-type 'rune))) - (register-rod res) - res)) +(definline make-rod (size) + (make-array size :element-type 'rune)) (defun char-rune (char) (code-rune (char-code char))) (defun rune-char (rune &optional (default #\?)) - #+CMU - (if (< rune 256) (code-char rune) default) - #-CMU - (or (code-char rune) default)) + (if (>= rune char-code-limit) + default + (or (code-char rune) default))) (defun rod-string (rod &optional (default-char #\?)) (map 'string (lambda (x) (rune-char x default-char)) rod)) @@ -178,10 +173,6 @@ (defun rodp (object) (typep object 'rod)) -(defun really-rod-p (object) - (and (typep object 'rod) - (really-really-rod-p object))) - (defun rod-subseq (source start &optional (end (length source))) (unless (rodp source) (error "~S is not of type ~S." source 'rod)) @@ -221,45 +212,6 @@ (declare (type fixnum i)) (setf (%rune res i) (aref source (the fixnum (+ i start)))))))) -;;; Support for telling ROD and arrays apart: - -#+CMU -(progn - (defvar *rod-hash-table* - (make-array 5003 :initial-element nil))) - -(defun register-rod (rod) - #+CMU - (unless (really-really-rod-p rod) - (push (ext:make-weak-pointer rod) - (aref *rod-hash-table* (mod (cl::pointer-hash rod) - (length *rod-hash-table*))))) - rod) - -(defun really-really-rod-p (rod) - #+CMU - (find rod (aref *rod-hash-table* (mod (cl::pointer-hash rod) - (length *rod-hash-table*))) - :key #'ext:weak-pointer-value)) - -#+CMU -(progn - (defun rod-hash-table-rehash () - (let* ((n 5003) - (new (make-array n :initial-element nil))) - (loop for bucket across *rod-hash-table* do - (loop for item in bucket do - (let ((v (ext:weak-pointer-value item))) - (when v - (push item (aref new (mod (cl::pointer-hash v) n))))))) - (setf *rod-hash-table* new))) - - (defun rod-hash-after-gc-hook () - ;; hmm interesting question: should we rehash? - (rod-hash-table-rehash)) - - (pushnew 'rod-hash-after-gc-hook extensions:*after-gc-hooks*) ) - (defun rod< (rod1 rod2) (do ((i 0 (+ i 1))) (nil) diff --git a/util.lisp b/util.lisp deleted file mode 100644 index 60cd74c..0000000 --- a/util.lisp +++ /dev/null @@ -1,73 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RUNES; -*- -;;; --------------------------------------------------------------------------- -;;; Title: Some common utilities for the Closure browser -;;; Created: 1997-12-27 -;;; Author: Gilbert Baumann -;;; License: LLGPL (See file COPYING for details). -;;; --------------------------------------------------------------------------- -;;; (c) copyright 1997-1999 by Gilbert Baumann - -;;; 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 "Preamble to the Gnu Lesser General Public License" found in -;;; the file COPYING. -;;; -;;; 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. -;;; -;;; Version 2.1 of the GNU Lesser General Public License is in the file -;;; COPYING that was distributed with this file. If it is not present, -;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until -;;; superseded by a newer version) or write to the Free Software -;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -;; Changes -;; -;; When Who What -;; ---------------------------------------------------------------------------- -;; 1999-08-24 GB = fixed MULTIPLE-VALUE-OR it now takes any number of -;; subforms -;; - -(in-package :runes) - -;;; -------------------------------------------------------------------------------- -;;; 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)))) - -;;; -------------------------------------------------------------------------------- -;;; while and until - -(defmacro while (test &body body) - `(until (not ,test) ,@body)) - -(defmacro until (test &body body) - `(do () (,test) ,@body)) - -;; 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))))) diff --git a/xstream.lisp b/xstream.lisp index 9032a7b..fe818ca 100644 --- a/xstream.lisp +++ b/xstream.lisp @@ -65,7 +65,7 @@ ;; XSTREAM/CLOSE os-stream ;; -(eval-when (eval compile load) +(eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *fast* '(optimize (speed 3) (safety 0))) ;;(defparameter *fast* '(optimize (speed 2) (safety 3))) ) @@ -154,6 +154,10 @@ ;; `buffer-start'. ) +(defun print-xstream (self sink depth) + (declare (ignore depth)) + (format sink "#<~S ~S>" (type-of self) (xstream-name self))) + (defmacro read-rune (input) "Read a single rune off the xstream `input'. In case of end of file :EOF is returned." @@ -213,7 +217,7 @@ nil) ,input)) -(defsubst unread-rune (rune input) +(definline unread-rune (rune input) "Unread the last recently read rune; if there wasn't such a rune, you deserve to lose." (declare (ignore rune)) @@ -376,10 +380,20 @@ ;;; controller implementations (defmethod read-octets (sequence (stream stream) start end) - (#+CLISP lisp:read-byte-sequence + (#+CLISP ext:read-byte-sequence #-CLISP read-sequence sequence stream :start start :end end)) +#+cmu +(defmethod read-octets :around (sequence (stream stream) start end) + ;; CMUCL <= 19a on non-SunOS accidentally triggers EFAULT in read(2) + ;; if SEQUENCE has been write protected by GC. Workaround: Touch all pages + ;; in SEQUENCE and make sure no GC happens between that and the read(2). + (ext::without-gcing + (loop for i from start below end + do (setf (elt sequence i) (elt sequence i))) + (call-next-method))) + (defmethod read-octets (sequence (stream null) start end) (declare (ignore sequence start end)) 0)