OSCL/closure-common
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- Moved utility functions from the "runes" package to the "cxml" package to

Browse Source 
avoid name conflicts with functions from "glisp" of the same name.
- Renamed defsubst to definline for the same reason.

(This is a commit to the cxml repository, not the main closure repository.
If you don't want cxml commit messages on the closure list, please complain
to me and I'll change it.)
This commit is contained in:
dlichteblau
2005-03-25 18:16:56 +00:00
parent 0a7fe86e1c
commit 11249740d9
12 changed files with 107 additions and 199 deletions
Download Patch File Download Diff File Expand all files Collapse all files

29
characters.lisp
View File

@ -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))

4
dep-acl.lisp
View File

@ -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.)

4
dep-acl5.lisp
View File

@ -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

46
dep-clisp.lisp
View File

@ -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)))

2
dep-cmucl-dtc.lisp
View File

@ -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)))

2
dep-cmucl.lisp
View File

@ -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)))

2
dep-openmcl.lisp
View File

@ -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)

2
dep-sbcl.lisp
View File

@ -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)))

36
package.lisp
View File

@ -10,14 +10,7 @@
(defpackage :runes
(:use :cl)
(:export #:defsubst
;; util.lisp :
#:compose
#:curry
#:rcurry
#:until
#:while
(:export #:definline
;; runes.lisp
#:rune
@ -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))

86
runes.lisp
View File

@ -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)

73
util.lisp
View File

@ -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 <unk6@rz.uni-karlsruhe.de>
;;; 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)))))

20
xstream.lisp
View File

@ -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)