diff --git a/CLISP.diff b/CLISP.diff
deleted file mode 100644
index e78ae79..0000000
--- a/CLISP.diff
+++ /dev/null
@@ -1,17 +0,0 @@
---- orig/xml/xml-parse.lisp
-+++ mod/xml/xml-parse.lisp
-@@ -525,7 +525,10 @@
- (declaim (type (simple-array rune (*))
- *scratch-pad* *scratch-pad-2* *scratch-pad-3* *scratch-pad-4*))
-
--(defmacro with-scratch-pads (() &body body)
-+(defmacro with-scratch-pads (#-clisp ()
-+ ;; clisp does not allow () as macro argument list
-+ #+clisp (&key &allow-other-keys)
-+ &body body)
- `(let ((*scratch-pad* (make-array 1024 :element-type 'rune))
- (*scratch-pad-2* (make-array 1024 :element-type 'rune))
- (*scratch-pad-3* (make-array 1024 :element-type 'rune))
-
-
-
diff --git a/NEWS b/NEWS
deleted file mode 100644
index 9045bce..0000000
--- a/NEWS
+++ /dev/null
@@ -1,151 +0,0 @@
-Changes to Gilbert Baumann's Code
-========================================
-(Stand dieser Liste: patch-54)
-
-base-0
- Import of Closure's src/xml and src/glisp
-
-
-Build system
-----------------
-patch-14
- dom-builder.lsp braucht package.lisp
-patch-17
- xml-parse braucht dom-impl
-patch-18
- xml-parse braucht encodings
-patch-19
- xml-parse.lisp needs xml-stream.lisp
-
-
-Interface changes
-----------------
-patch-2
- export UNPARSE-DOCUMENT
-
-
-Portability issues
-----------------
-patch-1
- ACL port aktualisiert
-patch-8
- fixed more mlisp breakage
-
-
-DOM fixes
-----------------
-patch-3
- add dom:remove-child, dom:import-node
-patch-6
- fixed dom:remove-child
-patch-7
- strings->rods in set-attribute, too
-patch-21
- dom:item und dom:length fuer NodeList implementiert
-patch-22
- s/remove-atttribute/remove-attribute
-patch-23
- dom:remove-attribute-node korrigiert
-patch-24
- neu: dom:remove-attribute
-patch-25
- dom:normalize implementiert
-patch-26
- get-elements-by-tag-name fuer Element implementiert
-patch-32
- s/data/value/ fuer CHARACTER-DATA
-patch-33
- Aufruf von Setter-Methoden
-patch-34
- (setf value) nachgetragen
-patch-35
- (DOM:NODE-VALUE ATTRIBUTE) korrigiert
-patch-36
- writer fuer DOM:DATA
-patch-37
- (setf dom:node-value) implementiert
-patch-43
- hack: implemented CHILD-NODES for ENTITY-REFERENCE
-patch-44
- ENTITY-REFERENCE-Kinder als read-only markieren
-patch-45
- DOM-EXCEPTION implementiert
-patch-46
- fixed special cases in delete-data and replace-data
-patch-47
- delete-data: Arraytyp korrigiert
-patch-48
- DOM:INSERT-DATA implementiert
-patch-49
- bugfix: replace-data for count != (length arg)
-patch-50
- patch-46 nachgebessert: offset == length ist OK
-patch-51
- fixed special cases in dom:substring-data
-patch-52
- fixed patch-36, my (setf dom:data) implementation was bogus
-
-
-xml-parse.lisp changes
-----------------
-patch-5
- (assert (eql initial-speed 1)) in make-xstream
-patch-20
- added a forward declaration for *namespace-bindings*
-patch-39
- fix for thread safety in p/document
-patch-41
- Warnung ueber (nicht) redefinierte Attribute abschalten koennen
-patch-54
- call sax:comment; create comment nodes
-
-
-String-Handling
-----------------
-patch-4
- renamed dom to cdom, added string-dom
-patch-38
- diverse setter nachgetragen
-
-
-Misc.
-----------------
-patch-9
- print elements with their tag-name
-patch-11
- print attributes with name and value
-
-patch-10
- (reverted by patch-10)
-patch-12
- REVERT patch-10
-
-
-domtest.cl
-----------------
-patch-27
- alle DOM Level 1 CORE Tests uebersetzen koennen (mehr schlecht als recht)
-patch-28
- so, jetzt kompilieren die DOM-Tests auch (wenngleich zwei drittel noch fehlschlagen)
-patch-29
- einzelnen Test ausfuehren koennen
-patch-30
- workaround
-patch-31
- fuer nicht-Strings
-patch-40
- ?
-patch-42
- implementationAttribute-Probleme zwar ausgeben, aber kein WARN machen
-patch-53
- domtest fixes fuer und
-
-
-xmlconf.cl
-----------------
-patch-13
- Testfunktion fuer XML Conformance Test Suite
-patch-15
- run only tests for namespace-aware XML-1.0 parsers
-patch-16
- mit korrektem OUTPUT abgleichen
diff --git a/dom/xml-canonic.lisp b/dom/xml-canonic.lisp
deleted file mode 100644
index f5908f6..0000000
--- a/dom/xml-canonic.lisp
+++ /dev/null
@@ -1,161 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: runes; Encoding: utf-8; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Dump canonic XML according to J.Clark
-;;; Created: 1999-09-09
-;;; Author: Gilbert Baumann
-;;; License: LGPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; © copyright 1999 by Gilbert Baumann
-
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Library General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 2 of the License, or (at your option) any later version.
-;;;
-;;; This library 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
-;;; Library General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Library General Public
-;;; License along with this library; if not, write to the
-;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;;; Boston, MA 02111-1307 USA.
-
-(in-package :xml)
-
-;;
-;; | Canonical XML
-;; | =============
-;; |
-;; | This document defines a subset of XML called canonical XML. The
-;; | intended use of canonical XML is in testing XML processors, as a
-;; | representation of the result of parsing an XML document.
-;; |
-;; | Every well-formed XML document has a unique structurally equivalent
-;; | canonical XML document. Two structurally equivalent XML documents have
-;; | a byte-for-byte identical canonical XML document. Canonicalizing an
-;; | XML document requires only information that an XML processor is
-;; | required to make available to an application.
-;; |
-;; | A canonical XML document conforms to the following grammar:
-;; |
-;; | CanonXML ::= Pi* element Pi*
-;; | element ::= Stag (Datachar | Pi | element)* Etag
-;; | Stag ::= '<' Name Atts '>'
-;; | Etag ::= ''
-;; | Pi ::= '' Char*)) '?>'
-;; | Atts ::= (' ' Name '=' '"' Datachar* '"')*
-;; | Datachar ::= '&' | '<' | '>' | '"'
-;; | | ' '| '
'| '
'
-;; | | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD))
-;; | Name ::= (see XML spec)
-;; | Char ::= (see XML spec)
-;; | S ::= (see XML spec)
-;; |
-;; | Attributes are in lexicographical order (in Unicode bit order).
-;; |
-;; | A canonical XML document is encoded in UTF-8.
-;; |
-;; | Ignorable white space is considered significant and is treated
-;; | equivalently to data.
-;;
-;; -- James Clark (jjc@jclark.com)
-
-(defvar *quux*) ;!!!BIG HACK!!!
-
-(defun unparse-document (doc sink)
- (map nil (rcurry #'unparse-node sink) (dom:child-nodes doc)))
-
-(defun unparse-node (node sink)
- (cond ((dom:element-p node)
- (write-rune #/< sink)
- (write-rod (dom:tag-name node) sink)
- ;; atts
- (let ((atts (sort (copy-list (dom:items (dom:attributes node)))
- #'rod< :key #'dom:name)))
- (dolist (a atts)
- (write-rune #/space sink)
- (write-rod (dom:name a) sink)
- (write-rune #/= sink)
- (write-rune #/\" sink)
- (let ((*quux* nil))
- (map nil (lambda (c) (unparse-datachar c sink)) (dom:value a)))
- (write-rune #/\" sink)))
- (write-rod '#.(string-rod ">") sink)
- (dom:do-node-list (k (dom:child-nodes node))
- (unparse-node k sink))
- (write-rod '#.(string-rod "") sink))
- ((dom:processing-instruction-p node)
- (unless (rod-equal (dom:target node) '#.(string-rod "xml"))
- (write-rod '#.(string-rod "") sink) ))
- ((dom:text-node-p node)
- (let ((*quux* nil))
- (map nil (lambda (c) (unparse-datachar c sink))
- (dom:data node))))
- ((dom:comment-p node))
- (t
- (error "Oops in unparse: ~S." node))))
-
-(defun unparse-datachar (c sink)
- (cond ((rune= c #/&) (write-rod '#.(string-rod "&") sink))
- ((rune= c #/<) (write-rod '#.(string-rod "<") sink))
- ((rune= c #/>) (write-rod '#.(string-rod ">") sink))
- ((rune= c #/\") (write-rod '#.(string-rod """) sink))
- ((rune= c #/U+0009) (write-rod '#.(string-rod " ") sink))
- ((rune= c #/U+000A) (write-rod '#.(string-rod "
") sink))
- ((rune= c #/U+000D) (write-rod '#.(string-rod "
") sink))
- (t
- (write-rune c sink))))
-
-(defun write-rod (rod sink)
- (let ((*quux* nil))
- (map nil (lambda (c) (write-rune c sink)) rod)))
-
-(defun write-rune (rune sink)
- (let ((code (rune-code rune)))
- (cond ((<= #xD800 code #xDBFF)
- (setf *quux* code))
- ((<= #xDC00 code #xDFFF)
- (let ((q (logior (ash (- *quux* #xD7C0) 10) (- code #xDC00))))
- (write-rune-0 q sink))
- (setf *quux* nil))
- (t
- (write-rune-0 code sink)))))
-
-(defun write-rune-0 (code sink)
- (labels ((wr (x)
- (write-char (code-char x) sink)))
- (cond ((<= #x00000000 code #x0000007F)
- (wr code))
- ((<= #x00000080 code #x000007FF)
- (wr (logior #b11000000 (ldb (byte 5 6) code)))
- (wr (logior #b10000000 (ldb (byte 6 0) code))))
- ((<= #x00000800 code #x0000FFFF)
- (wr (logior #b11100000 (ldb (byte 4 12) code)))
- (wr (logior #b10000000 (ldb (byte 6 6) code)))
- (wr (logior #b10000000 (ldb (byte 6 0) code))))
- ((<= #x00010000 code #x001FFFFF)
- (wr (logior #b11110000 (ldb (byte 3 18) code)))
- (wr (logior #b10000000 (ldb (byte 6 12) code)))
- (wr (logior #b10000000 (ldb (byte 6 6) code)))
- (wr (logior #b10000000 (ldb (byte 6 0) code))))
- ((<= #x00200000 code #x03FFFFFF)
- (wr (logior #b11111000 (ldb (byte 2 24) code)))
- (wr (logior #b10000000 (ldb (byte 6 18) code)))
- (wr (logior #b10000000 (ldb (byte 6 12) code)))
- (wr (logior #b10000000 (ldb (byte 6 6) code)))
- (wr (logior #b10000000 (ldb (byte 6 0) code))))
- ((<= #x04000000 code #x7FFFFFFF)
- (wr (logior #b11111100 (ldb (byte 1 30) code)))
- (wr (logior #b10000000 (ldb (byte 6 24) code)))
- (wr (logior #b10000000 (ldb (byte 6 18) code)))
- (wr (logior #b10000000 (ldb (byte 6 12) code)))
- (wr (logior #b10000000 (ldb (byte 6 6) code)))
- (wr (logior #b10000000 (ldb (byte 6 0) code)))))))
diff --git a/domtest.lisp b/domtest.lisp
deleted file mode 100644
index c9fc910..0000000
--- a/domtest.lisp
+++ /dev/null
@@ -1,433 +0,0 @@
-#+(or)
-(defpackage :domtest
- (:use :cl :xml)
- (:alias (:string-dom :dom)))
-(defpackage :domtest-tests
- (:use))
-(in-package :domtest)
-
-(defparameter *directory* "~/src/2001/DOM-Test-Suite/")
-
-
-;;;; allgemeine Hilfsfunktionen
-
-(defmacro string-case (keyform &rest clauses)
- (let ((key (gensym "key")))
- `(let ((,key ,keyform))
- (declare (ignorable ,key))
- (cond
- ,@(loop
- for (keys . forms) in clauses
- for test = (etypecase keys
- (string `(string= ,key ,keys))
- (sequence `(find ,key ,keys :test 'string=))
- ((eql t) t))
- collect
- `(,test ,@forms))))))
-
-(defun rcurry (function &rest args)
- (lambda (&rest more-args)
- (apply function (append more-args args))))
-
-(defmacro for ((&rest clauses) &rest body-forms)
- `(%for ,clauses (progn ,@body-forms)))
-
-(defmacro for* ((&rest clauses) &rest body-forms)
- `(%for* ,clauses (progn ,@body-forms)))
-
-(defmacro %for ((&rest clauses) body-form &rest finally-forms)
- (for-aux 'for clauses body-form finally-forms))
-
-(defmacro %for* ((&rest clauses) body-form &rest finally-forms)
- (for-aux 'for* clauses body-form finally-forms))
-
-(defmacro for-finish ()
- '(loop-finish))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun for-aux (kind clauses body-form finally-forms)
- ` (loop ,@ (loop for firstp = t then nil
- for %clauses = clauses then (rest %clauses)
- for clause = (first %clauses) then (first %clauses)
- while (and %clauses (listp clause))
- append (cons (ecase kind
- (for (if firstp 'as 'and))
- (for* 'as))
- (if (= 2 (length clause))
- (list (first clause) '= (second clause))
- clause))
- into result
- finally (return (append result %clauses)))
- do (progn ,body-form)
- finally (progn ,@finally-forms))))
-
-
-;;;; spezielle Hilfsfunktionen
-
-(defmacro with-attributes ((&rest attributes) element &body body)
- (let ((e (gensym "element")))
- `(let* ((,e ,element)
- ,@(mapcar (lambda (var)
- `(,var (dom:get-attribute ,e ,(symbol-name var))))
- attributes))
- ,@body)))
-
-(defun map-child-elements (result-type fn element &key name)
- (remove '#1=#:void
- (map result-type
- (lambda (node)
- (if (and (eq (dom:node-type node) :element)
- (or (null name)
- (equal (dom:tag-name node) name)))
- (funcall fn node)
- '#1#))
- (dom:child-nodes element))))
-
-(defmacro do-child-elements ((var element &key name) &body body)
- `(block nil
- (map-child-elements nil (lambda (,var) ,@body) ,element :name ,name)))
-
-(defun find-child-element (name element)
- (do-child-elements (child element :name name)
- (return child)))
-
-(defun %intern (name)
- (intern name :domtest-tests))
-
-(defun replace-studly-caps (str)
- ;; s/([A-Z][a-z])/-\1/
- (with-output-to-string (out)
- (with-input-from-string (in str)
- (for ((first = t :then nil)
- (c = (read-char in nil nil))
- (next = (peek-char nil in nil nil))
- :while c)
- (when (and (not first) (upper-case-p c) next (lower-case-p next))
- (write-char #\- out))
- (write-char (char-downcase c) out)))))
-
-(defun intern-dom (name)
- (intern (replace-studly-caps name) :dom))
-
-(defun child-elements (element)
- (map-child-elements 'list #'identity element))
-
-(defun parse-java-literal (str)
- (cond
- ((null str) nil) ;?
- ((equal str "true")
- t)
- ((equal str "false")
- nil)
- ((digit-char-p (char str 0))
- (parse-integer str))
- ((char= (char str 0) #\")
- (let ((end (1- (length str))))
- (assert (char= (char str end) #\"))
- (subseq str 1 end)))
- (t
- (%intern str))))
-
-(defmacro maybe-setf (place form)
- (if place
- `(setf ,place ,form)
- form))
-
-
-;;;; dom1-interfaces.xml auslesen
-
-(defvar *methods* '())
-(defvar *fields* '())
-
-(defun read-members (&optional (directory *directory*))
- (let* ((pathname (merge-pathnames "patches/dom1-interfaces.xml" directory))
- (library (dom:document-element (xml:parse-file pathname)))
- (methods '())
- (fields '()))
- (do-child-elements (interface library :name "interface")
- (do-child-elements (method interface :name "method")
- (let ((parameters (find-child-element "parameters" method)))
- (push (cons (dom:get-attribute method "name")
- (map-child-elements 'list
- (rcurry #'dom:get-attribute "name")
- parameters
- :name "param"))
- methods)))
- (do-child-elements (attribute interface :name "attribute")
- (push (dom:get-attribute attribute "name") fields)))
- (values methods fields)))
-
-
-;;;; Conditions uebersetzen
-
-(defun translate-condition (element)
- (string-case (dom:tag-name element)
- ("equals" (translate-equals element))
- ("contentType" (translate-content-type element))
- ("implementationAttribute" (assert-have-implementation-attribute element))
- ("isNull" (translate-is-null element))
- ("not" (translate-is-null element))
- ("notNull" (translate-not-null element))
- ("same" (translate-same element))
- (t (error "unknown condition: ~A" element))))
-
-(defun translate-equals (element)
- (with-attributes (|actual| |expected| |ignoreCase|) element
- `(,(if (parse-java-literal |ignoreCase|) 'string-equal 'string=)
- ,(%intern actual)
- ,(parse-java-literal expected))))
-
-(defun translate-same (element)
- (with-attributes (|actual| |expected|) element
- `(eql ,(%intern actual) ,(parse-java-literal expected))))
-
-(defun translate-instance-of (element)
- (with-attributes (|obj| |type|) element
- `(typep ,(%intern |obj|) ,(intern-dom |type|))))
-
-(defun translate-is-null (element)
- (with-attributes (|obj|) element
- `(null ,(%intern |obj|))))
-
-(defun translate-not-null (element)
- (with-attributes (|obj|) element
- (%intern |obj|)))
-
-(defun translate-content-type (element) ;XXX verstehe ich nicht
- (with-attributes (|type|) element
- `(equal ,(parse-java-literal |type|) "text/xml")))
-
-(defun translate-uri-equals (element)
- (with-attributes
- (|actual|
- |scheme| |path| |host| |file| |name| |query| |fragment| |isAbsolute|)
- element
- |isAbsolute|
- `(let ((uri ,(%intern |actual|)))
- (and (string-equalp ,|scheme| (net.uri:uri-scheme uri))
- (equal ,|host| (net.uri:uri-host uri))
- (equal ,|path| (net.uri:uri-path uri))
- (equal ,|file| "???")
- (equal ,|name| "???")
- (equal ,|query| (net.uri:uri-query uri))
- (equal ,|fragment| (net.uri:uri-fragment uri))
- ;; isabsolute
- nil))))
-
-
-;;;; Statements uebersetzen
-
-(defun translate-statement (element)
- (string-case (dom:tag-name element)
- ("append" (translate-append element))
- ("assertDOMException" (translate-assert-domexception element))
- ("assertEquals" (translate-assert-equals element))
- ("assertNotNull" (translate-assert-not-null element))
- ("assertInstanceOf" (translate-assert-instance-of element))
- ("assertNull" (translate-assert-null element))
- ("assertSame" (translate-assert-same element))
- ("assertSize" (translate-assert-size element))
- ("assertTrue" (translate-assert-true element))
- ("assertFalse" (translate-assert-true element))
- ("assertURIEquals" (translate-assert-uri-equals element))
- ("for-each" (translate-for-each element))
- ("fail" (translate-fail element))
- ("if" (translate-if element))
- ("increment" (translate-unary-assignment '+ element))
- ("decrement" (translate-unary-assignment '- element))
- ("load" (translate-load element))
- ("plus" (translate-binary-assignment '+ element))
- ("try" (translate-try element))
- ("while" (translate-while element))
- (t (translate-member element))))
-
-(defun translate-binary-assignment (fn element)
- (with-attributes (|var| |op1| |op2|) element
- `(maybe-setf ,(%intern |var|) (,fn ,(%intern |op1|) ,(%intern |op2|)))))
-
-(defun translate-unary-assignment (fn element)
- (with-attributes (|var| |value|) element
- `(maybe-setf ,(%intern |var|)
- (,fn ,(%intern |var|) ,(parse-java-literal |value|)))))
-
-(defun translate-load (load)
- (with-attributes (|var| |href| |willBeModified|) load
- `(maybe-setf ,(%intern |var|)
- (load-file ,|href| ,(parse-java-literal |willBeModified|)))))
-
-(defun translate-call (call method)
- (let ((name (car method))
- (args (mapcar (lambda (name)
- (parse-java-literal (dom:get-attribute call name)))
- (cdr method))))
- (with-attributes (|var| |obj|) call
- `(maybe-setf ,(%intern |var|) (,(intern-dom name) ,|obj| ,@args)))))
-
-(defun translate-get (call name)
- (with-attributes (|var| |obj|) call
- `(maybe-setf ,(%intern |var|) (,(intern-dom name) ,|obj|))))
-
-(defun translate-fail (element)
- (declare (ignore element))
- `(error "failed"))
-
-(defun translate-member (element)
- (let* ((name (dom:tag-name element))
- (method (find name *methods* :key #'car :test #'equal))
- (field (find name *fields* :test #'equal)))
- (cond
- (method (translate-call element method))
- (field (translate-get element field))
- (t (error "unknown element ~A" element)))))
-
-(defun translate-assert-equals (element)
- `(assert ,(translate-equals element)))
-
-(defun translate-assert-same (element)
- `(assert ,(translate-same element)))
-
-(defun translate-assert-null (element)
- (with-attributes (|actual|) element
- `(assert (null ,(%intern |actual|)))))
-
-(defun translate-assert-not-null (element)
- (with-attributes (|actual|) element
- `(assert ,(%intern |actual|))))
-
-(defun translate-assert-size (element)
- (with-attributes (|collection| |size|) element
- `(assert (eql (length ,(%intern |collection|)) ,(%intern |size|)))))
-
-(defun translate-assert-instance-of (element)
- `(assert ,(translate-instance-of element)))
-
-(defun translate-if (element)
- (destructuring-bind (condition &rest rest)
- (child-elements element)
- (let (then else)
- (dolist (r rest)
- (when (equal (dom:tag-name r) "else")
- (setf else (child-elements r))
- (return))
- (push r then))
- `(cond
- (,(translate-condition condition)
- ,@(mapcar #'translate-statement (reverse then)))
- (t
- ,@(mapcar #'translate-statement else))))))
-
-(defun translate-while (element)
- (destructuring-bind (condition &rest body)
- (child-elements element)
- `(loop
- while ,(translate-condition condition)
- do (progn ,@(mapcar #'translate-statement body)))))
-
-(defun translate-assert-domexception (element)
- (do-child-elements (c element)
- (unless (equal (dom:tag-name c) "metadata")
- (return
- `(progn
- ,@(translate-body c)
- ;; XXX haben noch keine Exceptions
- (error "expected exception ~A" (dom:tag-name element)))))))
-
-(defun translate-try (element)
- (map-child-elements 'list
- (lambda (c)
- (if (equal (dom:tag-name c) "catch")
- nil
- (translate-statement c)))
- element)
- ;; XXX haben noch keine Exceptions
- )
-
-(defun translate-append (element)
- (with-attributes (|collection| |item|) element
- (let ((c (%intern |collection|))
- (i (%intern |item|)))
- `(maybe-setf ,c (append ,c (list ,i))))))
-
-(defun translate-assert-true (element)
- (with-attributes (|actual|) element
- `(assert ,(%intern |actual|))))
-
-(defun translate-assert-false (element)
- (with-attributes (|actual|) element
- `(assert (not ,(%intern |actual|)))))
-
-(defun translate-assert-uri-equals (element)
- `(assert ,(translate-uri-equals element)))
-
-
-;;;; Tests uebersetzen
-
-(defun translate-body (element)
- (map-child-elements 'list #'translate-statement element))
-
-(defun translate-for-each (element)
- (with-attributes (|collection| |member|) element
- `(dolist (,(%intern |member|) ,(%intern |collection|))
- ,@(translate-body element))))
-
-(defun test (name &optional (directory *directory*))
- (let* ((test-directory (merge-pathnames "tests/level1/core/" directory)))
- (slurp-test
- (make-pathname :name name :type "xml" :defaults test-directory))))
-
-(defun assert-have-implementation-attribute (element)
- (string-case (dom:get-attribute element "name")
- (t
- (warn "implementationAttribute ~A not supported, skipping test"
- (dom:get-attribute element "name"))
- (throw 'give-up nil))))
-
-(defun slurp-test (pathname)
- (unless *fields*
- (multiple-value-setq (*methods* *fields*) (read-members *directory*)))
- (catch 'give-up
- (let* ((test (dom:document-element (xml:parse-file pathname)))
- title
- (variables '())
- (code '()))
- (do-child-elements (e test)
- (string-case (dom:tag-name e)
- ("metadata"
- (let ((title-element (find-child-element "title" e)))
- (setf title (dom:data (dom:first-child title-element)))))
- ("var"
- (push (%intern (dom:get-attribute e "name")) variables))
- ("implementationAttribute"
- (assert-have-implementation-attribute e))
- (t
- (push (translate-statement e) code))))
- `(defun ,(%intern (concatenate 'string "test-" title)) ()
- (let (,@variables)
- ,@(reverse code))))))
-
-(defun test2 (&optional verbose)
- (let* ((test-directory (merge-pathnames "tests/level1/core/" *directory*))
- (suite
- (dom:document-element
- (xml:parse-file (merge-pathnames "alltests.xml" test-directory))))
- (n 0)
- (i 0))
- (do-child-elements (member suite)
- (declare (ignore member))
- (incf n))
- (do-child-elements (member suite)
- (let ((href (dom:get-attribute member "href")))
- (format t "~&~D/~D ~A~%" i n href)
- (let ((lisp (slurp-test (merge-pathnames href test-directory))))
- (when verbose
- (print lisp))))
- (incf i))))
-
-#+(or)
-(test "attrname")
-
-#+(or)
-(read-methods)
-
-#+(or)
-(test2)
diff --git a/glisp/COPYING b/glisp/COPYING
deleted file mode 100644
index 243648d..0000000
--- a/glisp/COPYING
+++ /dev/null
@@ -1,521 +0,0 @@
-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.
-
-End of Document
-------------------------------------------------------------------------
- GNU LESSER GENERAL PUBLIC LICENSE
- Version 2.1, February 1999
-
- Copyright (C) 1991, 1999 Free Software Foundation, Inc.
- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-[This is the first released version of the Lesser GPL. It also counts
- as the successor of the GNU Library Public License, version 2, hence
- the version number 2.1.]
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-Licenses are intended to guarantee your freedom to share and change
-free software--to make sure the software is free for all its users.
-
- This license, the Lesser General Public License, applies to some
-specially designated software packages--typically libraries--of the
-Free Software Foundation and other authors who decide to use it. You
-can use it too, but we suggest you first think carefully about whether
-this license or the ordinary General Public License is the better
-strategy to use in any particular case, based on the explanations below.
-
- When we speak of free software, we are referring to freedom of use,
-not price. Our General Public Licenses are designed to make sure that
-you have the freedom to distribute copies of free software (and charge
-for this service if you wish); that you receive source code or can get
-it if you want it; that you can change the software and use pieces of
-it in new free programs; and that you are informed that you can do
-these things.
-
- To protect your rights, we need to make restrictions that forbid
-distributors to deny you these rights or to ask you to surrender these
-rights. These restrictions translate to certain responsibilities for
-you if you distribute copies of the library or if you modify it.
-
- For example, if you distribute copies of the library, whether gratis
-or for a fee, you must give the recipients all the rights that we gave
-you. You must make sure that they, too, receive or can get the source
-code. If you link other code with the library, you must provide
-complete object files to the recipients, so that they can relink them
-with the library after making changes to the library and recompiling
-it. And you must show them these terms so they know their rights.
-
- We protect your rights with a two-step method: (1) we copyright the
-library, and (2) we offer you this license, which gives you legal
-permission to copy, distribute and/or modify the library.
-
- To protect each distributor, we want to make it very clear that
-there is no warranty for the free library. Also, if the library is
-modified by someone else and passed on, the recipients should know
-that what they have is not the original version, so that the original
-author's reputation will not be affected by problems that might be
-introduced by others.
-
- Finally, software patents pose a constant threat to the existence of
-any free program. We wish to make sure that a company cannot
-effectively restrict the users of a free program by obtaining a
-restrictive license from a patent holder. Therefore, we insist that
-any patent license obtained for a version of the library must be
-consistent with the full freedom of use specified in this license.
-
- Most GNU software, including some libraries, is covered by the
-ordinary GNU General Public License. This license, the GNU Lesser
-General Public License, applies to certain designated libraries, and
-is quite different from the ordinary General Public License. We use
-this license for certain libraries in order to permit linking those
-libraries into non-free programs.
-
- When a program is linked with a library, whether statically or using
-a shared library, the combination of the two is legally speaking a
-combined work, a derivative of the original library. The ordinary
-General Public License therefore permits such linking only if the
-entire combination fits its criteria of freedom. The Lesser General
-Public License permits more lax criteria for linking other code with
-the library.
-
- We call this license the "Lesser" General Public License because it
-does Less to protect the user's freedom than the ordinary General
-Public License. It also provides other free software developers Less
-of an advantage over competing non-free programs. These disadvantages
-are the reason we use the ordinary General Public License for many
-libraries. However, the Lesser license provides advantages in certain
-special circumstances.
-
- For example, on rare occasions, there may be a special need to
-encourage the widest possible use of a certain library, so that it becomes
-a de-facto standard. To achieve this, non-free programs must be
-allowed to use the library. A more frequent case is that a free
-library does the same job as widely used non-free libraries. In this
-case, there is little to gain by limiting the free library to free
-software only, so we use the Lesser General Public License.
-
- In other cases, permission to use a particular library in non-free
-programs enables a greater number of people to use a large body of
-free software. For example, permission to use the GNU C Library in
-non-free programs enables many more people to use the whole GNU
-operating system, as well as its variant, the GNU/Linux operating
-system.
-
- Although the Lesser General Public License is Less protective of the
-users' freedom, it does ensure that the user of a program that is
-linked with the Library has the freedom and the wherewithal to run
-that program using a modified version of the Library.
-
- The precise terms and conditions for copying, distribution and
-modification follow. Pay close attention to the difference between a
-"work based on the library" and a "work that uses the library". The
-former contains code derived from the library, whereas the latter must
-be combined with the library in order to run.
-
- GNU LESSER GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License Agreement applies to any software library or other
-program which contains a notice placed by the copyright holder or
-other authorized party saying it may be distributed under the terms of
-this Lesser General Public License (also called "this License").
-Each licensee is addressed as "you".
-
- A "library" means a collection of software functions and/or data
-prepared so as to be conveniently linked with application programs
-(which use some of those functions and data) to form executables.
-
- The "Library", below, refers to any such software library or work
-which has been distributed under these terms. A "work based on the
-Library" means either the Library or any derivative work under
-copyright law: that is to say, a work containing the Library or a
-portion of it, either verbatim or with modifications and/or translated
-straightforwardly into another language. (Hereinafter, translation is
-included without limitation in the term "modification".)
-
- "Source code" for a work means the preferred form of the work for
-making modifications to it. For a library, complete source code means
-all the source code for all modules it contains, plus any associated
-interface definition files, plus the scripts used to control compilation
-and installation of the library.
-
- Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running a program using the Library is not restricted, and output from
-such a program is covered only if its contents constitute a work based
-on the Library (independent of the use of the Library in a tool for
-writing it). Whether that is true depends on what the Library does
-and what the program that uses the Library does.
-
- 1. You may copy and distribute verbatim copies of the Library's
-complete source code as you receive it, in any medium, provided that
-you conspicuously and appropriately publish on each copy an
-appropriate copyright notice and disclaimer of warranty; keep intact
-all the notices that refer to this License and to the absence of any
-warranty; and distribute a copy of this License along with the
-Library.
-
- You may charge a fee for the physical act of transferring a copy,
-and you may at your option offer warranty protection in exchange for a
-fee.
-
- 2. You may modify your copy or copies of the Library or any portion
-of it, thus forming a work based on the Library, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) The modified work must itself be a software library.
-
- b) You must cause the files modified to carry prominent notices
- stating that you changed the files and the date of any change.
-
- c) You must cause the whole of the work to be licensed at no
- charge to all third parties under the terms of this License.
-
- d) If a facility in the modified Library refers to a function or a
- table of data to be supplied by an application program that uses
- the facility, other than as an argument passed when the facility
- is invoked, then you must make a good faith effort to ensure that,
- in the event an application does not supply such function or
- table, the facility still operates, and performs whatever part of
- its purpose remains meaningful.
-
- (For example, a function in a library to compute square roots has
- a purpose that is entirely well-defined independent of the
- application. Therefore, Subsection 2d requires that any
- application-supplied function or table used by this function must
- be optional: if the application does not supply it, the square
- root function must still compute square roots.)
-
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Library,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Library, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote
-it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Library.
-
-In addition, mere aggregation of another work not based on the Library
-with the Library (or with a work based on the Library) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may opt to apply the terms of the ordinary GNU General Public
-License instead of this License to a given copy of the Library. To do
-this, you must alter all the notices that refer to this License, so
-that they refer to the ordinary GNU General Public License, version 2,
-instead of to this License. (If a newer version than version 2 of the
-ordinary GNU General Public License has appeared, then you can specify
-that version instead if you wish.) Do not make any other change in
-these notices.
-
- Once this change is made in a given copy, it is irreversible for
-that copy, so the ordinary GNU General Public License applies to all
-subsequent copies and derivative works made from that copy.
-
- This option is useful when you wish to copy part of the code of
-the Library into a program that is not a library.
-
- 4. You may copy and distribute the Library (or a portion or
-derivative of it, under Section 2) in object code or executable form
-under the terms of Sections 1 and 2 above provided that you accompany
-it with the complete corresponding machine-readable source code, which
-must be distributed under the terms of Sections 1 and 2 above on a
-medium customarily used for software interchange.
-
- If distribution of object code is made by offering access to copy
-from a designated place, then offering equivalent access to copy the
-source code from the same place satisfies the requirement to
-distribute the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
- 5. A program that contains no derivative of any portion of the
-Library, but is designed to work with the Library by being compiled or
-linked with it, is called a "work that uses the Library". Such a
-work, in isolation, is not a derivative work of the Library, and
-therefore falls outside the scope of this License.
-
- However, linking a "work that uses the Library" with the Library
-creates an executable that is a derivative of the Library (because it
-contains portions of the Library), rather than a "work that uses the
-library". The executable is therefore covered by this License.
-Section 6 states terms for distribution of such executables.
-
- When a "work that uses the Library" uses material from a header file
-that is part of the Library, the object code for the work may be a
-derivative work of the Library even though the source code is not.
-Whether this is true is especially significant if the work can be
-linked without the Library, or if the work is itself a library. The
-threshold for this to be true is not precisely defined by law.
-
- If such an object file uses only numerical parameters, data
-structure layouts and accessors, and small macros and small inline
-functions (ten lines or less in length), then the use of the object
-file is unrestricted, regardless of whether it is legally a derivative
-work. (Executables containing this object code plus portions of the
-Library will still fall under Section 6.)
-
- Otherwise, if the work is a derivative of the Library, you may
-distribute the object code for the work under the terms of Section 6.
-Any executables containing that work also fall under Section 6,
-whether or not they are linked directly with the Library itself.
-
- 6. As an exception to the Sections above, you may also combine or
-link a "work that uses the Library" with the Library to produce a
-work containing portions of the Library, and distribute that work
-under terms of your choice, provided that the terms permit
-modification of the work for the customer's own use and reverse
-engineering for debugging such modifications.
-
- You must give prominent notice with each copy of the work that the
-Library is used in it and that the Library and its use are covered by
-this License. You must supply a copy of this License. If the work
-during execution displays copyright notices, you must include the
-copyright notice for the Library among them, as well as a reference
-directing the user to the copy of this License. Also, you must do one
-of these things:
-
- a) Accompany the work with the complete corresponding
- machine-readable source code for the Library including whatever
- changes were used in the work (which must be distributed under
- Sections 1 and 2 above); and, if the work is an executable linked
- with the Library, with the complete machine-readable "work that
- uses the Library", as object code and/or source code, so that the
- user can modify the Library and then relink to produce a modified
- executable containing the modified Library. (It is understood
- that the user who changes the contents of definitions files in the
- Library will not necessarily be able to recompile the application
- to use the modified definitions.)
-
- b) Use a suitable shared library mechanism for linking with the
- Library. A suitable mechanism is one that (1) uses at run time a
- copy of the library already present on the user's computer system,
- rather than copying library functions into the executable, and (2)
- will operate properly with a modified version of the library, if
- the user installs one, as long as the modified version is
- interface-compatible with the version that the work was made with.
-
- c) Accompany the work with a written offer, valid for at
- least three years, to give the same user the materials
- specified in Subsection 6a, above, for a charge no more
- than the cost of performing this distribution.
-
- d) If distribution of the work is made by offering access to copy
- from a designated place, offer equivalent access to copy the above
- specified materials from the same place.
-
- e) Verify that the user has already received a copy of these
- materials or that you have already sent this user a copy.
-
- For an executable, the required form of the "work that uses the
-Library" must include any data and utility programs needed for
-reproducing the executable from it. However, as a special exception,
-the materials to be distributed need not include anything that is
-normally distributed (in either source or binary form) with the major
-components (compiler, kernel, and so on) of the operating system on
-which the executable runs, unless that component itself accompanies
-the executable.
-
- It may happen that this requirement contradicts the license
-restrictions of other proprietary libraries that do not normally
-accompany the operating system. Such a contradiction means you cannot
-use both them and the Library together in an executable that you
-distribute.
-
- 7. You may place library facilities that are a work based on the
-Library side-by-side in a single library together with other library
-facilities not covered by this License, and distribute such a combined
-library, provided that the separate distribution of the work based on
-the Library and of the other library facilities is otherwise
-permitted, and provided that you do these two things:
-
- a) Accompany the combined library with a copy of the same work
- based on the Library, uncombined with any other library
- facilities. This must be distributed under the terms of the
- Sections above.
-
- b) Give prominent notice with the combined library of the fact
- that part of it is a work based on the Library, and explaining
- where to find the accompanying uncombined form of the same work.
-
- 8. You may not copy, modify, sublicense, link with, or distribute
-the Library except as expressly provided under this License. Any
-attempt otherwise to copy, modify, sublicense, link with, or
-distribute the Library is void, and will automatically terminate your
-rights under this License. However, parties who have received copies,
-or rights, from you under this License will not have their licenses
-terminated so long as such parties remain in full compliance.
-
- 9. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Library or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Library (or any work based on the
-Library), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Library or works based on it.
-
- 10. Each time you redistribute the Library (or any work based on the
-Library), the recipient automatically receives a license from the
-original licensor to copy, distribute, link with or modify the Library
-subject to these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties with
-this License.
-
- 11. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Library at all. For example, if a patent
-license would not permit royalty-free redistribution of the Library by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Library.
-
-If any portion of this section is held invalid or unenforceable under any
-particular circumstance, the balance of the section is intended to apply,
-and the section as a whole is intended to apply in other circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
- 12. If the distribution and/or use of the Library is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Library under this License may add
-an explicit geographical distribution limitation excluding those countries,
-so that distribution is permitted only in or among countries not thus
-excluded. In such case, this License incorporates the limitation as if
-written in the body of this License.
-
- 13. The Free Software Foundation may publish revised and/or new
-versions of the Lesser General Public License from time to time.
-Such new versions will be similar in spirit to the present version,
-but may differ in detail to address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Library
-specifies a version number of this License which applies to it and
-"any later version", you have the option of following the terms and
-conditions either of that version or of any later version published by
-the Free Software Foundation. If the Library does not specify a
-license version number, you may choose any version ever published by
-the Free Software Foundation.
-
- 14. If you wish to incorporate parts of the Library into other free
-programs whose distribution conditions are incompatible with these,
-write to the author to ask for permission. For software which is
-copyrighted by the Free Software Foundation, write to the Free
-Software Foundation; we sometimes make exceptions for this. Our
-decision will be guided by the two goals of preserving the free status
-of all derivatives of our free software and of promoting the sharing
-and reuse of software generally.
-
- NO WARRANTY
-
- 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
-WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
-EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
-OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
-KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
-LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
-THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
- 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
-WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
-AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
-FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
-CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
-LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
-RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
-FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
-SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
-DAMAGES.
-
- END OF TERMS AND CONDITIONS
-
diff --git a/glisp/characters.lisp b/glisp/characters.lisp
deleted file mode 100644
index ace440e..0000000
--- a/glisp/characters.lisp
+++ /dev/null
@@ -1,132 +0,0 @@
-;;; copyright (c) 2004 knowledgeTools Int. GmbH
-;;; Author of this version: David Lichteblau
-;;;
-;;; License: LGPL (See file COPYING for details).
-;;;
-;;; derived from runes.lisp, (c) copyright 1998,1999 by Gilbert Baumann
-
-(in-package :glisp)
-
-(deftype rune () 'base-char)
-(deftype rod () 'base-string)
-(deftype simple-rod () 'simple-string)
-
-(defsubst rune (rod index)
- (char rod index))
-
-(defun (setf rune) (new rod index)
- (setf (char rod index) new))
-
-(defsubst %rune (rod index)
- (aref (the simple-string rod) (the fixnum index)))
-
-(defsubst (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))
-
-(defsubst rune= (x y)
- (char= x y))
-
-(defun rune-downcase (rune)
- (char-downcase rune))
-
-(defsubst rune-upcase (rune)
- (char-upcase rune))
-
-(defun rune-upper-case-letter-p (rune)
- (upper-case-p rune))
-
-(defun rune-lower-case-letter-p (rune)
- (lower-case-p rune))
-
-(defun rune-equal (x y)
- (char-equal x y))
-
-(defun rod-downcase (rod)
- (string-downcase rod))
-
-(defun rod-upcase (rod)
- (string-upcase rod))
-
-(defsubst 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))
- (digit-char-p char radix))
-
-(defun rod (x)
- (cond
- ((stringp x) x)
- ((symbolp x) (string x))
- ((characterp x) (string x))
- ((vectorp x) (coerce x 'string))
- ((integerp x) (string (code-char x)))
- (t (error "Cannot convert ~S to a ~S" x 'rod))))
-
-(defun runep (x)
- (characterp x))
-
-(defun sloopy-rod-p (x)
- (stringp x))
-
-(defun rod= (x y)
- (string= x y))
-
-(defun rod-equal (x y)
- (string-equal x y))
-
-(defsubst make-rod (size)
- (make-string size))
-
-(defun char-rune (char)
- char)
-
-(defun rune-char (rune &optional default)
- (declare (ignore default))
- rune)
-
-(defun rod-string (rod &optional (default-char #\?))
- (declare (ignore default-char))
- rod)
-
-(defun string-rod (string)
- string)
-
-;;;;
-
-(defun rune<= (rune &rest more-runes)
- (loop
- for (a b) on (cons rune more-runes)
- while b
- always (char<= a b)))
-
-(defun rune>= (rune &rest more-runes)
- (loop
- for (a b) on (cons rune more-runes)
- while b
- always (char>= a b)))
-
-(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))
- (subseq source start end))
-
-(defun rod-subseq* (source start &optional (end (length source)))
- (rod-subseq source start end))
-
-(defun rod< (rod1 rod2)
- (string< rod1 rod2))
diff --git a/glisp/dep-acl.lisp b/glisp/dep-acl.lisp
deleted file mode 100644
index 5c953cf..0000000
--- a/glisp/dep-acl.lisp
+++ /dev/null
@@ -1,127 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: ACL-4.3 dependent stuff + fixups
-;;; Created: 1999-05-25 22:33
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1998,1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(export 'glisp::read-byte-sequence :glisp)
-(export 'glisp::read-char-sequence :glisp)
-(export 'glisp::run-unix-shell-command :glisp)
-(export 'glisp::mp/process-run-function :glisp)
-(export 'glisp::mp/process-kill :glisp)
-(export 'glisp::mp/seize-lock :glisp)
-(export 'glisp::mp/release-lock :glisp)
-(export 'glisp::mp/transfer-lock-owner :glisp)
-(export 'glisp::mp/current-process :glisp)
-(export 'glisp::mp/process-yield :glisp)
-(export 'glisp::mp/process-wait :glisp)
-(export 'glisp::getenv :glisp)
-
-(defun glisp::read-byte-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-(defun glisp::read-char-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-#+ALLEGRO-V5.0
-(defun glisp::open-inet-socket (hostname port)
- (values
- (socket:make-socket :remote-host hostname
- :remote-port port
- :format :binary)
- :byte))
-
-#-ALLEGRO-V5.0
-(defun glisp::open-inet-socket (hostname port)
- (values
- (ipc:open-network-stream :host hostname
- :port port
- :element-type '(unsigned-byte 8)
- :class 'EXCL::BIDIRECTIONAL-BINARY-SOCKET-STREAM)
- :byte))
-
-#||
-(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
-)
-||#
-
-(defun glisp::mp/make-lock (&key name)
- (mp:make-process-lock :name name))
-
-(defmacro glisp::mp/with-lock ((lock) &body body)
- `(mp:with-process-lock (,lock)
- ,@body))
-
-(defmacro glisp::with-timeout ((&rest options) &body body)
- `(mp:with-timeout ,options . ,body))
-
-(defun glisp::g/make-string (length &rest options)
- (apply #'make-array length :element-type 'base-char options))
-
-(defun glisp:run-unix-shell-command (cmd)
- (excl:shell cmd))
-
-(defun glisp:mp/process-run-function (name fn &rest args)
- (apply #'mp:process-run-function name fn args))
-
-(defun glisp:mp/process-kill (proc)
- (mp:process-kill proc))
-
-(defun glisp:mp/current-process ()
- sys:*current-process*)
-
-(defun glisp::mp/seize-lock (lock &key whostate)
- whostate
- (mp:process-lock lock))
-
-(defun glisp::mp/transfer-lock-owner (lock old-process new-process)
- (assert (eql (mp:process-lock-locker lock) old-process))
- (setf (mp:process-lock-locker lock) new-process)
- )
-
-(defun glisp::mp/release-lock (lock)
- (mp:process-unlock lock))
-
-(defun glisp::mp/process-yield (&optional process-to-run)
- (mp:process-allow-schedule process-to-run))
-
-(defun glisp::mp/process-wait (whostate predicate)
- (mp:process-wait whostate predicate))
-
-;; ACL is incapable to define compiler macros on (setf foo)
-;; Unfortunately it is also incapable to declaim such functions inline.
-;; So we revoke the DEFUN hack from dep-gcl here.
-
-(defmacro glisp::defsubst (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))
- (glisp::defsubst ,fnam ,args .,body)))
- `(progn
- (defun ,fun ,args .,body)
- (define-compiler-macro ,fun (&rest .args.)
- (cons '(lambda ,args .,body)
- .args.)))))
-
-
-(defun glisp::getenv (string)
- (sys:getenv string))
diff --git a/glisp/dep-acl5.lisp b/glisp/dep-acl5.lisp
deleted file mode 100644
index 1335ee4..0000000
--- a/glisp/dep-acl5.lisp
+++ /dev/null
@@ -1,162 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; Encoding: utf-8; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: ACL-5.0 dependent stuff + fixups
-;;; Created: 1999-05-25 22:32
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1998,1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-;;; Changes
-;;; =======
-
-;;; When Who What
-;;; ---------------------------------------------------------------------------
-;;; 2002-01-04 GB spend BLOCK for DEFSUBST
-;;; 1999-08-31 SES Stig Erik Sandø
-;;;
-;;; Changed #+allegro-v5.0 to
-;;; #+(and allegro-version>= (version>= 5))
-;;;
-
-(export 'glisp::read-byte-sequence :glisp)
-(export 'glisp::read-char-sequence :glisp)
-(export 'glisp::run-unix-shell-command :glisp)
-(export 'glisp::mp/process-run-function :glisp)
-(export 'glisp::mp/process-kill :glisp)
-(export 'glisp::mp/current-process :glisp)
-(export 'glisp::mp/seize-lock :glisp)
-(export 'glisp::mp/release-lock :glisp)
-(export 'glisp::mp/process-yield :glisp)
-(export 'glisp::mp/process-wait :glisp)
-(export 'glisp::getenv :glisp)
-
-(export 'glisp::make-server-socket :glisp)
-
-(defun glisp::mp/seize-lock (lock &key whostate)
- whostate
- (mp:process-lock lock))
-
-(defun glisp::mp/release-lock (lock)
- (mp:process-unlock lock))
-
-(defun glisp::read-byte-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-(defun glisp::read-char-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-#+(and allegro-version>= (version>= 5))
-(defun glisp::open-inet-socket (hostname port)
- (values
- (socket:make-socket :remote-host hostname
- :remote-port port
- :format :binary)
- :byte))
-
-(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
- (socket:make-socket :connect :passive
- :local-port port
- :format (cond ((subtypep element-type '(unsigned-byte 8))
- :binary)
- ((subtypep element-type 'character)
- :text)
- (t
- (error "Unknown element type: ~S." element-type)))))
-
-(defun glisp::accept-connection/low (socket)
- (values
- (socket:accept-connection socket :wait t)
- :byte))
-
-
-#-(and allegro-version>= (version>= 5))
-(defun glisp::open-inet-socket (hostname port)
- (values
- (ipc:open-network-stream :host hostname
- :port port
- :element-type '(unsigned-byte 8)
- :class 'EXCL::BIDIRECTIONAL-BINARY-SOCKET-STREAM)
- :byte))
-
-(defun glisp::mp/make-lock (&key name)
- (mp:make-process-lock :name name))
-
-(defmacro glisp::mp/with-lock ((lock) &body body)
- `(mp:with-process-lock (,lock)
- ,@body))
-
-(defmacro glisp::with-timeout ((&rest options) &body body)
- `(mp:with-timeout ,options . ,body))
-
-(defun glisp::g/make-string (length &rest options)
- (apply #'make-array length :element-type 'base-char options))
-
-(defun glisp:run-unix-shell-command (cmd)
- (excl:shell cmd))
-
-(defparameter glisp::*inherited-vars*
- '(*terminal-io* *standard-input* *standard-output* *error-output* *trace-output* *query-io* *debug-io*))
-
-(defparameter glisp::*inherited-vars* nil)
-
-(defun glisp:mp/process-run-function (name fn &rest args)
- (mp:process-run-function
- name
- (lambda (vars vals fn args)
- (progv vars vals
- (apply fn args)))
- glisp::*inherited-vars* (mapcar #'symbol-value glisp::*inherited-vars*)
- fn args))
-
-(defun glisp:mp/current-process ()
- sys:*current-process*)
-
-(defun glisp::mp/process-yield (&optional process-to-run)
- (mp:process-allow-schedule process-to-run))
-
-(defun glisp::mp/process-wait (whostate predicate)
- (mp:process-wait whostate predicate))
-
-(defun glisp::mp/process-kill (proc)
- (mp:process-kill proc))
-
-;; ACL is incapable to define compiler macros on (setf foo)
-;; Unfortunately it is also incapable to declaim such functions inline.
-;; So we revoke the DEFUN hack from dep-gcl here.
-
-(defmacro glisp::defsubst (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))
- (glisp::defsubst ,fnam ,args .,body)))
- (labels ((declp (x)
- (and (consp x) (eq (car x) 'declare))))
- `(progn
- (defun ,fun ,args .,body)
- (define-compiler-macro ,fun (&rest .args.)
- (cons '(lambda ,args
- ,@(remove-if-not #'declp body)
- (block ,fun
- ,@(remove-if #'declp body)))
- .args.))))))
-
-
-(defun glisp::getenv (string)
- (sys:getenv string))
\ No newline at end of file
diff --git a/glisp/dep-clisp.lisp b/glisp/dep-clisp.lisp
deleted file mode 100644
index af740f5..0000000
--- a/glisp/dep-clisp.lisp
+++ /dev/null
@@ -1,176 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: CLISP dependent stuff + fixups
-;;; Created: 1999-05-25 22:32
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(in-package :CL-USER)
-
-(eval-when (compile load eval)
- (if (fboundp 'cl::define-compiler-macro)
- (pushnew 'define-compiler-macro *features*)))
-
-(setq lisp:*load-paths* '(#P"./"))
-
-(import 'lisp:read-byte-sequence :glisp)
-(export 'lisp:read-byte-sequence :glisp)
-(import 'lisp:read-char-sequence :glisp)
-(export 'lisp:read-char-sequence :glisp)
-(export 'glisp::compile-file :glisp)
-(export 'glisp::run-unix-shell-command :glisp)
-(export 'glisp::make-server-socket :glisp)
-
-
-#||
-(export 'glisp::read-byte-sequence :glisp)
-(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
- (let (c (i start))
- (loop
- (cond ((= i end) (return i)))
- (setq c (read-byte input nil :eof))
- (cond ((eql c :eof) (return i)))
- (setf (aref sequence i) c)
- (incf i) )))
-||#
-
-
-(defun glisp::compile-file (&rest ap)
- (and (apply #'compile-file ap)
- (apply #'compile-file-pathname ap)))
-
-(defmacro glisp::with-timeout ((&rest ignore) &body body)
- (declare (ignore ignore))
- `(progn
- ,@body))
-
-(defun glisp::open-inet-socket (hostname port)
- (values
- (lisp:socket-connect port hostname)
- :byte))
-
-(defun glisp:make-server-socket (port)
- (lisp:socket-server port))
-
-(defun glisp::accept-connection/low (socket)
- (let ((stream (lisp:socket-accept socket)))
- (setf (stream-element-type stream) '(unsigned-byte 8))
- (values
- stream
- :byte)))
-
-(defun glisp::g/make-string (length &rest options)
- (apply #'make-array length
- :element-type
- '#.(cond ((stringp (make-array 1 :element-type 'string-char))
- 'string-char)
- ((stringp (make-array 1 :element-type 'base-char))
- 'base-char)
- (t
- (error "What is the string element type of the day?")))
- options))
-
-(defun glisp:run-unix-shell-command (command)
- (lisp:shell command))
-
-#+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 'glisp::define-compiler-macro :glisp)
- (defmacro glisp::define-compiler-macro (name args &body body)
- (declare (ignore args body))
- `(progn
- ',name)))
-
-#||
-(defun xlib:draw-glyph (drawable gcontext x y elt &rest more)
- (apply #'xlib:draw-glyphs drawable gcontext x y (vector elt) more))
-||#
-
-(defmacro glisp::defsubst (name args &body body)
- `(progn
- (declaim (inline ,name))
- (defun ,name ,args .,body)))
-
-(export 'glisp::getenv :glisp)
-(defun glisp::getenv (var)
- (sys::getenv var))
-
-
-
-(export 'glisp::mp/process-run-function :glisp)
-(defun glisp:mp/process-run-function (name fn &rest args)
- (apply #'mp:process-run-function name fn args))
-
-(export 'glisp::mp/process-kill :glisp)
-(defun glisp:mp/process-kill (proc)
- (mp:process-kill proc))
-
-(export 'glisp::mp/current-process :glisp)
-(defun glisp:mp/current-process ()
- (mp:current-process))
-
-(export 'glisp::mp/seize-lock :glisp)
-(defun glisp::mp/seize-lock (lock &key whostate)
- whostate
- (mp:process-lock lock))
-
-(export 'glisp::mp/release-lock :glisp)
-(defun glisp::mp/release-lock (lock)
- (mp:process-unlock lock))
-
-(export 'glisp::mp/process-yield :glisp)
-(defun glisp::mp/process-yield (&optional process-to-run)
- process-to-run
- (mp:process-allow-schedule))
-
-(export 'glisp::mp/process-wait :glisp)
-(defun glisp::mp/process-wait (whostate predicate)
- (mp::process-wait whostate predicate))
-
-(defmacro glisp::mp/with-lock ((lock) &body body)
- `(mp:with-process-lock (,lock)
- ,@body))
-
-(defun glisp::mp/make-lock (&key name)
- (mp:make-process-lock :name name))
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/glisp/dep-cmucl-dtc.lisp b/glisp/dep-cmucl-dtc.lisp
deleted file mode 100644
index a99171a..0000000
--- a/glisp/dep-cmucl-dtc.lisp
+++ /dev/null
@@ -1,212 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: CMUCL dependent stuff + fixups
-;;; Created: 1999-05-25 22:32
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(export 'glisp::read-byte-sequence :glisp)
-(export 'glisp::read-char-sequence :glisp)
-(export 'glisp::run-unix-shell-command :glisp)
-
-(export 'glisp::getenv :glisp)
-
-(defun glisp::read-byte-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-(defun glisp::read-char-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
- (let (c (i start))
- (loop
- (cond ((= i end) (return i)))
- (setq c (read-byte input nil :eof))
- (cond ((eql c :eof) (return i)))
- (setf (aref sequence i) c)
- (incf i) )))
-
-(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
- (let ((r (read-sequence sequence input :start start :end end)))
- (cond ((and (= r start) (> end start))
- (let ((byte (read-byte input nil :eof)))
- (cond ((eq byte :eof)
- r)
- (t
- (setf (aref sequence start) byte)
- (incf start)
- (if (> end start)
- (glisp::read-byte-sequence sequence input :start start :end end)
- start)))))
- (t
- r))))
-
-#||
-(defun glisp::read-char-sequence (sequence input &key (start 0) (end (length sequence)))
- (let (c (i start))
- (loop
- (cond ((= i end) (return i)))
- (setq c (read-byte input nil :eof))
- (cond ((eql c :eof) (return i)))
- (setf (aref sequence i) c)
- (incf i) )))
-||#
-
-(defmacro glisp::with-timeout ((&rest ignore) &body body)
- (declare (ignore ignore))
- `(progn
- ,@body))
-
-(defun glisp::open-inet-socket (hostname port)
- (let ((fd (extensions:connect-to-inet-socket hostname port)))
- (values
- (sys:make-fd-stream fd
- :input t
- :output t
- :element-type '(unsigned-byte 8)
- :name (format nil "Network connection to ~A:~D" hostname port))
- :byte)))
-
-(defun glisp::g/make-string (length &rest options)
- (apply #'make-array length :element-type 'base-char options))
-
-#||
-
-RUN-PROGRAM is an external symbol in the EXTENSIONS package.
-Function: #
-Function arguments:
- (program args &key (env *environment-list*) (wait t) pty input
- if-input-does-not-exist output (if-output-exists :error) (error :output)
- (if-error-exists :error) status-hook)
-Function documentation:
- Run-program creates a new process and runs the unix progam in the
- file specified by the simple-string program. Args are the standard
- arguments that can be passed to a Unix program, for no arguments
- use NIL (which means just the name of the program is passed as arg 0).
-
- Run program will either return NIL or a PROCESS structure. See the CMU
- Common Lisp Users Manual for details about the PROCESS structure.
-
- The keyword arguments have the following meanings:
- :env -
- An A-LIST mapping keyword environment variables to simple-string
- values.
- :wait -
- If non-NIL (default), wait until the created process finishes. If
- NIL, continue running Lisp until the program finishes.
- :pty -
- Either T, NIL, or a stream. Unless NIL, the subprocess is established
- under a PTY. If :pty is a stream, all output to this pty is sent to
- this stream, otherwise the PROCESS-PTY slot is filled in with a stream
- connected to pty that can read output and write input.
- :input -
- Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
- input for the current process is inherited. If NIL, /dev/null
- is used. If a pathname, the file so specified is used. If a stream,
- all the input is read from that stream and send to the subprocess. If
- :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
- its output to the process. Defaults to NIL.
- :if-input-does-not-exist (when :input is the name of a file) -
- can be one of:
- :error - generate an error.
- :create - create an empty file.
- nil (default) - return nil from run-program.
- :output -
- Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
- output for the current process is inherited. If NIL, /dev/null
- is used. If a pathname, the file so specified is used. If a stream,
- all the output from the process is written to this stream. If
- :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
- be read to get the output. Defaults to NIL.
- :if-output-exists (when :input is the name of a file) -
- can be one of:
- :error (default) - generates an error if the file already exists.
- :supersede - output from the program supersedes the file.
- :append - output from the program is appended to the file.
- nil - run-program returns nil without doing anything.
- :error and :if-error-exists -
- Same as :output and :if-output-exists, except that :error can also be
- specified as :output in which case all error output is routed to the
- same place as normal output.
- :status-hook -
- This is a function the system calls whenever the status of the
- process changes. The function takes the process as an argument.
-Its defined argument types are:
- (T T &KEY (:ENV T) (:WAIT T) (:PTY T) (:INPUT T) (:IF-INPUT-DOES-NOT-EXIST T)
- (:OUTPUT T) (:IF-OUTPUT-EXISTS T) (:ERROR T) (:IF-ERROR-EXISTS T)
- (:STATUS-HOOK T))
-Its result type is:
- (OR EXTENSIONS::PROCESS NULL)
-On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from:
-target:code/run-program.lisp
- Created: Saturday, 6/20/98 07:13:08 pm [-1]
- Comment: $Header: /home/david/gitconversion/cvsroot/cxml/glisp/Attic/dep-cmucl-dtc.lisp,v 1.1 2005-03-13 18:02:10 david Exp $
-||#
-
-;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil))
-
-(defun glisp:run-unix-shell-command (command)
- (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil)))
-
-(defmacro glisp::defsubst (name args &body body)
- `(progn
- (declaim (inline ,name))
- (defun ,name ,args .,body)))
-
-
-;;; MP
-
-(export 'glisp::mp/process-yield :glisp)
-(export 'glisp::mp/process-wait :glisp)
-(export 'glisp::mp/process-run-function :glisp)
-(export 'glisp::mp/make-lock :glisp)
-(export 'glisp::mp/current-process :glisp)
-(export 'glisp::mp/process-kill :glisp)
-
-(defun glisp::mp/make-lock (&key name)
- (pthread::make-lock name))
-
-(defmacro glisp::mp/with-lock ((lock) &body body)
- `(pthread::with-lock-held (,lock)
- ,@body))
-
-(defun glisp::mp/process-yield (&optional process-to-run)
- (declare (ignore process-to-run))
- (PTHREAD:SCHED-YIELD))
-
-(defun glisp::mp/process-wait (whostate predicate)
- (do ()
- ((funcall predicate))
- (sleep .1)))
-
-(defun glisp::mp/process-run-function (name fun &rest args)
- (pthread::thread-create
- (lambda ()
- (apply fun args))
- :name name))
-
-(defun glisp::mp/current-process ()
- 'blah)
-
-(defun glisp::mp/process-kill (process)
- (warn "*** Define GLISP:MP/PROCESS-KILL for CMUCL."))
-
-(defun glisp::getenv (string)
- (cdr (assoc string ext:*environment-list* :test #'string-equal)))
-
diff --git a/glisp/dep-cmucl.lisp b/glisp/dep-cmucl.lisp
deleted file mode 100644
index 85b24cd..0000000
--- a/glisp/dep-cmucl.lisp
+++ /dev/null
@@ -1,241 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: CMUCL dependent stuff + fixups
-;;; Created: 1999-05-25 22:32
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(export 'glisp::read-byte-sequence :glisp)
-(export 'glisp::read-char-sequence :glisp)
-(export 'glisp::run-unix-shell-command :glisp)
-
-(export 'glisp::getenv :glisp)
-
-(export 'glisp::make-server-socket :glisp)
-(export 'glisp::close-server-socket :glisp)
-
-(defun glisp::read-byte-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-(defun glisp::read-char-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
- (let (c (i start))
- (loop
- (cond ((= i end) (return i)))
- (setq c (read-byte input nil :eof))
- (cond ((eql c :eof) (return i)))
- (setf (aref sequence i) c)
- (incf i) )))
-
-(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
- (let ((r (read-sequence sequence input :start start :end end)))
- (cond ((and (= r start) (> end start))
- (let ((byte (read-byte input nil :eof)))
- (cond ((eq byte :eof)
- r)
- (t
- (setf (aref sequence start) byte)
- (incf start)
- (if (> end start)
- (glisp::read-byte-sequence sequence input :start start :end end)
- start)))))
- (t
- r))))
-
-#||
-(defun glisp::read-char-sequence (sequence input &key (start 0) (end (length sequence)))
- (let (c (i start))
- (loop
- (cond ((= i end) (return i)))
- (setq c (read-byte input nil :eof))
- (cond ((eql c :eof) (return i)))
- (setf (aref sequence i) c)
- (incf i) )))
-||#
-
-(defmacro glisp::with-timeout ((&rest ignore) &body body)
- (declare (ignore ignore))
- `(progn
- ,@body))
-
-(defun glisp::open-inet-socket (hostname port)
- (let ((fd (extensions:connect-to-inet-socket hostname port)))
- (values
- (sys:make-fd-stream fd
- :input t
- :output t
- :element-type '(unsigned-byte 8)
- :name (format nil "Network connection to ~A:~D" hostname port))
- :byte)))
-
-(defstruct (server-socket (:constructor make-server-socket-struct))
- fd
- element-type
- port)
-
-(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
- (make-server-socket-struct :fd (ext:create-inet-listener port)
- :element-type element-type
- :port port))
-
-(defun glisp::accept-connection/low (socket)
- (mp:process-wait-until-fd-usable (server-socket-fd socket) :input)
- (values
- (sys:make-fd-stream (ext:accept-tcp-connection (server-socket-fd socket))
- :input t :output t
- :element-type (server-socket-element-type socket))
- (cond ((subtypep (server-socket-element-type socket) 'integer)
- :byte)
- (t
- :char))))
-
-(defun glisp::close-server-socket (socket)
- (unix:unix-close (server-socket-fd socket)))
-
-;;;;;;
-
-(defun glisp::g/make-string (length &rest options)
- (apply #'make-array length :element-type 'base-char options))
-
-
-
-#||
-
-RUN-PROGRAM is an external symbol in the EXTENSIONS package.
-Function: #
-Function arguments:
- (program args &key (env *environment-list*) (wait t) pty input
- if-input-does-not-exist output (if-output-exists :error) (error :output)
- (if-error-exists :error) status-hook)
-Function documentation:
- Run-program creates a new process and runs the unix progam in the
- file specified by the simple-string program. Args are the standard
- arguments that can be passed to a Unix program, for no arguments
- use NIL (which means just the name of the program is passed as arg 0).
-
- Run program will either return NIL or a PROCESS structure. See the CMU
- Common Lisp Users Manual for details about the PROCESS structure.
-
- The keyword arguments have the following meanings:
- :env -
- An A-LIST mapping keyword environment variables to simple-string
- values.
- :wait -
- If non-NIL (default), wait until the created process finishes. If
- NIL, continue running Lisp until the program finishes.
- :pty -
- Either T, NIL, or a stream. Unless NIL, the subprocess is established
- under a PTY. If :pty is a stream, all output to this pty is sent to
- this stream, otherwise the PROCESS-PTY slot is filled in with a stream
- connected to pty that can read output and write input.
- :input -
- Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
- input for the current process is inherited. If NIL, /dev/null
- is used. If a pathname, the file so specified is used. If a stream,
- all the input is read from that stream and send to the subprocess. If
- :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
- its output to the process. Defaults to NIL.
- :if-input-does-not-exist (when :input is the name of a file) -
- can be one of:
- :error - generate an error.
- :create - create an empty file.
- nil (default) - return nil from run-program.
- :output -
- Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
- output for the current process is inherited. If NIL, /dev/null
- is used. If a pathname, the file so specified is used. If a stream,
- all the output from the process is written to this stream. If
- :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
- be read to get the output. Defaults to NIL.
- :if-output-exists (when :input is the name of a file) -
- can be one of:
- :error (default) - generates an error if the file already exists.
- :supersede - output from the program supersedes the file.
- :append - output from the program is appended to the file.
- nil - run-program returns nil without doing anything.
- :error and :if-error-exists -
- Same as :output and :if-output-exists, except that :error can also be
- specified as :output in which case all error output is routed to the
- same place as normal output.
- :status-hook -
- This is a function the system calls whenever the status of the
- process changes. The function takes the process as an argument.
-Its defined argument types are:
- (T T &KEY (:ENV T) (:WAIT T) (:PTY T) (:INPUT T) (:IF-INPUT-DOES-NOT-EXIST T)
- (:OUTPUT T) (:IF-OUTPUT-EXISTS T) (:ERROR T) (:IF-ERROR-EXISTS T)
- (:STATUS-HOOK T))
-Its result type is:
- (OR EXTENSIONS::PROCESS NULL)
-On Wednesday, 7/1/98 12:48:51 pm [-1] it was compiled from:
-target:code/run-program.lisp
- Created: Saturday, 6/20/98 07:13:08 pm [-1]
- Comment: $Header: /home/david/gitconversion/cvsroot/cxml/glisp/Attic/dep-cmucl.lisp,v 1.1 2005-03-13 18:02:10 david Exp $
-||#
-
-;; (process-exit-code (run-program "/bin/sh" (list "-c" "ls") :wait t :input nil :output nil))
-
-(defun glisp:run-unix-shell-command (command)
- (ext:process-exit-code (ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil :output nil)))
-
-(defmacro glisp::defsubst (name args &body body)
- `(progn
- (declaim (inline ,name))
- (defun ,name ,args .,body)))
-
-
-;;; MP
-
-(export 'glisp::mp/process-yield :glisp)
-(export 'glisp::mp/process-wait :glisp)
-(export 'glisp::mp/process-run-function :glisp)
-(export 'glisp::mp/make-lock :glisp)
-(export 'glisp::mp/current-process :glisp)
-(export 'glisp::mp/process-kill :glisp)
-
-(defun glisp::mp/make-lock (&key name)
- (mp:make-lock name))
-
-(defmacro glisp::mp/with-lock ((lock) &body body)
- `(mp:with-lock-held (,lock)
- ,@body))
-
-(defun glisp::mp/process-yield (&optional process-to-run)
- (declare (ignore process-to-run))
- (mp:process-yield))
-
-(defun glisp::mp/process-wait (whostate predicate)
- (mp:process-wait whostate predicate))
-
-(defun glisp::mp/process-run-function (name fun &rest args)
- (mp:make-process
- (lambda ()
- (apply fun args))
- :name name))
-
-(defun glisp::mp/current-process ()
- mp:*current-process*)
-
-(defun glisp::mp/process-kill (process)
- (mp:destroy-process process))
-
-(defun glisp::getenv (string)
- (cdr (assoc string ext:*environment-list* :test #'string-equal)))
-
diff --git a/glisp/dep-gcl-2.lisp b/glisp/dep-gcl-2.lisp
deleted file mode 100644
index 5fcd8d5..0000000
--- a/glisp/dep-gcl-2.lisp
+++ /dev/null
@@ -1,93 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Second part of GCL dependent stuff
-;;; Created: 1999-05-25 22:31
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(in-package :GLISP)
-
-(lisp::clines
- "#include "
- "#include "
- "#include "
- "#include "
- "#include "
- "#include "
- "#include "
- "#include "
- )
-
-(lisp::defcfun "static object open_inet_socket_aux (object x, object y, char *hostname, int port)" 2
- "FILE *fp;"
- "object stream;"
-
- "struct hostent *hostinfo;"
- "struct sockaddr_in addr;"
- "int sock;"
- "vs_mark;"
-
- "hostinfo = gethostbyname (hostname);"
-
- "if (hostinfo == 0)"
- "{"
- " return Cnil;"
- "}"
-
- "addr.sin_family = AF_INET;"
- "addr.sin_port = htons (port);"
- "addr.sin_addr = *(struct in_addr*) hostinfo->h_addr;"
- ""
- "sock = socket (PF_INET, SOCK_STREAM, 0);"
- "if (sock < 0)"
- " return Cnil;"
- ""
- "if (connect (sock, (struct sockaddr *) &addr, sizeof (addr)) != 0)"
- "{"
- " close (sock);"
- " return Cnil;"
- "}"
-
-
- "fp = fdopen (sock, \"rb+\");"
- "stream = (object) alloc_object(t_stream);"
- "stream->sm.sm_mode = (short)smm_io;"
- "stream->sm.sm_fp = fp;"
- "stream->sm.sm_object0 = x;"
- "stream->sm.sm_object1 = y;"
- "stream->sm.sm_int0 = stream->sm.sm_int1 = 0;"
- "vs_push(stream);"
- "setup_stream_buffer(stream);"
- "vs_reset;"
- "return stream;"
- )
-
-(lisp::defentry open-inet-socket-aux (lisp::object lisp::object lisp::string lisp::int)
- (lisp::object "open_inet_socket_aux"))
-
-(lisp::defentry unix/system (lisp::string)
- (lisp::int "system"))
-
-(defun open-inet-socket (hostname port)
- (values (or (open-inet-socket-aux '(unsigned-byte 8)
- (format nil "Network connection to ~A:~D" hostname port)
- hostname port)
- (error "Cannot connect to `~A' on port ~D."
- hostname port))
- :byte))
diff --git a/glisp/dep-gcl.lisp b/glisp/dep-gcl.lisp
deleted file mode 100644
index f53ae07..0000000
--- a/glisp/dep-gcl.lisp
+++ /dev/null
@@ -1,344 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: GCL dependent stuff + fixups
-;;; Created: 1999-05-25 22:31
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(shadow '(make-pathname pathname-directory) :glisp)
-
-(export '(glisp::defun
- glisp::read-byte-sequence
- glisp::read-char-sequence
- glisp::define-compiler-macro
- glisp::formatter
- glisp::destructuring-bind
- glisp::parse-macro
- glisp::loop
- glisp::*print-readably*
- glisp::compile-file-pathname
- glisp::ignore-errors
- glisp::pathname-directory
- glisp::make-pathname
- glisp::run-unix-shell-command)
- :glisp)
-
-(defmacro glisp::defun (name args &body body)
- (cond ((and (consp name)
- (eq (car name) 'setf))
- (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr name)) ")")
- (symbol-package (cadr name)))))
- `(progn
- (defsetf ,(cadr name) (&rest ap) (new-value) (list* ',fnam new-value ap))
- (defun ,fnam ,args .,body))))
- (t
- `(defun ,name ,args .,body)) ))
-
-(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
- (let (c (i start))
- (loop
- (cond ((= i end) (return i)))
- (setq c (read-byte input nil :eof))
- (cond ((eql c :eof) (return i)))
- (setf (aref sequence i) c)
- (incf i) )))
-
-(defun glisp::read-char-sequence (sequence input &key (start 0) (end (length sequence)))
- (let (c (i start))
- (loop
- (cond ((= i end) (return i)))
- (setq c (read-char input nil :eof))
- (cond ((eql c :eof) (return i)))
- (setf (aref sequence i) c)
- (incf i) )))
-
-(defmacro glisp::define-compiler-macro (&rest ignore)
- ignore
- nil)
-
-(defun glisp::formatter (string)
- #'(lambda (sink &rest ap)
- (apply #'format sink string ap)))
-
-(defmacro lambda (&rest x)
- `#'(lambda .,x))
-
-
-(defun glisp::row-major-aref (array index)
- ;; Wir sollten hier wirklich was effizienteres haben
- (aref (make-array (array-total-size array)
- :displaced-to array
- :element-type (array-element-type array))
- index))
-
-(glisp::defun (setf glisp::row-major-aref) (value array index)
- ;; Wir sollten hier wirklich was effizienteres haben
- (setf (aref (make-array (array-total-size array)
- :displaced-to array
- :element-type (array-element-type array))
- index)
- value))
-
-(defun glisp::mp/make-lock (&key name)
- name
- nil)
-
-(defmacro glisp::mp/with-lock ((lock) &body body)
- (declare (ignore lock))
- `(progn
- ,@body))
-
-(defmacro glisp::with-timeout ((&rest ignore) &body body)
- (declare (ignore ignore))
- `(progn
- ,@body))
-
-(defvar glisp::*print-readably* nil)
-
-(defun glisp::g/make-string (length &rest options)
- (apply #'make-array length :element-type 'string-char options))
-
-(defun parse-macro-lambda-list (name lambda-list whole &optional environment-value (real-whole whole))
- "The work horse for destructing-bind and parse-macro."
- (let ((orig-lambda-list lambda-list)
- required optionals rest-var keys aux-vars whole-var env-var
- allow-other-keys-p
- (my-lambda-list-keywords '(&OPTIONAL &REST &KEY &AUX &BODY)))
-
- (labels ((COLLECT (&optional on-keys-p)
- (let (result)
- (do ()
- ((or (atom lambda-list) (member (car lambda-list) my-lambda-list-keywords))
- (nreverse result))
- (cond ((eq (car lambda-list) '&WHOLE)
- (push (cadr lambda-list) whole-var)
- (setf lambda-list (cddr lambda-list)))
- ((eq (car lambda-list) '&ENVIRONMENT)
- (push (cadr lambda-list) env-var)
- (setf lambda-list (cddr lambda-list)))
- ((eq (car lambda-list) '&ALLOW-OTHER-KEYS)
- (unless on-keys-p
- (cerror "Ignore this syntax restriction and set the allow-other-keys-p flag."
- "In lambda list of macro ~S: &ALLOW-OTHER-KEYS may only be specified ~
- in the &KEYS section: ~S"
- name orig-lambda-list))
- (setq allow-other-keys-p T lambda-list (cdr lambda-list)))
- (T (push (pop lambda-list) result)) ))) )
-
- (CHECK-ONLY-ONE (kind lst)
- (unless (<= (length lst) 1)
- (error "In lambda list of macro ~S: You may only specify one ~S parameter, but I got ~S.~%~
- Lambda list: ~S."
- name kind lst orig-lambda-list))
- (car lst)) )
-
- ;; Now collect the various elements of the lambda-list
- (setq required (collect))
- (when (and (consp lambda-list) (eq (car lambda-list) '&OPTIONAL)) (pop lambda-list) (setq optionals (collect)))
- (when (and (consp lambda-list) (member (car lambda-list) '(&REST &BODY))) (pop lambda-list) (setq rest-var (collect)))
- (when (and (consp lambda-list) (eq (car lambda-list) '&KEY)) (pop lambda-list) (setq keys (collect T)))
- (when (and (consp lambda-list) (eq (car lambda-list) '&AUX)) (pop lambda-list) (setq aux-vars (collect)))
-
- ;; Inspect the remaining value of lambda-list
- (cond ((consp lambda-list)
- ;; Not all was parsed correctly ...
- (error "In lambda list of macro ~S: Found lambda list keyword ~S out of order;~%~
- The order must be &OPTIONAL, &REST/&BODY, &KEY, &AUX; &WHOLE and &ENVIRONMENT may apear anywhere.~%~
- Lambda list: ~S."
- name (car lambda-list) orig-lambda-list))
- ((null lambda-list)) ; Everything is just fine.
- ((symbolp lambda-list)
- ;; Dotted with a symbol = specification of a rest-var
- (push lambda-list rest-var))
- (T
- ;; List is odd-ly dotted.
- (error "In lambda list of macro ~S: A lambda list may only be dotted with a symbol.~%~
- Lambda list: ~S."
- name orig-lambda-list)) )
-
- ;; Now check for rest-var, whole-var and env-var, which may all specify only one variable ...
- (setf rest-var (check-only-one '&REST rest-var))
- (setf whole-var (check-only-one '&WHOLE whole-var))
- (when (and env-var (not environment-value))
- (cerror "Ignore the &ENVIRONMENT parameter."
- "In lambda list of macro ~S: An &ENVIRONMENT parameter may only be specified on the top-level lambda list.~%~
- Lambda list: ~S."
- name orig-lambda-list)
- (setq env-var nil))
- (setf env-var (check-only-one '&ENVIRONMENT env-var))
-
- (when (and (null rest-var) keys)
- (setf rest-var (gensym)))
-
- ;; Build up the bindings
- (let ((bindings nil) (constraints nil) (w whole))
- (labels ((add-one (x) (add (list x)))
- (add-bind (spec val)
- (if (consp spec)
- (let ((gsym (gensym)))
- (add-one `(,gsym ,val))
- (multiple-value-bind (bndngs cnstrnts) (parse-macro-lambda-list name spec gsym)
- (add bndngs)
- (setq contraints (nconc constraints cnstrnts))) )
- (add-one `(,spec ,val))))
- (add (x) (setf bindings (nconc bindings x))))
-
- (when whole-var
- (add-one `(,whole-var ,real-whole))
- (when (eq whole real-whole) (setq w whole-var)))
-
- ;; Calculate the constraints ...
- (let ((min nil)
- (max nil))
- (when (or required optionals rest-var) (setq min (length required)))
- (when (and (null rest-var) (or required optionals))
- (setq max (+ (length required) (length optionals))))
- (cond ((and (null min) (null max)))
- ((eql min max)
- (push `(listp ,w) constraints)
- (push `(= (length ,w) ,min) constraints))
- (T
- (push `(listp ,w) constraints)
- (when (and min (> min 0)) (push `(>= (length ,w) ,min) constraints))
- (when max (push `(<= (length ,w) ,max) constraints))) ))
-
- (setq constraints (nreverse constraints))
-
- (dolist (spec required)
- (add-bind spec `(CAR ,w))
- (setf w (list 'cdr w)))
-
- (dolist (spec optionals)
- ;; CHECK
- (cond ((consp spec)
- (when (caddr spec) ;svar
- (add-one `(,(caddr spec) (NOT (NULL ,w)))))
- (add-bind (car spec) `(if (NOT (NULL ,w)) (CAR ,w) ,(cadr spec))))
- (T
- (add-one `(,spec (CAR ,w)))) )
- (setf w (list 'cdr w)))
-
- (when rest-var (add-one `(,rest-var ,w)))
-
- (dolist (spec keys)
- ;; CHECK
- (let (kw var svar default)
- (cond ((consp spec)
- (setq var (car spec) default (cadr spec) svar (caddr spec))
- (when (consp var) (setq kw (car var) var (cadr var))))
- (T (setq var spec default nil svar nil)))
- ;; SVAR
- (unless kw (setq kw (intern (symbol-name var) :keyword)))
- (add-bind var `(getf ,rest-var ,kw ,default)) ))
-
- (dolist (spec aux-vars) (add-one spec))
-
- (when env-var
- (add-one `(,env-var ,environment-value)))
-
- (values bindings constraints env-var)) ))))
-
-(defun glisp::parse-macro (name lambda-list body &optional env)
- "This is used to process a macro definition in the same way as defmacro and
- macrolet. It returns a lambda-expression that accepts two arguments, a form
- and an environment. The name, lambda-list, and body arguments correspond to
- the parts of a defmacro or macrolet definition.
-
- The lambda-list argument may inclue &environment and &whole and may include
- destructing. The name argument is used to enclose the body in an implicat
- block and might also be used for implementation-depend purposes (such as
- including the name of the macro in error messages if the form does not match
- the lambda-list)."
-
- (let ((call (gensym)) (env (gensym)))
- (multiple-value-bind (bindings constraints)
- (parse-macro-lambda-list name lambda-list `(CDR call) env call)
- `(lambda (,call ,env)
- (block ,name
- (let* ,bindings
- (unless (and ,@constraints)
- (error "Macro ~S called with wrong number/nesting of arguments: ~S"
- ',name ,call))
- ,@body))) )) )
-
-(defmacro glisp::destructuring-bind (lambda-list expression &body body)
- "This macro binds the variables specified in lambda-list to the corresponding
- values in the tree structure resulting from evaluating the expression, then
- executes the forms as an implicit progn.
-
- A destructing-bind lambda-list may contain the lambda-list keywords &optional,
- &rest, &key, &allow-other-keys, and &aux; &body and &whole may also be used as
- they are in defmacro, but &environment may not be used. Nested and dotted
- lambda-lists are also permitted as for defmacro. The idea is that a
- destructing-bind lambda-list has the same format as inner levels of a defmacro
- lambda-list.
-
- If the result of evaluating the expressions does not match the destructuring
- pattern, an error should be signaled."
-
- (let ((call (gensym)))
- (multiple-value-bind (bindings constraints)
- (parse-macro-lambda-list nil lambda-list call)
- `(let* ((,call ,expression) ,@bindings)
- (unless (and ,@constraints)
- (error "DESTRUCTING-BIND with wrong number/nesting of arguments: ~S~%~
- Lambda list to match with: ~S." ,call ',lambda-list))
- (locally ,@body)) )) )
-
-
-(defmacro glisp::loop (&rest args)
- `(sloop:sloop ,@args))
-
-(defun glisp:compile-file-pathname (filename &rest options)
- (declare (ignore options))
- (merge-pathnames (make-pathname :type "o") filename))
-
-
-(defmacro glisp:ignore-errors (&rest body)
- `(IGNORE-ERRORS-FN #'(LAMBDA () ,@body)))
-
-(defun ignore-errors-fn (cont)
- (let ((old (symbol-function 'system:universal-error-handler)))
- (block foo
- (unwind-protect
- (progn
- (setf (symbol-function 'system:universal-error-handler)
- #'(lambda (&rest x)
- (return-from foo (values nil x))))
- (funcall cont) )
- (setf (symbol-function 'system:universal-error-handler) old) ))))
-
-(defun glisp::make-pathname (&rest args &key directory &allow-other-keys)
- (cond ((eq (car directory) :relative)
- (apply #'lisp:make-pathname :directory (cdr directory) args))
- ((eq (car directory) :absolute)
- (apply #'lisp:make-pathname :directory (cons :root (cdr directory)) args))
- (t
- (apply #'lisp:make-pathname args))))
-
-(defun glisp::pathname-directory (pathname)
- (let ((d (lisp:pathname-directory pathname)))
- (cond ((eq (car d) :root)
- (cons :absolute (cdr d)))
- (t
- (cons :relative d)))))
-
-
-(defun glisp::run-unix-shell-command (cmd)
- (glisp::unix/system cmd))
diff --git a/glisp/dep-sbcl.lisp b/glisp/dep-sbcl.lisp
deleted file mode 100644
index e9bb761..0000000
--- a/glisp/dep-sbcl.lisp
+++ /dev/null
@@ -1,141 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: SBCL dependent stuff + fixups
-;;; Created: 1999-05-25 22:32
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(export 'glisp::read-byte-sequence :glisp)
-(export 'glisp::read-char-sequence :glisp)
-(export 'glisp::run-unix-shell-command :glisp)
-
-(export 'glisp::getenv :glisp)
-
-(export 'glisp::make-server-socket :glisp)
-(export 'glisp::close-server-socket :glisp)
-
-(defun glisp::read-byte-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-(defun glisp::read-char-sequence (&rest ap)
- (apply #'read-sequence ap))
-
-(defmacro glisp::with-timeout ((&rest options) &body body)
- (declare (ignore ignore))
- `(progn
- ,@body))
-
-(defun glisp::open-inet-socket (hostname port)
- (values
- (sb-bsd-sockets:socket-make-stream
- (let ((host (car (sb-bsd-sockets:host-ent-addresses
- (sb-bsd-sockets:get-host-by-name hostname)))))
- (when host
- (let ((s (make-instance 'sb-bsd-sockets:inet-socket
- :type :stream :protocol :tcp)))
- (sb-bsd-sockets:socket-connect s host port)
- s)))
- :element-type '(unsigned-byte 8)
- :input t :output t)
- :byte))
-
-(defstruct (server-socket (:constructor make-server-socket-struct))
- fd
- element-type
- port)
-
-
-#||
-(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
- (make-server-socket-struct :fd (ext:create-inet-listener port)
- :element-type element-type
- :port port))
-
-
-(defun glisp::accept-connection/low (socket)
- (mp:process-wait-until-fd-usable (server-socket-fd socket) :input)
- (values
- (sys:make-fd-stream (ext:accept-tcp-connection (server-socket-fd socket))
- :input t :output t
- :element-type (server-socket-element-type socket))
- (cond ((subtypep (server-socket-element-type socket) 'integer)
- :byte)
- (t
- :char))))
-
-(defun glisp::close-server-socket (socket)
- (unix:unix-close (server-socket-fd socket)))
-||#
-
-;;;;;;
-
-(defun glisp::g/make-string (length &rest options)
- (apply #'make-array length :element-type 'base-char options))
-
-
-
-(defun glisp::run-unix-shell-command (command)
- (sb-impl::process-exit-code
- (sb-ext:run-program "/bin/sh" (list "-c" command) :wait t :input nil
- :output nil)))
-
-(defmacro glisp::defsubst (name args &body body)
- `(progn
- (declaim (inline ,name))
- (defun ,name ,args .,body)))
-
-
-;;; MP
-
-(export 'glisp::mp/process-yield :glisp)
-(export 'glisp::mp/process-wait :glisp)
-(export 'glisp::mp/process-run-function :glisp)
-(export 'glisp::mp/make-lock :glisp)
-(export 'glisp::mp/current-process :glisp)
-(export 'glisp::mp/process-kill :glisp)
-
-(defun glisp::mp/make-lock (&key name)
- (clim-sys::make-lock name))
-
-(defmacro glisp::mp/with-lock ((lock) &body body)
- `(clim-sys:with-lock-held (,lock)
- ,@body))
-
-(defun glisp::mp/process-yield (&optional process-to-run)
- (declare (ignore process-to-run))
- (clim-sys:process-yield))
-
-(defun glisp::mp/process-wait (whostate predicate)
- (clim-sys:process-wait whostate predicate))
-
-(defun glisp::mp/process-run-function (name fun &rest args)
- (clim-sys:make-process
- (lambda ()
- (apply fun args))
- :name name))
-
-(defun glisp::mp/current-process ()
- (clim-sys:current-process))
-
-(defun glisp::mp/process-kill (process)
- (clim-sys:destroy-process process))
-
-(defun glisp::getenv (string)
- (sb-ext:posix-getenv string))
-
diff --git a/glisp/gendep.lisp b/glisp/gendep.lisp
deleted file mode 100644
index 61be0f8..0000000
--- a/glisp/gendep.lisp
+++ /dev/null
@@ -1,427 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Generating a sane DEFPACKAGE for GLISP
-;;; Created: 1999-05-25 22:30
-;;; Author: Gilbert Baumann
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999 by Gilbert Baumann
-
-(defparameter *all-ansi-symbols*
- '("&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE" "*"
- "**" "***" "*BREAK-ON-SIGNALS*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*"
- "*COMPILE-PRINT*" "*COMPILE-VERBOSE*" "*DEBUG-IO*" "*DEBUGGER-HOOK*"
- "*DEFAULT-PATHNAME-DEFAULTS*" "*ERROR-OUTPUT*" "*FEATURES*" "*GENSYM-COUNTER*"
- "*LOAD-PATHNAME*" "*LOAD-PRINT*" "*LOAD-TRUENAME*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*"
- "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*" "*PRINT-CASE*" "*PRINT-CIRCLE*"
- "*PRINT-ESCAPE*" "*PRINT-GENSYM*" "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-LINES*"
- "*PRINT-MISER-WIDTH*" "*PRINT-PPRINT-DISPATCH*" "*PRINT-PRETTY*" "*PRINT-RADIX*"
- "*PRINT-READABLY*" "*PRINT-RIGHT-MARGIN*" "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*"
- "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-EVAL*" "*READ-SUPPRESS*" "*READTABLE*"
- "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*TERMINAL-IO*" "*TRACE-OUTPUT*" "+" "++" "+++" "-"
- "/" "//" "///" "/=" "1+" "1-" "<" "<=" "=" ">" ">=" "ABORT" "ABS" "ACONS" "ACOS" "ACOSH"
- "ADD-METHOD" "ADJOIN" "ADJUST-ARRAY" "ADJUSTABLE-ARRAY-P" "ALLOCATE-INSTANCE"
- "ALPHA-CHAR-P" "ALPHANUMERICP" "AND" "APPEND" "APPLY" "APROPOS" "APROPOS-LIST" "AREF"
- "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "ARRAY"
- "ARRAY-DIMENSION" "ARRAY-DIMENSION-LIMIT" "ARRAY-DIMENSIONS" "ARRAY-DISPLACEMENT"
- "ARRAY-ELEMENT-TYPE" "ARRAY-HAS-FILL-POINTER-P" "ARRAY-IN-BOUNDS-P" "ARRAY-RANK"
- "ARRAY-RANK-LIMIT" "ARRAY-ROW-MAJOR-INDEX" "ARRAY-TOTAL-SIZE" "ARRAY-TOTAL-SIZE-LIMIT"
- "ARRAYP" "ASH" "ASIN" "ASINH" "ASSERT" "ASSOC" "ASSOC-IF" "ASSOC-IF-NOT" "ATAN" "ATANH"
- "ATOM" "BASE-CHAR" "BASE-STRING" "BIGNUM" "BIT" "BIT-AND" "BIT-ANDC1" "BIT-ANDC2"
- "BIT-EQV" "BIT-IOR" "BIT-NAND" "BIT-NOR" "BIT-NOT" "BIT-ORC1" "BIT-ORC2" "BIT-VECTOR"
- "BIT-VECTOR-P" "BIT-XOR" "BLOCK" "BOOLE" "BOOLE-1" "BOOLE-2" "BOOLE-AND" "BOOLE-ANDC1"
- "BOOLE-ANDC2" "BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-NAND"
- "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-XOR" "BOOLEAN" "BOTH-CASE-P"
- "BOUNDP" "BREAK" "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "BUILT-IN-CLASS" "BUTLAST"
- "BYTE" "BYTE-POSITION" "BYTE-SIZE" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR"
- "CAAR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CALL-ARGUMENTS-LIMIT"
- "CALL-METHOD" "CALL-NEXT-METHOD" "CAR" "CASE" "CATCH" "CCASE" "CDAAAR" "CDAADR" "CDAAR"
- "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR" "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR"
- "CDDR" "CDR" "CEILING" "CELL-ERROR" "CELL-ERROR-NAME" "CERROR" "CHANGE-CLASS" "CHAR"
- "CHAR-CODE" "CHAR-CODE-LIMIT" "CHAR-DOWNCASE" "CHAR-EQUAL" "CHAR-GREATERP" "CHAR-INT"
- "CHAR-LESSP" "CHAR-NAME" "CHAR-NOT-EQUAL" "CHAR-NOT-GREATERP" "CHAR-NOT-LESSP"
- "CHAR-UPCASE" "CHAR/=" "CHAR<" "CHAR<=" "CHAR=" "CHAR>" "CHAR>=" "CHARACTER" "CHARACTERP"
- "CHECK-TYPE" "CIS" "CLASS" "CLASS-NAME" "CLASS-OF" "CLEAR-INPUT" "CLEAR-OUTPUT" "CLOSE"
- "CLRHASH" "CODE-CHAR" "COERCE" "COMPILATION-SPEED" "COMPILE" "COMPILE-FILE"
- "COMPILE-FILE-PATHNAME" "COMPILED-FUNCTION" "COMPILED-FUNCTION-P" "COMPILER-MACRO"
- "COMPILER-MACRO-FUNCTION" "COMPLEMENT" "COMPLEX" "COMPLEXP" "COMPUTE-APPLICABLE-METHODS"
- "COMPUTE-RESTARTS" "CONCATENATE" "CONCATENATED-STREAM" "CONCATENATED-STREAM-STREAMS"
- "COND" "CONDITION" "CONJUGATE" "CONS" "CONSP" "CONSTANTLY" "CONSTANTP" "CONTINUE"
- "CONTROL-ERROR" "COPY-ALIST" "COPY-LIST" "COPY-PPRINT-DISPATCH" "COPY-READTABLE"
- "COPY-SEQ" "COPY-STRUCTURE" "COPY-SYMBOL" "COPY-TREE" "COS" "COSH" "COUNT" "COUNT-IF"
- "COUNT-IF-NOT" "CTYPECASE" "DEBUG" "DECF" "DECLAIM" "DECLARATION" "DECLARE" "DECODE-FLOAT"
- "DECODE-UNIVERSAL-TIME" "DEFCLASS" "DEFCONSTANT" "DEFGENERIC" "DEFINE-COMPILER-MACRO"
- "DEFINE-CONDITION" "DEFINE-METHOD-COMBINATION" "DEFINE-MODIFY-MACRO"
- "DEFINE-SETF-EXPANDER" "DEFINE-SYMBOL-MACRO" "DEFMACRO" "DEFMETHOD" "DEFPACKAGE"
- "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR" "DELETE"
- "DELETE-DUPLICATES" "DELETE-FILE" "DELETE-IF" "DELETE-IF-NOT" "DELETE-PACKAGE"
- "DENOMINATOR" "DEPOSIT-FIELD" "DESCRIBE" "DESCRIBE-OBJECT" "DESTRUCTURING-BIND"
- "DIGIT-CHAR" "DIGIT-CHAR-P" "DIRECTORY" "DIRECTORY-NAMESTRING" "DISASSEMBLE"
- "DIVISION-BY-ZERO" "DO" "DO*" "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS"
- "DOCUMENTATION" "DOLIST" "DOTIMES" "DOUBLE-FLOAT" "DOUBLE-FLOAT-EPSILON"
- "DOUBLE-FLOAT-NEGATIVE-EPSILON" "DPB" "DRIBBLE" "DYNAMIC-EXTENT" "ECASE" "ECHO-STREAM"
- "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ED" "EIGHTH" "ELT"
- "ENCODE-UNIVERSAL-TIME" "END-OF-FILE" "ENDP" "ENOUGH-NAMESTRING"
- "ENSURE-DIRECTORIES-EXIST" "ENSURE-GENERIC-FUNCTION" "EQ" "EQL" "EQUAL" "EQUALP" "ERROR"
- "ETYPECASE" "EVAL" "EVAL-WHEN" "EVENP" "EVERY" "EXP" "EXPORT" "EXPT" "EXTENDED-CHAR"
- "FBOUNDP" "FCEILING" "FDEFINITION" "FFLOOR" "FIFTH" "FILE-AUTHOR" "FILE-ERROR"
- "FILE-ERROR-PATHNAME" "FILE-LENGTH" "FILE-NAMESTRING" "FILE-POSITION" "FILE-STREAM"
- "FILE-STRING-LENGTH" "FILE-WRITE-DATE" "FILL" "FILL-POINTER" "FIND" "FIND-ALL-SYMBOLS"
- "FIND-CLASS" "FIND-IF" "FIND-IF-NOT" "FIND-METHOD" "FIND-PACKAGE" "FIND-RESTART"
- "FIND-SYMBOL" "FINISH-OUTPUT" "FIRST" "FIXNUM" "FLET" "FLOAT" "FLOAT-DIGITS"
- "FLOAT-PRECISION" "FLOAT-RADIX" "FLOAT-SIGN" "FLOATING-POINT-INEXACT"
- "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW"
- "FLOATP" "FLOOR" "FMAKUNBOUND" "FORCE-OUTPUT" "FORMAT" "FORMATTER" "FOURTH" "FRESH-LINE"
- "FROUND" "FTRUNCATE" "FTYPE" "FUNCALL" "FUNCTION" "FUNCTION-KEYWORDS"
- "FUNCTION-LAMBDA-EXPRESSION" "FUNCTIONP" "GCD" "GENERIC-FUNCTION" "GENSYM" "GENTEMP" "GET"
- "GET-DECODED-TIME" "GET-DISPATCH-MACRO-CHARACTER" "GET-INTERNAL-REAL-TIME"
- "GET-INTERNAL-RUN-TIME" "GET-MACRO-CHARACTER" "GET-OUTPUT-STREAM-STRING" "GET-PROPERTIES"
- "GET-SETF-EXPANSION" "GET-UNIVERSAL-TIME" "GETF" "GETHASH" "GO" "GRAPHIC-CHAR-P"
- "HANDLER-BIND" "HANDLER-CASE" "HASH-TABLE" "HASH-TABLE-COUNT" "HASH-TABLE-P"
- "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-SIZE" "HASH-TABLE-TEST"
- "HOST-NAMESTRING" "IDENTITY" "IF" "IGNORABLE" "IGNORE" "IGNORE-ERRORS" "IMAGPART" "IMPORT"
- "IN-PACKAGE" "INCF" "INITIALIZE-INSTANCE" "INLINE" "INPUT-STREAM-P" "INSPECT" "INTEGER"
- "INTEGER-DECODE-FLOAT" "INTEGER-LENGTH" "INTEGERP" "INTERACTIVE-STREAM-P" "INTERN"
- "INTERNAL-TIME-UNITS-PER-SECOND" "INTERSECTION" "INVALID-METHOD-ERROR" "INVOKE-DEBUGGER"
- "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "ISQRT" "KEYWORD" "KEYWORDP" "LABELS"
- "LAMBDA" "LAMBDA-LIST-KEYWORDS" "LAMBDA-PARAMETERS-LIMIT" "LAST" "LCM" "LDB" "LDB-TEST"
- "LDIFF" "LEAST-NEGATIVE-DOUBLE-FLOAT" "LEAST-NEGATIVE-LONG-FLOAT"
- "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT"
- "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT"
- "LEAST-NEGATIVE-SHORT-FLOAT" "LEAST-NEGATIVE-SINGLE-FLOAT" "LEAST-POSITIVE-DOUBLE-FLOAT"
- "LEAST-POSITIVE-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT"
- "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT"
- "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-SHORT-FLOAT"
- "LEAST-POSITIVE-SINGLE-FLOAT" "LENGTH" "LET" "LET*" "LISP-IMPLEMENTATION-TYPE"
- "LISP-IMPLEMENTATION-VERSION" "LIST" "LIST*" "LIST-ALL-PACKAGES" "LIST-LENGTH" "LISTEN"
- "LISTP" "LOAD" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-TIME-VALUE" "LOCALLY" "LOG"
- "LOGAND" "LOGANDC1" "LOGANDC2" "LOGBITP" "LOGCOUNT" "LOGEQV" "LOGICAL-PATHNAME"
- "LOGICAL-PATHNAME-TRANSLATIONS" "LOGIOR" "LOGNAND" "LOGNOR" "LOGNOT" "LOGORC1" "LOGORC2"
- "LOGTEST" "LOGXOR" "LONG-FLOAT" "LONG-FLOAT-EPSILON" "LONG-FLOAT-NEGATIVE-EPSILON"
- "LONG-SITE-NAME" "LOOP" "LOOP-FINISH" "LOWER-CASE-P" "MACHINE-INSTANCE" "MACHINE-TYPE"
- "MACHINE-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1" "MACROLET" "MAKE-ARRAY"
- "MAKE-BROADCAST-STREAM" "MAKE-CONCATENATED-STREAM" "MAKE-CONDITION"
- "MAKE-DISPATCH-MACRO-CHARACTER" "MAKE-ECHO-STREAM" "MAKE-HASH-TABLE" "MAKE-INSTANCE"
- "MAKE-INSTANCES-OBSOLETE" "MAKE-LIST" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS"
- "MAKE-METHOD" "MAKE-PACKAGE" "MAKE-PATHNAME" "MAKE-RANDOM-STATE" "MAKE-SEQUENCE"
- "MAKE-STRING" "MAKE-STRING-INPUT-STREAM" "MAKE-STRING-OUTPUT-STREAM" "MAKE-SYMBOL"
- "MAKE-SYNONYM-STREAM" "MAKE-TWO-WAY-STREAM" "MAKUNBOUND" "MAP" "MAP-INTO" "MAPC" "MAPCAN"
- "MAPCAR" "MAPCON" "MAPHASH" "MAPL" "MAPLIST" "MASK-FIELD" "MAX" "MEMBER" "MEMBER-IF"
- "MEMBER-IF-NOT" "MERGE" "MERGE-PATHNAMES" "METHOD" "METHOD-COMBINATION"
- "METHOD-COMBINATION-ERROR" "METHOD-QUALIFIERS" "MIN" "MINUSP" "MISMATCH" "MOD"
- "MOST-NEGATIVE-DOUBLE-FLOAT" "MOST-NEGATIVE-FIXNUM" "MOST-NEGATIVE-LONG-FLOAT"
- "MOST-NEGATIVE-SHORT-FLOAT" "MOST-NEGATIVE-SINGLE-FLOAT" "MOST-POSITIVE-DOUBLE-FLOAT"
- "MOST-POSITIVE-FIXNUM" "MOST-POSITIVE-LONG-FLOAT" "MOST-POSITIVE-SHORT-FLOAT"
- "MOST-POSITIVE-SINGLE-FLOAT" "MUFFLE-WARNING" "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-CALL"
- "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-PROG1" "MULTIPLE-VALUE-SETQ" "MULTIPLE-VALUES-LIMIT"
- "NAME-CHAR" "NAMESTRING" "NBUTLAST" "NCONC" "NEXT-METHOD-P" "NIL" "NINTERSECTION" "NINTH"
- "NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "NOT" "NOTANY" "NOTEVERY" "NOTINLINE" "NRECONC"
- "NREVERSE" "NSET-DIFFERENCE" "NSET-EXCLUSIVE-OR" "NSTRING-CAPITALIZE" "NSTRING-DOWNCASE"
- "NSTRING-UPCASE" "NSUBLIS" "NSUBST" "NSUBST-IF" "NSUBST-IF-NOT" "NSUBSTITUTE"
- "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" "NTH" "NTH-VALUE" "NTHCDR" "NULL" "NUMBER" "NUMBERP"
- "NUMERATOR" "NUNION" "ODDP" "OPEN" "OPEN-STREAM-P" "OPTIMIZE" "OR" "OTHERWISE"
- "OUTPUT-STREAM-P" "PACKAGE" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "PACKAGE-NAME"
- "PACKAGE-NICKNAMES" "PACKAGE-SHADOWING-SYMBOLS" "PACKAGE-USE-LIST" "PACKAGE-USED-BY-LIST"
- "PACKAGEP" "PAIRLIS" "PARSE-ERROR" "PARSE-INTEGER" "PARSE-NAMESTRING" "PATHNAME"
- "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-MATCH-P" "PATHNAME-NAME"
- "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMEP" "PEEK-CHAR" "PHASE" "PI" "PLUSP" "POP"
- "POSITION" "POSITION-IF" "POSITION-IF-NOT" "PPRINT" "PPRINT-DISPATCH"
- "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-FILL" "PPRINT-INDENT" "PPRINT-LINEAR"
- "PPRINT-LOGICAL-BLOCK" "PPRINT-NEWLINE" "PPRINT-POP" "PPRINT-TAB" "PPRINT-TABULAR" "PRIN1"
- "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT" "PRINT-NOT-READABLE"
- "PRINT-NOT-READABLE-OBJECT" "PRINT-OBJECT" "PRINT-UNREADABLE-OBJECT" "PROBE-FILE"
- "PROCLAIM" "PROG" "PROG*" "PROG1" "PROG2" "PROGN" "PROGRAM-ERROR" "PROGV" "PROVIDE"
- "PSETF" "PSETQ" "PUSH" "PUSHNEW" "QUOTE" "RANDOM" "RANDOM-STATE" "RANDOM-STATE-P" "RASSOC"
- "RASSOC-IF" "RASSOC-IF-NOT" "RATIO" "RATIONAL" "RATIONALIZE" "RATIONALP" "READ"
- "READ-BYTE" "READ-CHAR" "READ-CHAR-NO-HANG" "READ-DELIMITED-LIST" "READ-FROM-STRING"
- "READ-LINE" "READ-PRESERVING-WHITESPACE" "READ-SEQUENCE" "READER-ERROR" "READTABLE"
- "READTABLE-CASE" "READTABLEP" "REAL" "REALP" "REALPART" "REDUCE" "REINITIALIZE-INSTANCE"
- "REM" "REMF" "REMHASH" "REMOVE" "REMOVE-DUPLICATES" "REMOVE-IF" "REMOVE-IF-NOT"
- "REMOVE-METHOD" "REMPROP" "RENAME-FILE" "RENAME-PACKAGE" "REPLACE" "REQUIRE" "REST"
- "RESTART" "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" "RETURN" "RETURN-FROM" "REVAPPEND"
- "REVERSE" "ROOM" "ROTATEF" "ROUND" "ROW-MAJOR-AREF" "RPLACA" "RPLACD" "SAFETY" "SATISFIES"
- "SBIT" "SCALE-FLOAT" "SCHAR" "SEARCH" "SECOND" "SEQUENCE" "SERIOUS-CONDITION" "SET"
- "SET-DIFFERENCE" "SET-DISPATCH-MACRO-CHARACTER" "SET-EXCLUSIVE-OR" "SET-MACRO-CHARACTER"
- "SET-PPRINT-DISPATCH" "SET-SYNTAX-FROM-CHAR" "SETF" "SETQ" "SEVENTH" "SHADOW"
- "SHADOWING-IMPORT" "SHARED-INITIALIZE" "SHIFTF" "SHORT-FLOAT" "SHORT-FLOAT-EPSILON"
- "SHORT-FLOAT-NEGATIVE-EPSILON" "SHORT-SITE-NAME" "SIGNAL" "SIGNED-BYTE" "SIGNUM"
- "SIMPLE-ARRAY" "SIMPLE-BASE-STRING" "SIMPLE-BIT-VECTOR" "SIMPLE-BIT-VECTOR-P"
- "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-CONTROL"
- "SIMPLE-ERROR" "SIMPLE-STRING" "SIMPLE-STRING-P" "SIMPLE-TYPE-ERROR" "SIMPLE-VECTOR"
- "SIMPLE-VECTOR-P" "SIMPLE-WARNING" "SIN" "SINGLE-FLOAT" "SINGLE-FLOAT-EPSILON"
- "SINGLE-FLOAT-NEGATIVE-EPSILON" "SINH" "SIXTH" "SLEEP" "SLOT-BOUNDP" "SLOT-EXISTS-P"
- "SLOT-MAKUNBOUND" "SLOT-MISSING" "SLOT-UNBOUND" "SLOT-VALUE" "SOFTWARE-TYPE"
- "SOFTWARE-VERSION" "SOME" "SORT" "SPACE" "SPECIAL" "SPECIAL-OPERATOR-P" "SPEED" "SQRT"
- "STABLE-SORT" "STANDARD" "STANDARD-CHAR" "STANDARD-CHAR-P" "STANDARD-CLASS"
- "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT" "STEP" "STORAGE-CONDITION"
- "STORE-VALUE" "STREAM" "STREAM-ELEMENT-TYPE" "STREAM-ERROR" "STREAM-ERROR-STREAM"
- "STREAM-EXTERNAL-FORMAT" "STREAMP" "STRING" "STRING-CAPITALIZE" "STRING-DOWNCASE"
- "STRING-EQUAL" "STRING-GREATERP" "STRING-LEFT-TRIM" "STRING-LESSP" "STRING-NOT-EQUAL"
- "STRING-NOT-GREATERP" "STRING-NOT-LESSP" "STRING-RIGHT-TRIM" "STRING-STREAM" "STRING-TRIM"
- "STRING-UPCASE" "STRING/=" "STRING<" "STRING<=" "STRING=" "STRING>" "STRING>=" "STRINGP"
- "STRUCTURE" "STRUCTURE-CLASS" "STRUCTURE-OBJECT" "STYLE-WARNING" "SUBLIS" "SUBSEQ"
- "SUBSETP" "SUBST" "SUBST-IF" "SUBST-IF-NOT" "SUBSTITUTE" "SUBSTITUTE-IF"
- "SUBSTITUTE-IF-NOT" "SUBTYPEP" "SVREF" "SXHASH" "SYMBOL" "SYMBOL-FUNCTION"
- "SYMBOL-MACROLET" "SYMBOL-NAME" "SYMBOL-PACKAGE" "SYMBOL-PLIST" "SYMBOL-VALUE" "SYMBOLP"
- "SYNONYM-STREAM" "SYNONYM-STREAM-SYMBOL" "T" "TAGBODY" "TAILP" "TAN" "TANH" "TENTH"
- "TERPRI" "THE" "THIRD" "THROW" "TIME" "TRACE" "TRANSLATE-LOGICAL-PATHNAME"
- "TRANSLATE-PATHNAME" "TREE-EQUAL" "TRUENAME" "TRUNCATE" "TWO-WAY-STREAM"
- "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE" "TYPE-ERROR"
- "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE" "TYPE-OF" "TYPECASE" "TYPEP" "UNBOUND-SLOT"
- "UNBOUND-SLOT-INSTANCE" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "UNEXPORT" "UNINTERN"
- "UNION" "UNLESS" "UNREAD-CHAR" "UNSIGNED-BYTE" "UNTRACE" "UNUSE-PACKAGE" "UNWIND-PROTECT"
- "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "UPDATE-INSTANCE-FOR-REDEFINED-CLASS"
- "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "UPPER-CASE-P" "USE-PACKAGE"
- "USE-VALUE" "USER-HOMEDIR-PATHNAME" "VALUES" "VALUES-LIST" "VARIABLE" "VECTOR"
- "VECTOR-POP" "VECTOR-PUSH" "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WARNING" "WHEN"
- "WILD-PATHNAME-P" "WITH-ACCESSORS" "WITH-COMPILATION-UNIT" "WITH-CONDITION-RESTARTS"
- "WITH-HASH-TABLE-ITERATOR" "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM"
- "WITH-OUTPUT-TO-STRING" "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART" "WITH-SLOTS"
- "WITH-STANDARD-IO-SYNTAX" "WRITE" "WRITE-BYTE" "WRITE-CHAR" "WRITE-LINE" "WRITE-SEQUENCE"
- "WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP"))
-
-(defvar *export-from-glisp*
- '(
- "DEFSUBST"
- "G/MAKE-STRING"
- "MP/MAKE-LOCK"
- "MP/WITH-LOCK"
- "WITH-TIMEOUT"
- "OPEN-INET-SOCKET"
- ;; 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"
- "G/OPEN-INET-SOCKET"
- "ACCEPT-CONNECTION"
-
- "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"
-
- ;; runes.lisp
- "RUNE"
- "ROD"
- "SIMPLE-ROD"
- "%RUNE"
- "ROD-CAPITALIZE"
- "CODE-RUNE"
- "RUNE-CODE"
- "RUNE-DOWNCASE"
- "RUNE-UPCASE"
- "ROD-DOWNCASE"
- "ROD-UPCASE"
- "WHITE-SPACE-RUNE-P"
- "DIGIT-RUNE-P"
- "RUNE="
- "RUNE<="
- "RUNE>="
- "RUNE-EQUAL"
- "RUNEP"
- "SLOOPY-ROD-P"
- "ROD="
- "ROD-EQUAL"
- "MAKE-ROD"
- "CHAR-RUNE"
- "RUNE-CHAR"
- "ROD-STRING"
- "STRING-ROD"
- "ROD-SUBSEQ"
-
- "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"
- ))
-
-(defparameter *packages*
- #-GCL '(:common-lisp)
- #+GCL '(:lisp :pcl) )
-
-(defparameter *dep-id*
- #+CLISP "clisp"
- #+(AND :CMU (NOT :PTHREAD)) "cmucl"
- #+(AND :CMU :PTHREAD) "cmucl-dtc"
- #+(AND ALLEGRO ALLEGRO-V5.0) "acl5"
- #+(AND ALLEGRO (NOT ALLEGRO-V5.0)) "acl"
- #+GCL "gcl"
- #-(OR CLISP CMU ALLEGRO GCL)
- #.(error "Configure!"))
-
-;; all symbols, which are defined by gray streams
-
-(defparameter *gray-symbols*
- '("FUNDAMENTAL-STREAM"
- "FUNDAMENTAL-INPUT-STREAM"
- "FUNDAMENTAL-OUTPUT-STREAM"
- "FUNDAMENTAL-CHARACTER-STREAM"
- "FUNDAMENTAL-BINARY-STREAM"
- "FUNDAMENTAL-CHARACTER-INPUT-STREAM"
- "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
- "FUNDAMENTAL-BINARY-INPUT-STREAM"
-
- "STREAM-READ-CHAR"
- "STREAM-UNREAD-CHAR"
- "STREAM-READ-CHAR-NO-HANG"
- "STREAM-PEEK-CHAR"
- "STREAM-LISTEN"
- "STREAM-READ-LINE"
- "STREAM-CLEAR-INPUT"
-
- "STREAM-WRITE-CHAR"
- "STREAM-LINE-COLUMN"
- "STREAM-START-LINE-P"
- "STREAM-WRITE-STRING"
- "STREAM-TERPRI"
- "STREAM-FRESH-LINE"
- "STREAM-FINISH-OUTPUT"
- "STREAM-FORCE-OUTPUT"
- "STREAM-ADVANCE-TO-COLUMN"
- "STREAM-CLEAR-INPUT"
-
- "STREAM-READ-BYTE"
- "STREAM-WRITE-BYTE" ))
-
-(defparameter *gray-packages*
- #+:CLISP '(:lisp)
- #+:CMU '(:ext)
- #+:ALLEGRO '(:excl)
- #+:HARLEQUIN-COMMON-LISP '(:stream)
- )
-
-(defun seek-symbol (name packages)
- ;; Seek the a symbol named 'name' in `packages'
- (or (some #'(lambda (p)
- (multiple-value-bind (sym res) (find-symbol name p)
- (if (eql res :external)
- (list sym)
- nil)))
- packages)
- (progn (format T "~&There is no ~A." name)
- (finish-output)
- nil)))
-
-(defun dump-defpackage (sink)
- (format sink ";; AUTOMATICALLY CREATED -- DO NOT EDIT")
- (format sink "~%;; Lisp Implementation Type: ~A" (lisp-implementation-type))
- (format sink "~%;; Lisp Implementation Version: ~A" (lisp-implementation-version))
- (format sink "~%")
- (let ((*print-case* :downcase)
- (export-ansi nil)
- (export-gray nil))
- (format sink "~%(in-package :~A)" (package-name *package*))
- (format sink "~%")
- (format sink "~%(defpackage :glisp")
- (format sink "~% (:use)")
- (labels ((grok (symbols packages)
- (let ((res nil))
- (dolist (nam symbols)
- (let ((sym (seek-symbol nam packages)))
- (when sym
- (push (car sym) res)
- (cond ((multiple-value-bind (sym2 res) (find-symbol nam :glisp)
- (and sym2 (eq res :external)))
- (format sink "~% ;; ~S patched" (car sym)) )
- (t
- (setf sym (car sym))
- ;; CLISP has no (:import ..) ARG!
- (format sink "~% (:import-from :~A #:~A)"
- (package-name (symbol-package sym))
- (symbol-name sym)))))))
- res)))
- (setf export-ansi (grok *all-ansi-symbols* *packages*))
- (setf export-gray (grok *gray-symbols* *gray-packages*)))
- (format sink "~%")
- (format sink "~% ;; -- Export ------------------------------")
- (format sink "~%")
- (format sink "~% (:export")
- (format sink "~% ;; ********** ANSI-CL")
- (dolist (k (reverse export-ansi))
- (format sink "~% #:~(~A~)" k))
- (format sink "~% ;; ********** Gray Streams")
- (dolist (k (reverse export-gray))
- (format sink "~% #:~(~A~)" k))
- (format sink "~%~% ;; ********** Private stuff")
- (dolist (k *export-from-glisp*)
- (format sink "~% #:~(~A~)" k))
- (format sink "))")
- (format sink "~%")
- (format sink "~%(defpackage :gluser (:use :glisp))")
- (format sink "~%") )
- (terpri sink))
-
-(defun run ()
- (make-package :glisp :use ())
- (load (format nil "dep-~A.lisp" *dep-id*))
- (with-open-file (sink (format nil "dfpck-~A.lisp" *dep-id*) :direction :output :if-exists :new-version)
- (dump-defpackage sink)))
diff --git a/glisp/match.lisp b/glisp/match.lisp
deleted file mode 100644
index 1bdc712..0000000
--- a/glisp/match.lisp
+++ /dev/null
@@ -1,207 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Very simple (non-deterministic) regular expression matching
-;;; Created: 1999-01-21
-;;; Author: Gilbert Baumann
-;;; License: LGPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999 by Gilbert Baumann
-
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Library General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 2 of the License, or (at your option) any later version.
-;;;
-;;; This library 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
-;;; Library General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Library General Public
-;;; License along with this library; if not, write to the
-;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;;; Boston, MA 02111-1307 USA.
-
-(in-package :GLISP)
-
-;; Syntax
-;; ------
-
-;; atom -- match the atom
-;; (p predicate) -- match, iff (funcall p elt) is non-NIL
-;; (& a0 .. an) -- match a0a1..an
-;; (/ a0 .. an) -- match a0 or a1 ... or an
-;; (* a0 .. an) -- iteration, match any number of (& a0 ... an)
-;; (+ . rest) == (/ (& . rest) (* . rest))
-;; (? . rest) == (/ (& . rest) (&))
-;; (= var subexpr) == assign the subexpr to the match variable 'var'
-;;
-;; not implemented:
-;; (- a b) -- match a, but not b
-;; (and a b) -- matches if a and b matches
-;; (or a b) == (/ a b)
-;; (not x) == matches if x does not match
-;;
-
-;; This syntax has to be merged with clex as well.
-
-(defvar *match-macros* (make-hash-table :test #'eq))
-
-(defmacro define-match-macro (name args &body body)
- `(eval-when (compile load eval)
- (setf (gethash ',name *match-macros*)
- #'(lambda (whole)
- (destructuring-bind ,args (cdr whole)
- ,@body)))
- ',name))
-
-(defun symcat (&rest syms)
- (let ((pack (dolist (k syms nil)
- (when (symbolp k)
- (return (symbol-package k))))))
- (cond ((null pack)
- (error "No package for ~S of ~S." 'symcat syms))
- (t
- (intern (apply #'concatenate 'string (mapcar #'string syms))
- pack)))))
-
-(defun sym-equal (a b)
- (string= (symbol-name a) (symbol-name b)))
-
-(defun bau-funcall (fun &rest args)
- (cond ((and (consp fun) (eq (car fun) 'lambda))
- (cons fun args))
- ((and (consp fun) (eq (car fun) 'function))
- (cons (cadr fun) args))
- (t
- (list* 'funcall fun args))))
-
-(defun compile-srx (srx action &key (string-type 'vector) (test '#'eql))
- (let ((vars nil))
- (labels ((cmp (x cont-expr)
- (cond
- ((atom x)
- (with-unique-names (string start end)
- `(lambda (,string ,start ,end)
- (declare (type fixnum ,start ,end)
- (type ,string-type ,string))
- (if (and (< ,start ,end)
- ,(bau-funcall test `(aref ,string ,start) `',x))
- ,(bau-funcall cont-expr string `(the fixnum (1+ ,start)) end)))))
-
- ((sym-equal (car x) 'p)
- (destructuring-bind (p) (cdr x)
- (with-unique-names (string start end)
- `(lambda (,string ,start ,end)
- (declare (type fixnum ,start ,end)
- (type ,string-type ,string))
- (if (and (< ,start ,end)
- ,(bau-funcall p `(aref ,string ,start)))
- ,(bau-funcall cont-expr string `(the fixnum (1+ ,start)) end))))))
-
- ((sym-equal (car x) '/)
- (with-unique-names (ccfn string string2 start end end2 j)
- `(lambda (,string ,start ,end)
- (declare (type fixnum ,start ,end)
- (type ,string-type ,string))
- (labels ((,ccfn (,string2 ,j ,end2)
- (declare (type fixnum ,j ,end2)
- (type ,string-type ,string2))
- ,(bau-funcall cont-expr string2 j end2)))
- ,@(mapcar (lambda (a)
- `(,(cmp a `#',ccfn) ,string ,start ,end))
- (cdr x))))))
-
- ((sym-equal (car x) '*)
- (with-unique-names (ccfn string string2 start end end2 j)
- (let ((subexpr (cons '& (cdr x))))
- `(lambda (,string ,start ,end)
- (declare (type fixnum ,start ,end)
- (type ,string-type ,string))
- (labels ((,ccfn (,string2 ,j ,end2)
- (declare (type fixnum ,j ,end2)
- (type ,string-type ,string2))
- (,(cmp subexpr `#',ccfn) ,string2 ,j ,end2)
- ,(bau-funcall cont-expr string j end)))
- (,ccfn ,string ,start ,end))))))
-
- ((sym-equal (car x) '&)
- (case (length x)
- (1 (with-unique-names (string start end)
- `(lambda (,string ,start ,end)
- (declare (type fixnum ,start ,end)
- (type ,string-type ,string))
- ,(bau-funcall cont-expr string start end))))
- (2 (cmp (cadr x) cont-expr))
- (otherwise
- (with-unique-names (string start end)
- `(lambda (,string ,start ,end)
- (declare (type fixnum ,start ,end)
- (type ,string-type ,string))
- (,(cmp (cadr x)
- (with-unique-names (string j end)
- `#'(lambda (,string ,j ,end)
- (declare (type fixnum ,j ,end)
- (type ,string-type ,string))
- (,(cmp (cons '& (cddr x)) cont-expr) ,string ,j ,end))))
- ,string ,start ,end))))))
-
- ((sym-equal (car x) '=)
- (destructuring-bind (var subexpr) (cdr x)
- (pushnew var vars)
- (with-unique-names (string i0 end)
- `(lambda (,string ,i0 ,end)
- (declare (type fixnum ,i0 ,end)
- (type ,string-type ,string))
- (,(cmp subexpr
- (with-unique-names (string i1 end)
- `#'(lambda (,string ,i1 ,end)
- (declare (type fixnum ,i1 ,end)
- (type ,string-type ,string))
- (setf ,(symcat var "-START") ,i0
- ,(symcat var "-END") ,i1)
- ,(bau-funcall cont-expr string i1 end))))
- ,string ,i0 ,end)))))
-
- ((sym-equal (car x) '+)
- (cmp `(& ,@(cdr x) (* ,@(cdr x))) cont-expr))
-
- ((sym-equal (car x) '?)
- (cmp `(/ (&) (& ,@(cdr x))) cont-expr))
-
- (t
- (let ((mmf (gethash (car x) *match-macros*)))
- (cond (mmf
- (cmp (funcall mmf x) cont-expr))
- (t
- (error "Unknown symbolic regular expression: ~S." x))))) )))
-
- (with-unique-names (string start end continuation match)
- (let ((cf (cmp srx `#',continuation)))
- `(lambda (,string ,start ,end)
- (declare ;;#.cl-user:+optimize-very-fast+
- (type fixnum ,start ,end)
- (type ,string-type ,string))
- (block ,match
- (let ,(mapcan (lambda (var) (list (symcat var "-START") (symcat var "-END"))) vars)
- (labels (,(with-unique-names (string j end)
- `(,continuation (,string ,j ,end)
- (declare (type fixnum ,j ,end)
- (type ,string-type ,string))
- (declare (ignore ,string))
- (if (= ,j ,end)
- (let ()
- (return-from ,match ,action))))))
- (,cf ,string ,start ,end)))
- nil)))))))
-
-(defmacro if-match ((string &key start end type (test '#'eql)) srx &body actions)
- (let ((str (gensym "str")))
- `(let ((,str ,string))
- (,(compile-srx srx `(progn .,actions)
- :string-type (or type 'vector)
- :test test)
- ,str
- ,(if start start 0)
- ,(if end end `(length ,str))))))
-
diff --git a/glisp/package.lisp b/glisp/package.lisp
deleted file mode 100644
index 902233f..0000000
--- a/glisp/package.lisp
+++ /dev/null
@@ -1,406 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP-TEMP; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Generating a sane DEFPACKAGE for GLISP
-;;; Created: 1999-05-25
-;;; Author: Gilbert Baumann
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1999,2000 by Gilbert Baumann
-
-(defpackage :glisp-temp (:use #:cl))
-(in-package :glisp-temp)
-
-(defpackage :glisp (:use))
-
-(eval-when (compile)
- (defparameter *all-ansi-symbols*
- '("&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE" "*"
- "**" "***" "*BREAK-ON-SIGNALS*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*"
- "*COMPILE-PRINT*" "*COMPILE-VERBOSE*" "*DEBUG-IO*" "*DEBUGGER-HOOK*"
- "*DEFAULT-PATHNAME-DEFAULTS*" "*ERROR-OUTPUT*" "*FEATURES*" "*GENSYM-COUNTER*"
- "*LOAD-PATHNAME*" "*LOAD-PRINT*" "*LOAD-TRUENAME*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*"
- "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*" "*PRINT-CASE*" "*PRINT-CIRCLE*"
- "*PRINT-ESCAPE*" "*PRINT-GENSYM*" "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-LINES*"
- "*PRINT-MISER-WIDTH*" "*PRINT-PPRINT-DISPATCH*" "*PRINT-PRETTY*" "*PRINT-RADIX*"
- "*PRINT-READABLY*" "*PRINT-RIGHT-MARGIN*" "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*"
- "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-EVAL*" "*READ-SUPPRESS*" "*READTABLE*"
- "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*TERMINAL-IO*" "*TRACE-OUTPUT*" "+" "++" "+++" "-"
- "/" "//" "///" "/=" "1+" "1-" "<" "<=" "=" ">" ">=" "ABORT" "ABS" "ACONS" "ACOS" "ACOSH"
- "ADD-METHOD" "ADJOIN" "ADJUST-ARRAY" "ADJUSTABLE-ARRAY-P" "ALLOCATE-INSTANCE"
- "ALPHA-CHAR-P" "ALPHANUMERICP" "AND" "APPEND" "APPLY" "APROPOS" "APROPOS-LIST" "AREF"
- "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "ARRAY"
- "ARRAY-DIMENSION" "ARRAY-DIMENSION-LIMIT" "ARRAY-DIMENSIONS" "ARRAY-DISPLACEMENT"
- "ARRAY-ELEMENT-TYPE" "ARRAY-HAS-FILL-POINTER-P" "ARRAY-IN-BOUNDS-P" "ARRAY-RANK"
- "ARRAY-RANK-LIMIT" "ARRAY-ROW-MAJOR-INDEX" "ARRAY-TOTAL-SIZE" "ARRAY-TOTAL-SIZE-LIMIT"
- "ARRAYP" "ASH" "ASIN" "ASINH" "ASSERT" "ASSOC" "ASSOC-IF" "ASSOC-IF-NOT" "ATAN" "ATANH"
- "ATOM" "BASE-CHAR" "BASE-STRING" "BIGNUM" "BIT" "BIT-AND" "BIT-ANDC1" "BIT-ANDC2"
- "BIT-EQV" "BIT-IOR" "BIT-NAND" "BIT-NOR" "BIT-NOT" "BIT-ORC1" "BIT-ORC2" "BIT-VECTOR"
- "BIT-VECTOR-P" "BIT-XOR" "BLOCK" "BOOLE" "BOOLE-1" "BOOLE-2" "BOOLE-AND" "BOOLE-ANDC1"
- "BOOLE-ANDC2" "BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-NAND"
- "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-XOR" "BOOLEAN" "BOTH-CASE-P"
- "BOUNDP" "BREAK" "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "BUILT-IN-CLASS" "BUTLAST"
- "BYTE" "BYTE-POSITION" "BYTE-SIZE" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR"
- "CAAR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CALL-ARGUMENTS-LIMIT"
- "CALL-METHOD" "CALL-NEXT-METHOD" "CAR" "CASE" "CATCH" "CCASE" "CDAAAR" "CDAADR" "CDAAR"
- "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR" "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR"
- "CDDR" "CDR" "CEILING" "CELL-ERROR" "CELL-ERROR-NAME" "CERROR" "CHANGE-CLASS" "CHAR"
- "CHAR-CODE" "CHAR-CODE-LIMIT" "CHAR-DOWNCASE" "CHAR-EQUAL" "CHAR-GREATERP" "CHAR-INT"
- "CHAR-LESSP" "CHAR-NAME" "CHAR-NOT-EQUAL" "CHAR-NOT-GREATERP" "CHAR-NOT-LESSP"
- "CHAR-UPCASE" "CHAR/=" "CHAR<" "CHAR<=" "CHAR=" "CHAR>" "CHAR>=" "CHARACTER" "CHARACTERP"
- "CHECK-TYPE" "CIS" "CLASS" "CLASS-NAME" "CLASS-OF" "CLEAR-INPUT" "CLEAR-OUTPUT" "CLOSE"
- "CLRHASH" "CODE-CHAR" "COERCE" "COMPILATION-SPEED" "COMPILE" "COMPILE-FILE"
- "COMPILE-FILE-PATHNAME" "COMPILED-FUNCTION" "COMPILED-FUNCTION-P" "COMPILER-MACRO"
- "COMPILER-MACRO-FUNCTION" "COMPLEMENT" "COMPLEX" "COMPLEXP" "COMPUTE-APPLICABLE-METHODS"
- "COMPUTE-RESTARTS" "CONCATENATE" "CONCATENATED-STREAM" "CONCATENATED-STREAM-STREAMS"
- "COND" "CONDITION" "CONJUGATE" "CONS" "CONSP" "CONSTANTLY" "CONSTANTP" "CONTINUE"
- "CONTROL-ERROR" "COPY-ALIST" "COPY-LIST" "COPY-PPRINT-DISPATCH" "COPY-READTABLE"
- "COPY-SEQ" "COPY-STRUCTURE" "COPY-SYMBOL" "COPY-TREE" "COS" "COSH" "COUNT" "COUNT-IF"
- "COUNT-IF-NOT" "CTYPECASE" "DEBUG" "DECF" "DECLAIM" "DECLARATION" "DECLARE" "DECODE-FLOAT"
- "DECODE-UNIVERSAL-TIME" "DEFCLASS" "DEFCONSTANT" "DEFGENERIC" "DEFINE-COMPILER-MACRO"
- "DEFINE-CONDITION" "DEFINE-METHOD-COMBINATION" "DEFINE-MODIFY-MACRO"
- "DEFINE-SETF-EXPANDER" "DEFINE-SYMBOL-MACRO" "DEFMACRO" "DEFMETHOD" "DEFPACKAGE"
- "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR" "DELETE"
- "DELETE-DUPLICATES" "DELETE-FILE" "DELETE-IF" "DELETE-IF-NOT" "DELETE-PACKAGE"
- "DENOMINATOR" "DEPOSIT-FIELD" "DESCRIBE" "DESCRIBE-OBJECT" "DESTRUCTURING-BIND"
- "DIGIT-CHAR" "DIGIT-CHAR-P" "DIRECTORY" "DIRECTORY-NAMESTRING" "DISASSEMBLE"
- "DIVISION-BY-ZERO" "DO" "DO*" "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS"
- "DOCUMENTATION" "DOLIST" "DOTIMES" "DOUBLE-FLOAT" "DOUBLE-FLOAT-EPSILON"
- "DOUBLE-FLOAT-NEGATIVE-EPSILON" "DPB" "DRIBBLE" "DYNAMIC-EXTENT" "ECASE" "ECHO-STREAM"
- "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ED" "EIGHTH" "ELT"
- "ENCODE-UNIVERSAL-TIME" "END-OF-FILE" "ENDP" "ENOUGH-NAMESTRING"
- "ENSURE-DIRECTORIES-EXIST" "ENSURE-GENERIC-FUNCTION" "EQ" "EQL" "EQUAL" "EQUALP" "ERROR"
- "ETYPECASE" "EVAL" "EVAL-WHEN" "EVENP" "EVERY" "EXP" "EXPORT" "EXPT" "EXTENDED-CHAR"
- "FBOUNDP" "FCEILING" "FDEFINITION" "FFLOOR" "FIFTH" "FILE-AUTHOR" "FILE-ERROR"
- "FILE-ERROR-PATHNAME" "FILE-LENGTH" "FILE-NAMESTRING" "FILE-POSITION" "FILE-STREAM"
- "FILE-STRING-LENGTH" "FILE-WRITE-DATE" "FILL" "FILL-POINTER" "FIND" "FIND-ALL-SYMBOLS"
- "FIND-CLASS" "FIND-IF" "FIND-IF-NOT" "FIND-METHOD" "FIND-PACKAGE" "FIND-RESTART"
- "FIND-SYMBOL" "FINISH-OUTPUT" "FIRST" "FIXNUM" "FLET" "FLOAT" "FLOAT-DIGITS"
- "FLOAT-PRECISION" "FLOAT-RADIX" "FLOAT-SIGN" "FLOATING-POINT-INEXACT"
- "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW"
- "FLOATP" "FLOOR" "FMAKUNBOUND" "FORCE-OUTPUT" "FORMAT" "FORMATTER" "FOURTH" "FRESH-LINE"
- "FROUND" "FTRUNCATE" "FTYPE" "FUNCALL" "FUNCTION" "FUNCTION-KEYWORDS"
- "FUNCTION-LAMBDA-EXPRESSION" "FUNCTIONP" "GCD" "GENERIC-FUNCTION" "GENSYM" "GENTEMP" "GET"
- "GET-DECODED-TIME" "GET-DISPATCH-MACRO-CHARACTER" "GET-INTERNAL-REAL-TIME"
- "GET-INTERNAL-RUN-TIME" "GET-MACRO-CHARACTER" "GET-OUTPUT-STREAM-STRING" "GET-PROPERTIES"
- "GET-SETF-EXPANSION" "GET-UNIVERSAL-TIME" "GETF" "GETHASH" "GO" "GRAPHIC-CHAR-P"
- "HANDLER-BIND" "HANDLER-CASE" "HASH-TABLE" "HASH-TABLE-COUNT" "HASH-TABLE-P"
- "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-SIZE" "HASH-TABLE-TEST"
- "HOST-NAMESTRING" "IDENTITY" "IF" "IGNORABLE" "IGNORE" "IGNORE-ERRORS" "IMAGPART" "IMPORT"
- "IN-PACKAGE" "INCF" "INITIALIZE-INSTANCE" "INLINE" "INPUT-STREAM-P" "INSPECT" "INTEGER"
- "INTEGER-DECODE-FLOAT" "INTEGER-LENGTH" "INTEGERP" "INTERACTIVE-STREAM-P" "INTERN"
- "INTERNAL-TIME-UNITS-PER-SECOND" "INTERSECTION" "INVALID-METHOD-ERROR" "INVOKE-DEBUGGER"
- "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "ISQRT" "KEYWORD" "KEYWORDP" "LABELS"
- "LAMBDA" "LAMBDA-LIST-KEYWORDS" "LAMBDA-PARAMETERS-LIMIT" "LAST" "LCM" "LDB" "LDB-TEST"
- "LDIFF" "LEAST-NEGATIVE-DOUBLE-FLOAT" "LEAST-NEGATIVE-LONG-FLOAT"
- "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT"
- "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT"
- "LEAST-NEGATIVE-SHORT-FLOAT" "LEAST-NEGATIVE-SINGLE-FLOAT" "LEAST-POSITIVE-DOUBLE-FLOAT"
- "LEAST-POSITIVE-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT"
- "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT"
- "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-SHORT-FLOAT"
- "LEAST-POSITIVE-SINGLE-FLOAT" "LENGTH" "LET" "LET*" "LISP-IMPLEMENTATION-TYPE"
- "LISP-IMPLEMENTATION-VERSION" "LIST" "LIST*" "LIST-ALL-PACKAGES" "LIST-LENGTH" "LISTEN"
- "LISTP" "LOAD" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-TIME-VALUE" "LOCALLY" "LOG"
- "LOGAND" "LOGANDC1" "LOGANDC2" "LOGBITP" "LOGCOUNT" "LOGEQV" "LOGICAL-PATHNAME"
- "LOGICAL-PATHNAME-TRANSLATIONS" "LOGIOR" "LOGNAND" "LOGNOR" "LOGNOT" "LOGORC1" "LOGORC2"
- "LOGTEST" "LOGXOR" "LONG-FLOAT" "LONG-FLOAT-EPSILON" "LONG-FLOAT-NEGATIVE-EPSILON"
- "LONG-SITE-NAME" "LOOP" "LOOP-FINISH" "LOWER-CASE-P" "MACHINE-INSTANCE" "MACHINE-TYPE"
- "MACHINE-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1" "MACROLET" "MAKE-ARRAY"
- "MAKE-BROADCAST-STREAM" "MAKE-CONCATENATED-STREAM" "MAKE-CONDITION"
- "MAKE-DISPATCH-MACRO-CHARACTER" "MAKE-ECHO-STREAM" "MAKE-HASH-TABLE" "MAKE-INSTANCE"
- "MAKE-INSTANCES-OBSOLETE" "MAKE-LIST" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS"
- "MAKE-METHOD" "MAKE-PACKAGE" "MAKE-PATHNAME" "MAKE-RANDOM-STATE" "MAKE-SEQUENCE"
- "MAKE-STRING" "MAKE-STRING-INPUT-STREAM" "MAKE-STRING-OUTPUT-STREAM" "MAKE-SYMBOL"
- "MAKE-SYNONYM-STREAM" "MAKE-TWO-WAY-STREAM" "MAKUNBOUND" "MAP" "MAP-INTO" "MAPC" "MAPCAN"
- "MAPCAR" "MAPCON" "MAPHASH" "MAPL" "MAPLIST" "MASK-FIELD" "MAX" "MEMBER" "MEMBER-IF"
- "MEMBER-IF-NOT" "MERGE" "MERGE-PATHNAMES" "METHOD" "METHOD-COMBINATION"
- "METHOD-COMBINATION-ERROR" "METHOD-QUALIFIERS" "MIN" "MINUSP" "MISMATCH" "MOD"
- "MOST-NEGATIVE-DOUBLE-FLOAT" "MOST-NEGATIVE-FIXNUM" "MOST-NEGATIVE-LONG-FLOAT"
- "MOST-NEGATIVE-SHORT-FLOAT" "MOST-NEGATIVE-SINGLE-FLOAT" "MOST-POSITIVE-DOUBLE-FLOAT"
- "MOST-POSITIVE-FIXNUM" "MOST-POSITIVE-LONG-FLOAT" "MOST-POSITIVE-SHORT-FLOAT"
- "MOST-POSITIVE-SINGLE-FLOAT" "MUFFLE-WARNING" "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-CALL"
- "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-PROG1" "MULTIPLE-VALUE-SETQ" "MULTIPLE-VALUES-LIMIT"
- "NAME-CHAR" "NAMESTRING" "NBUTLAST" "NCONC" "NEXT-METHOD-P" "NIL" "NINTERSECTION" "NINTH"
- "NO-APPLICABLE-METHOD" "NO-NEXT-METHOD" "NOT" "NOTANY" "NOTEVERY" "NOTINLINE" "NRECONC"
- "NREVERSE" "NSET-DIFFERENCE" "NSET-EXCLUSIVE-OR" "NSTRING-CAPITALIZE" "NSTRING-DOWNCASE"
- "NSTRING-UPCASE" "NSUBLIS" "NSUBST" "NSUBST-IF" "NSUBST-IF-NOT" "NSUBSTITUTE"
- "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" "NTH" "NTH-VALUE" "NTHCDR" "NULL" "NUMBER" "NUMBERP"
- "NUMERATOR" "NUNION" "ODDP" "OPEN" "OPEN-STREAM-P" "OPTIMIZE" "OR" "OTHERWISE"
- "OUTPUT-STREAM-P" "PACKAGE" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "PACKAGE-NAME"
- "PACKAGE-NICKNAMES" "PACKAGE-SHADOWING-SYMBOLS" "PACKAGE-USE-LIST" "PACKAGE-USED-BY-LIST"
- "PACKAGEP" "PAIRLIS" "PARSE-ERROR" "PARSE-INTEGER" "PARSE-NAMESTRING" "PATHNAME"
- "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-MATCH-P" "PATHNAME-NAME"
- "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMEP" "PEEK-CHAR" "PHASE" "PI" "PLUSP" "POP"
- "POSITION" "POSITION-IF" "POSITION-IF-NOT" "PPRINT" "PPRINT-DISPATCH"
- "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-FILL" "PPRINT-INDENT" "PPRINT-LINEAR"
- "PPRINT-LOGICAL-BLOCK" "PPRINT-NEWLINE" "PPRINT-POP" "PPRINT-TAB" "PPRINT-TABULAR" "PRIN1"
- "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT" "PRINT-NOT-READABLE"
- "PRINT-NOT-READABLE-OBJECT" "PRINT-OBJECT" "PRINT-UNREADABLE-OBJECT" "PROBE-FILE"
- "PROCLAIM" "PROG" "PROG*" "PROG1" "PROG2" "PROGN" "PROGRAM-ERROR" "PROGV" "PROVIDE"
- "PSETF" "PSETQ" "PUSH" "PUSHNEW" "QUOTE" "RANDOM" "RANDOM-STATE" "RANDOM-STATE-P" "RASSOC"
- "RASSOC-IF" "RASSOC-IF-NOT" "RATIO" "RATIONAL" "RATIONALIZE" "RATIONALP" "READ"
- "READ-BYTE" "READ-CHAR" "READ-CHAR-NO-HANG" "READ-DELIMITED-LIST" "READ-FROM-STRING"
- "READ-LINE" "READ-PRESERVING-WHITESPACE" "READ-SEQUENCE" "READER-ERROR" "READTABLE"
- "READTABLE-CASE" "READTABLEP" "REAL" "REALP" "REALPART" "REDUCE" "REINITIALIZE-INSTANCE"
- "REM" "REMF" "REMHASH" "REMOVE" "REMOVE-DUPLICATES" "REMOVE-IF" "REMOVE-IF-NOT"
- "REMOVE-METHOD" "REMPROP" "RENAME-FILE" "RENAME-PACKAGE" "REPLACE" "REQUIRE" "REST"
- "RESTART" "RESTART-BIND" "RESTART-CASE" "RESTART-NAME" "RETURN" "RETURN-FROM" "REVAPPEND"
- "REVERSE" "ROOM" "ROTATEF" "ROUND" "ROW-MAJOR-AREF" "RPLACA" "RPLACD" "SAFETY" "SATISFIES"
- "SBIT" "SCALE-FLOAT" "SCHAR" "SEARCH" "SECOND" "SEQUENCE" "SERIOUS-CONDITION" "SET"
- "SET-DIFFERENCE" "SET-DISPATCH-MACRO-CHARACTER" "SET-EXCLUSIVE-OR" "SET-MACRO-CHARACTER"
- "SET-PPRINT-DISPATCH" "SET-SYNTAX-FROM-CHAR" "SETF" "SETQ" "SEVENTH" "SHADOW"
- "SHADOWING-IMPORT" "SHARED-INITIALIZE" "SHIFTF" "SHORT-FLOAT" "SHORT-FLOAT-EPSILON"
- "SHORT-FLOAT-NEGATIVE-EPSILON" "SHORT-SITE-NAME" "SIGNAL" "SIGNED-BYTE" "SIGNUM"
- "SIMPLE-ARRAY" "SIMPLE-BASE-STRING" "SIMPLE-BIT-VECTOR" "SIMPLE-BIT-VECTOR-P"
- "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-CONTROL"
- "SIMPLE-ERROR" "SIMPLE-STRING" "SIMPLE-STRING-P" "SIMPLE-TYPE-ERROR" "SIMPLE-VECTOR"
- "SIMPLE-VECTOR-P" "SIMPLE-WARNING" "SIN" "SINGLE-FLOAT" "SINGLE-FLOAT-EPSILON"
- "SINGLE-FLOAT-NEGATIVE-EPSILON" "SINH" "SIXTH" "SLEEP" "SLOT-BOUNDP" "SLOT-EXISTS-P"
- "SLOT-MAKUNBOUND" "SLOT-MISSING" "SLOT-UNBOUND" "SLOT-VALUE" "SOFTWARE-TYPE"
- "SOFTWARE-VERSION" "SOME" "SORT" "SPACE" "SPECIAL" "SPECIAL-OPERATOR-P" "SPEED" "SQRT"
- "STABLE-SORT" "STANDARD" "STANDARD-CHAR" "STANDARD-CHAR-P" "STANDARD-CLASS"
- "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD" "STANDARD-OBJECT" "STEP" "STORAGE-CONDITION"
- "STORE-VALUE" "STREAM" "STREAM-ELEMENT-TYPE" "STREAM-ERROR" "STREAM-ERROR-STREAM"
- "STREAM-EXTERNAL-FORMAT" "STREAMP" "STRING" "STRING-CAPITALIZE" "STRING-DOWNCASE"
- "STRING-EQUAL" "STRING-GREATERP" "STRING-LEFT-TRIM" "STRING-LESSP" "STRING-NOT-EQUAL"
- "STRING-NOT-GREATERP" "STRING-NOT-LESSP" "STRING-RIGHT-TRIM" "STRING-STREAM" "STRING-TRIM"
- "STRING-UPCASE" "STRING/=" "STRING<" "STRING<=" "STRING=" "STRING>" "STRING>=" "STRINGP"
- "STRUCTURE" "STRUCTURE-CLASS" "STRUCTURE-OBJECT" "STYLE-WARNING" "SUBLIS" "SUBSEQ"
- "SUBSETP" "SUBST" "SUBST-IF" "SUBST-IF-NOT" "SUBSTITUTE" "SUBSTITUTE-IF"
- "SUBSTITUTE-IF-NOT" "SUBTYPEP" "SVREF" "SXHASH" "SYMBOL" "SYMBOL-FUNCTION"
- "SYMBOL-MACROLET" "SYMBOL-NAME" "SYMBOL-PACKAGE" "SYMBOL-PLIST" "SYMBOL-VALUE" "SYMBOLP"
- "SYNONYM-STREAM" "SYNONYM-STREAM-SYMBOL" "T" "TAGBODY" "TAILP" "TAN" "TANH" "TENTH"
- "TERPRI" "THE" "THIRD" "THROW" "TIME" "TRACE" "TRANSLATE-LOGICAL-PATHNAME"
- "TRANSLATE-PATHNAME" "TREE-EQUAL" "TRUENAME" "TRUNCATE" "TWO-WAY-STREAM"
- "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE" "TYPE-ERROR"
- "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE" "TYPE-OF" "TYPECASE" "TYPEP" "UNBOUND-SLOT"
- "UNBOUND-SLOT-INSTANCE" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "UNEXPORT" "UNINTERN"
- "UNION" "UNLESS" "UNREAD-CHAR" "UNSIGNED-BYTE" "UNTRACE" "UNUSE-PACKAGE" "UNWIND-PROTECT"
- "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "UPDATE-INSTANCE-FOR-REDEFINED-CLASS"
- "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "UPPER-CASE-P" "USE-PACKAGE"
- "USE-VALUE" "USER-HOMEDIR-PATHNAME" "VALUES" "VALUES-LIST" "VARIABLE" "VECTOR"
- "VECTOR-POP" "VECTOR-PUSH" "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WARNING" "WHEN"
- "WILD-PATHNAME-P" "WITH-ACCESSORS" "WITH-COMPILATION-UNIT" "WITH-CONDITION-RESTARTS"
- "WITH-HASH-TABLE-ITERATOR" "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM"
- "WITH-OUTPUT-TO-STRING" "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART" "WITH-SLOTS"
- "WITH-STANDARD-IO-SYNTAX" "WRITE" "WRITE-BYTE" "WRITE-CHAR" "WRITE-LINE" "WRITE-SEQUENCE"
- "WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP"))
-
- (defvar *export-from-glisp*
- '(
- "DEFSUBST"
- "G/MAKE-STRING"
- "MP/MAKE-LOCK"
- "MP/WITH-LOCK"
- "WITH-TIMEOUT"
- "OPEN-INET-SOCKET"
- ;; 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"
- "G/OPEN-INET-SOCKET"
- "ACCEPT-CONNECTION"
-
- "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"
-
- ;; runes.lisp
- "RUNE"
- "ROD"
- "SIMPLE-ROD"
- "%RUNE"
- "ROD-CAPITALIZE"
- "CODE-RUNE"
- "RUNE-CODE"
- "RUNE-DOWNCASE"
- "RUNE-UPCASE"
- "ROD-DOWNCASE"
- "ROD-UPCASE"
- "WHITE-SPACE-RUNE-P"
- "DIGIT-RUNE-P"
- "RUNE="
- "RUNE<="
- "RUNE>="
- "RUNE-EQUAL"
- "RUNEP"
- "SLOOPY-ROD-P"
- "ROD="
- "ROD-EQUAL"
- "MAKE-ROD"
- "CHAR-RUNE"
- "RUNE-CHAR"
- "ROD-STRING"
- "STRING-ROD"
- "ROD-SUBSEQ"
-
- "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"
- ))
-
- (defparameter *packages*
- #-GCL '(:common-lisp)
- #+GCL '(:lisp :pcl) )
-
- (defparameter *gray-symbols*
- '("FUNDAMENTAL-STREAM"
- "FUNDAMENTAL-INPUT-STREAM"
- "FUNDAMENTAL-OUTPUT-STREAM"
- "FUNDAMENTAL-CHARACTER-STREAM"
- "FUNDAMENTAL-BINARY-STREAM"
- "FUNDAMENTAL-CHARACTER-INPUT-STREAM"
- "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
- "FUNDAMENTAL-BINARY-INPUT-STREAM"
-
- "STREAM-READ-CHAR"
- "STREAM-UNREAD-CHAR"
- "STREAM-READ-CHAR-NO-HANG"
- "STREAM-PEEK-CHAR"
- "STREAM-LISTEN"
- "STREAM-READ-LINE"
- "STREAM-CLEAR-INPUT"
-
- "STREAM-WRITE-CHAR"
- "STREAM-LINE-COLUMN"
- "STREAM-START-LINE-P"
- "STREAM-WRITE-STRING"
- "STREAM-TERPRI"
- "STREAM-FRESH-LINE"
- "STREAM-FINISH-OUTPUT"
- "STREAM-FORCE-OUTPUT"
- "STREAM-ADVANCE-TO-COLUMN"
-
- "STREAM-READ-BYTE"
- "STREAM-WRITE-BYTE" ))
-
- (defparameter *gray-packages*
- `(
- #+:CLISP ,@'(:lisp)
- #+:CMU ,@'(:ext)
- #+:sbcl ,@'(:sb-gray)
- #+:ALLEGRO ,@'(:common-lisp :excl :stream)
- #+:HARLEQUIN-COMMON-LISP ,@'(:stream)
- #+:OPENMCL ,@'(:ccl)
- ))
-
- (defun seek-symbol (name packages)
- ;; Seek the a symbol named 'name' in `packages'
- (or (some #'(lambda (p)
- (multiple-value-bind (sym res) (find-symbol name p)
- (if (eql res :external)
- (list sym)
- nil)))
- packages)
- (progn (format T "~&There is no ~A in ~A." name packages)
- (finish-output)
- nil)))
-
- (defun dump-defpackage (&aux imports export-ansi export-gray)
- (labels ((grok (symbols packages)
- (let ((res nil))
- (dolist (nam symbols)
- (let ((sym (seek-symbol nam packages)))
- (when sym
- (push (car sym) res)
- (cond ((multiple-value-bind (sym2 res) (find-symbol nam :glisp)
- (and sym2 (eq res :external)))
- ;;
- (format T "~&;; ~S is pacthed." sym) )
- (t
- (setf sym (car sym))
- ;; CLISP has no (:import ..) ARG!
- (push `(:import-from
- ,(package-name (symbol-package sym))
- ,(symbol-name sym))
- imports))))))
- res)))
- (setf export-ansi (grok *all-ansi-symbols* *packages*))
- (setf export-gray (grok *gray-symbols* *gray-packages*))
- `(progn
- (defpackage "GLISP" (:use)
- ,@imports
- (:export
- ,@(mapcar #'symbol-name export-ansi)
- ,@(mapcar #'symbol-name export-gray)
- ,@*export-from-glisp*))
- (defpackage "GLUSER"
- (:use "GLISP")) )))
-
- (defmacro define-glisp-package ()
- (dump-defpackage))
- )
-
-(define-glisp-package)
-
diff --git a/glisp/runes.lisp b/glisp/runes.lisp
deleted file mode 100644
index 8d8f55e..0000000
--- a/glisp/runes.lisp
+++ /dev/null
@@ -1,412 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Unicode strings (called RODs)
-;;; Created: 1999-05-25 22:29
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1998,1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-;; Changes
-;;
-;; When Who What
-;; ----------------------------------------------------------------------------
-;; 1999-08-15 GB - ROD=, ROD-EQUAL
-;; RUNE<=, RUNE>=
-;; MAKE-ROD, ROD-SUBSEQ
-;; CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD
-;; new functions
-;; - Added rune reader
-;;
-
-(in-package :GLISP)
-
-(deftype rune () '(unsigned-byte 16))
-(deftype rod () '(array rune (*)))
-(deftype simple-rod () '(simple-array rune (*)))
-
-(defsubst rune (rod index)
- (aref rod index))
-
-(defun (setf rune) (new rod index)
- (setf (aref rod index) new))
-
-(defsubst %rune (rod index)
- (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)))
-
-(defsubst (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)
-
-(defsubst rune= (x y)
- (= x y))
-
-(defun rune-downcase (rune)
- (cond ((<= #x0041 rune #x005a) (+ rune #x20))
- ((= rune #x00d7) rune)
- ((<= #x00c0 rune #x00de) (+ rune #x20))
- (t rune)))
-
-(defsubst rune-upcase (rune)
- (cond ((<= #x0061 rune #x007a) (- rune #x20))
- ((= rune #x00f7) rune)
- ((<= #x00e0 rune #x00fe) (- rune #x20))
- (t rune)))
-
-(defun rune-upper-case-letter-p (rune)
- (or (<= #x0041 rune #x005a) (<= #x00c0 rune #x00de)))
-
-(defun rune-lower-case-letter-p (rune)
- (or (<= #x0061 rune #x007a) (<= #x00e0 rune #x00fe)
- (= rune #x00d7)))
-
-
-(defun rune-equal (x y)
- (rune= (rune-upcase x) (rune-upcase y)))
-
-(defun rod-downcase (rod)
- ;; FIXME
- (register-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)))
-
-(defsubst 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))
- (cond ((<= #.(char-code #\0) char #.(char-code #\9))
- (and (< (- char #.(char-code #\0)) radix)
- (- char #.(char-code #\0))))
- ((<= #.(char-code #\A) char #.(char-code #\Z))
- (and (< (- char #.(char-code #\A) -10) radix)
- (- char #.(char-code #\A) -10)))
- ((<= #.(char-code #\a) char #.(char-code #\z))
- (and (< (- char #.(char-code #\a) -10) radix)
- (- char #.(char-code #\a) -10))) ))
-
-(defun rod (x)
- (cond ((stringp x) (register-rod (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))))
- (t (error "Cannot convert ~S to a ~S" x 'rod))))
-
-(defun runep (x)
- (and (integerp x)
- (<= 0 x #xFFFF)))
-
-(defun sloopy-rod-p (x)
- (and (not (stringp x))
- (vectorp x)
- (every #'runep x)))
-
-(defun rod= (x y)
- (and (= (length x) (length y))
- (dotimes (i (length x) t)
- (unless (rune= (rune x i) (rune y i))
- (return nil)))))
-
-(defun rod-equal (x y)
- (and (= (length x) (length y))
- (dotimes (i (length x) t)
- (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))
-
-(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))
-
-(defun rod-string (rod &optional (default-char #\?))
- (map 'string (lambda (x) (rune-char x default-char)) rod))
-
-(defun string-rod (string)
- (let* ((n (length string))
- (res (make-rod n)))
- (dotimes (i n)
- (setf (%rune res i) (char-rune (char string i))))
- res))
-
-;;;;
-;;;; RUNE Reader
-;;;;
-
-;; Portable implementation of WHITE-SPACE-P with regard to the current
-;; read table -- this is bit tricky.
-
-(defun rt-white-space-p (char)
- (let ((stream (make-string-input-stream (string char))))
- (eq :eof (peek-char t stream nil :eof))))
-
-(defun read-rune-name (input)
- ;; the first char is unconditionally read
- (let ((char0 (read-char input t nil t)))
- (when (char= char0 #\\)
- (setf char0 (read-char input t nil t)))
- (with-output-to-string (res)
- (write-char char0 res)
- (do ((ch (peek-char nil input nil :eof t) (peek-char nil input nil :eof t)))
- ((or (eq ch :eof)
- (rt-white-space-p ch)
- (multiple-value-bind (function non-terminating-p) (get-macro-character ch)
- (and function (not non-terminating-p)))))
- (write-char ch res)
- (read-char input))))) ;consume this character
-
-(defun iso-10646-char-code (char)
- (char-code char))
-
-(defvar *rune-names* (make-hash-table :test #'equal)
- "Hashtable, which maps all known rune names to rune codes;
- Names are stored in uppercase.")
-
-(defun define-rune-name (name code)
- (setf (gethash (string-upcase name) *rune-names*) code)
- name)
-
-(defun lookup-rune-name (name)
- (gethash (string-upcase name) *rune-names*))
-
-(define-rune-name "null" #x0000)
-(define-rune-name "space" #x0020)
-(define-rune-name "newline" #x000A)
-(define-rune-name "return" #x000D)
-(define-rune-name "tab" #x0009)
-(define-rune-name "page" #x000C)
-
-;; and just for fun:
-(define-rune-name "euro" #x20AC)
-
-;; ASCII control characters
-(define-rune-name "nul" #x0000) ;null
-(define-rune-name "soh" #x0001) ;start of header
-(define-rune-name "stx" #x0002) ;start of text
-(define-rune-name "etx" #x0003) ;end of text
-(define-rune-name "eot" #x0004) ;end of transmission
-(define-rune-name "enq" #x0005) ;
-(define-rune-name "ack" #x0006) ;acknowledge
-(define-rune-name "bel" #x0007) ;bell
-(define-rune-name "bs" #x0008) ;backspace
-(define-rune-name "ht" #x0009) ;horizontal tab
-(define-rune-name "lf" #X000A) ;line feed, new line
-(define-rune-name "vt" #X000B) ;vertical tab
-(define-rune-name "ff" #x000C) ;form feed
-(define-rune-name "cr" #x000D) ;carriage return
-(define-rune-name "so" #x000E) ;shift out
-(define-rune-name "si" #x000F) ;shift in
-(define-rune-name "dle" #x0010) ;device latch enable ?
-(define-rune-name "dc1" #x0011) ;device control 1
-(define-rune-name "dc2" #x0012) ;device control 2
-(define-rune-name "dc3" #x0013) ;device control 3
-(define-rune-name "dc4" #x0014) ;device control 4
-(define-rune-name "nak" #x0015) ;negative acknowledge
-(define-rune-name "syn" #x0016) ;
-(define-rune-name "etb" #x0017) ;
-(define-rune-name "can" #x0018) ;
-(define-rune-name "em" #x0019) ;end of message
-(define-rune-name "sub" #x001A) ;
-(define-rune-name "esc" #x001B) ;escape
-(define-rune-name "fs" #x001C) ;field separator ?
-(define-rune-name "gs" #x001D) ;group separator
-(define-rune-name "rs" #x001E) ;
-(define-rune-name "us" #x001F) ;
-
-(define-rune-name "del" #x007F) ;delete
-
-;; iso-latin
-(define-rune-name "nbsp" #x00A0) ;non breakable space
-(define-rune-name "shy" #x00AD) ;soft hyphen
-
-(defun rune-from-read-name (name)
- (cond ((= (length name) 1)
- (iso-10646-char-code (char name 0)))
- ((and (= (length name) 2)
- (char= (char name 0) #\\))
- (iso-10646-char-code (char name 1)))
- ((and (>= (length name) 3)
- (char-equal (char name 0) #\u)
- (char-equal (char name 1) #\+)
- (every (lambda (x) (digit-char-p x 16)) (subseq name 2)))
- (parse-integer name :start 2 :radix 16))
- ((lookup-rune-name name))
- (t
- (error "Meaningless rune name ~S." name))))
-
-(defun rune-reader (stream subchar arg)
- subchar arg
- (values (rune-from-read-name (read-rune-name stream))))
-
-(set-dispatch-macro-character #\# #\/ 'rune-reader)
-
-;;;;
-
-(defun rune<= (rune &rest more-runes)
- (apply #'<= rune more-runes))
-
-(defun rune>= (rune &rest more-runes)
- (apply #'>= rune more-runes))
-
-(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))
- (unless (and (typep start 'fixnum) (>= start 0))
- (error "~S is not a non-negative fixnum." start))
- (unless (and (typep end 'fixnum) (>= end start))
- (error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
- (when (> start (length source))
- (error "START argument, ~S, should be no greater than length of rod." start))
- (when (> end (length source))
- (error "END argument, ~S, should be no greater than length of rod." end))
- (locally
- (declare (type rod source)
- (type fixnum start end))
- (let ((res (make-rod (- end start))))
- (declare (type rod res))
- (do ((i (- (- end start) 1) (the fixnum (- i 1))))
- ((< i 0) res)
- (declare (type fixnum i))
- (setf (%rune res i) (%rune source (the fixnum (+ i start))))))))
-
-(defun rod-subseq* (source start &optional (end (length source)))
- (unless (and (typep start 'fixnum) (>= start 0))
- (error "~S is not a non-negative fixnum." start))
- (unless (and (typep end 'fixnum) (>= end start))
- (error "END argument, ~S, is not a fixnum no less than START, ~S." end start))
- (when (> start (length source))
- (error "START argument, ~S, should be no greater than length of rod." start))
- (when (> end (length source))
- (error "END argument, ~S, should be no greater than length of rod." end))
- (locally
- (declare (type fixnum start end))
- (let ((res (make-rod (- end start))))
- (declare (type rod res))
- (do ((i (- (- end start) 1) (the fixnum (- i 1))))
- ((< i 0) res)
- (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*) )
-
-;;; ROD ext syntax
-
-(defun rod-reader (stream subchar arg)
- (declare (ignore arg))
- (rod
- (with-output-to-string (bag)
- (do ((c (read-char stream t nil t)
- (read-char stream t nil t)))
- ((char= c subchar))
- (cond ((char= c #\\)
- (setf c (read-char stream t nil t))))
- (princ c bag)))))
-
-(defun rod-printer (stream rod)
- (princ #\# stream)
- (princ #\" stream)
- (loop for x across rod do
- (cond ((or (rune= x #.(char-code #\\))
- (rune= x #.(char-code #\")))
- (princ #\\ stream)
- (princ (code-char x) stream))
- ((< x char-code-limit)
- (princ (code-char x) stream))
- (t
- (format stream "\\u~4,'0X" x))))
- (princ #\" stream))
-
-(set-pprint-dispatch '(satisfies really-rod-p) #'rod-printer)
-
-(set-dispatch-macro-character #\# #\" 'rod-reader)
-
-#||
-(defun longish-array-p (arr)
- (and (arrayp arr)
- (> (array-total-size arr) 10)))
-
-(set-pprint-dispatch '(satisfies longish-array-p)
- #'(lambda (stream object)
- (let ((*print-array* nil)
- (*print-pretty* nil))
- (prin1 object stream))))
-||#
\ No newline at end of file
diff --git a/glisp/syntax.lisp b/glisp/syntax.lisp
deleted file mode 100644
index d66ce6c..0000000
--- a/glisp/syntax.lisp
+++ /dev/null
@@ -1,190 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Unicode strings (called RODs)
-;;; Created: 1999-05-25 22:29
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1998,1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-;; Changes
-;;
-;; When Who What
-;; ----------------------------------------------------------------------------
-;; 1999-08-15 GB - ROD=, ROD-EQUAL
-;; RUNE<=, RUNE>=
-;; MAKE-ROD, ROD-SUBSEQ
-;; CHAR-RUNE, RUNE-CHAR, ROD-STRING, STRING-ROD
-;; new functions
-;; - Added rune reader
-;;
-
-(in-package :glisp)
-
-;;;;
-;;;; RUNE Reader
-;;;;
-
-;; Portable implementation of WHITE-SPACE-P with regard to the current
-;; read table -- this is bit tricky.
-
-(defun rt-white-space-p (char)
- (let ((stream (make-string-input-stream (string char))))
- (eq :eof (peek-char t stream nil :eof))))
-
-(defun read-rune-name (input)
- ;; the first char is unconditionally read
- (let ((char0 (read-char input t nil t)))
- (when (char= char0 #\\)
- (setf char0 (read-char input t nil t)))
- (with-output-to-string (res)
- (write-char char0 res)
- (do ((ch (peek-char nil input nil :eof t) (peek-char nil input nil :eof t)))
- ((or (eq ch :eof)
- (rt-white-space-p ch)
- (multiple-value-bind (function non-terminating-p) (get-macro-character ch)
- (and function (not non-terminating-p)))))
- (write-char ch res)
- (read-char input))))) ;consume this character
-
-(defun iso-10646-char-code (char)
- (char-code char))
-
-(defvar *rune-names* (make-hash-table :test #'equal)
- "Hashtable, which maps all known rune names to rune codes;
- Names are stored in uppercase.")
-
-(defun define-rune-name (name code)
- (setf (gethash (string-upcase name) *rune-names*) code)
- name)
-
-(defun lookup-rune-name (name)
- (gethash (string-upcase name) *rune-names*))
-
-(define-rune-name "null" #x0000)
-(define-rune-name "space" #x0020)
-(define-rune-name "newline" #x000A)
-(define-rune-name "return" #x000D)
-(define-rune-name "tab" #x0009)
-(define-rune-name "page" #x000C)
-
-;; and just for fun:
-(define-rune-name "euro" #x20AC)
-
-;; ASCII control characters
-(define-rune-name "nul" #x0000) ;null
-(define-rune-name "soh" #x0001) ;start of header
-(define-rune-name "stx" #x0002) ;start of text
-(define-rune-name "etx" #x0003) ;end of text
-(define-rune-name "eot" #x0004) ;end of transmission
-(define-rune-name "enq" #x0005) ;
-(define-rune-name "ack" #x0006) ;acknowledge
-(define-rune-name "bel" #x0007) ;bell
-(define-rune-name "bs" #x0008) ;backspace
-(define-rune-name "ht" #x0009) ;horizontal tab
-(define-rune-name "lf" #X000A) ;line feed, new line
-(define-rune-name "vt" #X000B) ;vertical tab
-(define-rune-name "ff" #x000C) ;form feed
-(define-rune-name "cr" #x000D) ;carriage return
-(define-rune-name "so" #x000E) ;shift out
-(define-rune-name "si" #x000F) ;shift in
-(define-rune-name "dle" #x0010) ;device latch enable ?
-(define-rune-name "dc1" #x0011) ;device control 1
-(define-rune-name "dc2" #x0012) ;device control 2
-(define-rune-name "dc3" #x0013) ;device control 3
-(define-rune-name "dc4" #x0014) ;device control 4
-(define-rune-name "nak" #x0015) ;negative acknowledge
-(define-rune-name "syn" #x0016) ;
-(define-rune-name "etb" #x0017) ;
-(define-rune-name "can" #x0018) ;
-(define-rune-name "em" #x0019) ;end of message
-(define-rune-name "sub" #x001A) ;
-(define-rune-name "esc" #x001B) ;escape
-(define-rune-name "fs" #x001C) ;field separator ?
-(define-rune-name "gs" #x001D) ;group separator
-(define-rune-name "rs" #x001E) ;
-(define-rune-name "us" #x001F) ;
-
-(define-rune-name "del" #x007F) ;delete
-
-;; iso-latin
-(define-rune-name "nbsp" #x00A0) ;non breakable space
-(define-rune-name "shy" #x00AD) ;soft hyphen
-
-(defun rune-from-read-name (name)
- (cond ((= (length name) 1)
- (iso-10646-char-code (char name 0)))
- ((and (= (length name) 2)
- (char= (char name 0) #\\))
- (iso-10646-char-code (char name 1)))
- ((and (>= (length name) 3)
- (char-equal (char name 0) #\u)
- (char-equal (char name 1) #\+)
- (every (lambda (x) (digit-char-p x 16)) (subseq name 2)))
- (parse-integer name :start 2 :radix 16))
- ((lookup-rune-name name))
- (t
- (error "Meaningless rune name ~S." name))))
-
-(defun rune-reader (stream subchar arg)
- subchar arg
- (values (rune-from-read-name (read-rune-name stream))))
-
-(set-dispatch-macro-character #\# #\/ 'rune-reader)
-
-;;; ROD ext syntax
-
-(defun rod-reader (stream subchar arg)
- (declare (ignore arg))
- (rod
- (with-output-to-string (bag)
- (do ((c (read-char stream t nil t)
- (read-char stream t nil t)))
- ((char= c subchar))
- (cond ((char= c #\\)
- (setf c (read-char stream t nil t))))
- (princ c bag)))))
-
-(defun rod-printer (stream rod)
- (princ #\# stream)
- (princ #\" stream)
- (loop for x across rod do
- (cond ((or (rune= x #.(char-code #\\))
- (rune= x #.(char-code #\")))
- (princ #\\ stream)
- (princ (code-char x) stream))
- ((< x char-code-limit)
- (princ (code-char x) stream))
- (t
- (format stream "\\u~4,'0X" x))))
- (princ #\" stream))
-
-(set-pprint-dispatch '(satisfies really-rod-p) #'rod-printer)
-
-(set-dispatch-macro-character #\# #\" 'rod-reader)
-
-#||
-(defun longish-array-p (arr)
- (and (arrayp arr)
- (> (array-total-size arr) 10)))
-
-(set-pprint-dispatch '(satisfies longish-array-p)
- #'(lambda (stream object)
- (let ((*print-array* nil)
- (*print-pretty* nil))
- (prin1 object stream))))
-||#
diff --git a/glisp/util.lisp b/glisp/util.lisp
deleted file mode 100644
index eb65f00..0000000
--- a/glisp/util.lisp
+++ /dev/null
@@ -1,1113 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Some common utilities for the Closure browser
-;;; Created: 1997-12-27
-;;; Author: Gilbert Baumann
-;;; License: GPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; (c) copyright 1997-1999 by Gilbert Baumann
-
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, 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 :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 #'white-space-rune-p string :start start)))
- (cond (i
- (let ((j (position-if-not #'white-space-rune-p string :start i)))
- (if j
- (concatenate 'rod (subseq string start i)
- (if (and (= i start) begin?) '#() '#(32))
- (sanify-rod string nil end? j))
- (concatenate '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-byte-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))
-
-(defun g/open-inet-socket (&rest args)
- (multiple-value-bind (stream kind) (apply #'open-inet-socket args)
- (ecase kind
- #-CMU
- (:char (cl-char-stream->gstream stream))
- (:byte (cl-byte-stream->gstream stream)) )))
-
-#||
-(defun g/open-inet-socket-ssl (host port)
- (multiple-value-bind (stream) (gluser::make-ssl-client-socket host port)
- (cl-byte-stream->gstream stream)))
-||#
-
-(defun accept-connection (socket)
- (multiple-value-bind (stream kind) (accept-connection/low socket)
- (ecase kind
- (:char (cl-char-stream->gstream stream))
- (:byte (cl-byte-stream->gstream 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 (g/make-string buffer-size :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"))
- )))
-
diff --git a/xml/dom-builder.lisp b/xml/dom-builder.lisp
deleted file mode 100644
index 9c803f4..0000000
--- a/xml/dom-builder.lisp
+++ /dev/null
@@ -1,46 +0,0 @@
-(in-package :dom-impl)
-
-(export 'dom-builder)
-
-(defclass dom-builder ()
- ((document :initform nil :accessor document)
- (element-stack :initform '() :accessor element-stack)))
-
-(defmethod sax:start-document ((handler dom-builder))
- (let ((document (make-instance 'dom-impl::document))
- (doctype (make-instance 'dom-impl::document-type
- :notations (make-hash-table :test #'equalp))))
- (setf (slot-value document 'dom-impl::owner) document
- (slot-value document 'dom-impl::doc-type) doctype)
- (setf (document handler) document)
- (push document (element-stack handler))))
-
-(defmethod sax:end-document ((handler dom-builder))
- (setf (slot-value (document handler) 'children )
- (nreverse (slot-value (document handler) 'children)))
- (document handler))
-
-(defmethod sax:start-element ((handler dom-builder) namespace-uri local-name qname attributes)
- (with-slots (document element-stack) handler
- (let ((element (dom:create-element document qname))
- (parent (car element-stack)))
- (dolist (attr attributes)
- (dom:set-attribute element (xml::attribute-qname attr) (xml::attribute-value attr)))
- (setf (slot-value element 'dom-impl::parent) parent)
- (push element (slot-value parent 'dom-impl::children))
- (push element element-stack))))
-
-(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
- (let ((element (pop (element-stack handler))))
- (setf (slot-value element 'dom-impl::children)
- (nreverse (slot-value element 'dom-impl::children)))))
-
-(defmethod sax:characters ((handler dom-builder) data)
- (with-slots (document element-stack) handler
- (let ((node (dom:create-text-node document data)))
- (push node (slot-value (car element-stack) 'dom-impl::children)))))
-
-(defmethod sax:processing-instruction ((handler dom-builder) target data)
- (with-slots (document element-stack) handler
- (let ((node (dom:create-processing-instruction document target data)))
- (push node (slot-value (car element-stack) 'dom-impl::children)))))
diff --git a/xml/dom-impl.lisp b/xml/dom-impl.lisp
deleted file mode 100644
index 02bac90..0000000
--- a/xml/dom-impl.lisp
+++ /dev/null
@@ -1,512 +0,0 @@
-(defpackage :dom-impl
- (:use :glisp))
-
-(in-package :dom-impl)
-
-;; Classes
-
-(defclass node ()
- ((parent :initarg :parent :initform nil)
- (children :initarg :children :initform nil)
- (owner :initarg :owner :initform nil)))
-
-(defclass document (node)
- ((doc-type :initarg :doc-type :reader dom:doctype)))
-
-(defclass document-fragment (node)
- ())
-
-(defclass character-data (node)
- ((data :initarg :data :reader dom:data)))
-
-(defclass attribute (node)
- ((name :initarg :name :reader dom:name)
- (value :initarg :value :reader dom:value)
- (specified-p :initarg :specified-p :reader dom:specified)))
-
-(defclass element (node)
- ((tag-name :initarg :tag-name :reader dom:tag-name)
- (attributes :initarg :attributes :reader dom:attributes
- :initform (make-instance 'named-node-map))))
-
-(defclass text (character-data)
- ())
-
-(defclass comment (character-data)
- ())
-
-(defclass cdata-section (text)
- ())
-
-(defclass document-type (node)
- ((name :initarg :name :reader dom:name)
- (entities :initarg :entities :reader dom:entities)
- (notations :initarg :notations :reader dom:notations)))
-
-(defclass notation (node)
- ((name :initarg :name :reader dom:name)
- (public-id :initarg :public-id :reader dom:public-id)
- (system-id :initarg :system-id :reader dom:system-id)))
-
-(defclass entity (node)
- ((name :initarg :name :reader dom:name)
- (public-id :initarg :public-id :reader dom:public-id)
- (system-id :initarg :system-id :reader dom:system-id)
- (notation-name :initarg :notation-name :reader dom:notation-name)))
-
-(defclass entity-reference (node)
- ((name :initarg :name :reader dom:name)))
-
-(defclass processing-instruction (node)
- ((target :initarg :target :reader dom:target)
- (data :initarg :data :reader dom:data)))
-
-(defclass named-node-map ()
- ((items :initarg :items :reader dom:items
- :initform nil) ))
-
-
-;;; Implementation
-
-;; document-fragment protocol
-;; document protocol
-
-(defmethod dom:implementation ((document document))
- 'implementation)
-
-(defmethod dom:document-element ((document document))
- (dolist (k (dom:child-nodes document))
- (cond ((typep k 'element)
- (return k)))))
-
-(defmethod dom:create-element ((document document) tag-name)
- (setf tag-name (rod tag-name))
- (make-instance 'element
- :tag-name tag-name
- :owner document))
-
-(defmethod dom:create-document-fragment ((document document))
- (make-instance 'document-fragment
- :owner document))
-
-(defmethod dom:create-text-node ((document document) data)
- (setf data (rod data))
- (make-instance 'text
- :data data
- :owner document))
-
-(defmethod dom:create-comment ((document document) data)
- (setf data (rod data))
- (make-instance 'comment
- :data data
- :owner document))
-
-(defmethod dom:create-cdata-section ((document document) data)
- (setf data (rod data))
- (make-instance 'cdata-section
- :data data
- :owner document))
-
-(defmethod dom:create-processing-instruction ((document document) target data)
- (setf target (rod target))
- (setf data (rod data))
- (make-instance 'processing-instruction
- :owner document
- :target target
- :data data))
-
-(defmethod dom:create-attribute ((document document) name)
- (setf name (rod name))
- (make-instance 'attribute
- :name name
- :specified-p nil ;???
- :owner document))
-
-(defmethod dom:create-entity-reference ((document document) name)
- (setf name (rod name))
- (make-instance 'entity-reference
- :name name
- :owner document))
-
-(defmethod dom:get-elements-by-tag-name ((document document) tag-name)
- (setf tag-name (rod tag-name))
- (let ((result nil))
- (setf tag-name (rod tag-name))
- (let ((wild-p (rod= tag-name '#.(string-rod "*"))))
- (labels ((walk (n)
- (when (and (dom:element-p n)
- (or wild-p (tag-name-eq tag-name (dom:node-name n))))
- (push n result))
- (mapc #'walk (dom:child-nodes n))))
- (walk document)
- (reverse result)))))
-
-;;; Node
-
-(defmethod dom:parent-node ((node node))
- (slot-value node 'parent))
-
-(defmethod dom:child-nodes ((node node))
- (slot-value node 'children))
-
-(defmethod dom:first-child ((node node))
- (car (slot-value node 'children)))
-
-(defmethod dom:last-child ((node node))
- (car (last (slot-value node 'children))))
-
-(defmethod dom:previous-sibling ((node node))
- (with-slots (parent) node
- (when parent
- (with-slots (children) parent
- (do ((q children (cdr q)))
- ((null (cdr q)) niL)
- (cond ((eq (cadr q) node)
- (return (car q)))))))))
-
-(defmethod dom:next-sibling ((node node))
- (with-slots (parent) node
- (when parent
- (with-slots (children) parent
- (do ((q children (cdr q)))
- ((null (cdr q)) niL)
- (cond ((eq (car q) node)
- (return (cadr q)))))))))
-
-(defmethod dom:owner-document ((node node))
- (slot-value node 'owner))
-
-(defun ensure-valid-insertion-request (node new-child)
- (unless (can-adopt-p node new-child)
- ;; HIERARCHY_REQUEST_ERR
- (error "~S cannot adopt ~S." node new-child))
- (unless (eq (dom:owner-document node)
- (dom:owner-document new-child))
- ;; WRONG_DOCUMENT_ERR
- (error "~S cannot adopt ~S, since it was created by a different document."
- node new-child))
- (with-slots (children) node
- (unless (null (slot-value new-child 'parent))
- (cond ((eq (slot-value new-child 'parent)
- node)
- ;; remove it first
- (setf children (delete new-child children)))
- (t
- ;; otherwise it is an error.
- ;; GB_INTEGRITY_ERR
- (error "~S is already adopted." new-child)))) ))
-
-(defmethod dom:insert-before ((node node) (new-child node) (ref-child t))
- (ensure-valid-insertion-request node new-child)
- (with-slots (children) node
- (cond ((eq (car children) ref-child)
- (setf (slot-value new-child 'parent) node)
- (setf children (cons new-child children)))
- (t
- (do ((q children (cdr q)))
- ((null (cdr q))
- (cond ((null ref-child)
- (setf (slot-value new-child 'parent) node)
- (setf (cdr q) (cons new-child nil)))
- (t
- ;; NOT_FOUND_ERR
- (error "~S is no child of ~S." ref-child node))))
- (cond ((eq (cadr q) ref-child)
- (setf (slot-value new-child 'parent) node)
- (setf (cdr q) (cons new-child (cdr q)))
- (return))))))
- new-child))
-
-(defmethod dom:insert-before ((node node) (fragment document-fragment) ref-child)
- (dolist (child (dom:child-nodes fragment))
- (dom:insert-before node child ref-child))
- fragment)
-
-(defmethod dom:replace-child ((node node) (new-child node) (old-child node))
- (ensure-valid-insertion-request node new-child)
- (with-slots (children) node
- (do ((q children (cdr q)))
- ((null q)
- ;; NOT_FOUND_ERR
- (error "~S is no child of ~S." old-child node))
- (cond ((eq (car q) old-child)
- (setf (car q) new-child)
- (setf (slot-value new-child 'parent) node)
- (setf (slot-value old-child 'parent) nil)
- (return))))
- old-child))
-
-(defmethod dom:append-child ((node node) (new-child node))
- (ensure-valid-insertion-request node new-child)
- (with-slots (children) node
- (setf children (nconc children (list new-child)))
- (setf (slot-value new-child 'parent) node)
- new-child))
-
-(defmethod dom:has-child-nodes ((node node))
- (not (null (slot-value node 'children))))
-
-(defmethod dom:append-child ((node node) (new-child document-fragment))
- (dolist (child (dom:child-nodes new-child))
- (dom:append-child node child))
- new-child)
-
-;; was auf node noch implemetiert werden muss:
-;; - node-type
-;; - can-adopt-p
-;; - ggf attributes
-;; - node-name
-;; - node-value
-
-;; node-name
-
-(defmethod dom:node-name ((self document))
- '#.(string-rod "#document"))
-
-(defmethod dom:node-name ((self document-fragment))
- '#.(string-rod "#document-fragment"))
-
-(defmethod dom:node-name ((self text))
- '#.(string-rod "#text"))
-
-(defmethod dom:node-name ((self cdata-section))
- '#.(string-rod "#cdata-section"))
-
-(defmethod dom:node-name ((self comment))
- '#.(string-rod "#comment"))
-
-(defmethod dom:node-name ((self attribute))
- (dom:name self))
-
-(defmethod dom:node-name ((self element))
- (dom:tag-name self))
-
-(defmethod dom:node-name ((self document-type))
- (dom:name self))
-
-(defmethod dom:node-name ((self notation))
- (dom:name self))
-
-(defmethod dom:node-name ((self entity))
- (dom:name self))
-
-(defmethod dom:node-name ((self entity-reference))
- (dom:name self))
-
-(defmethod dom:node-name ((self processing-instruction))
- (dom:target self))
-
-;; node-type
-
-(defmethod dom:node-type ((self document)) :document)
-(defmethod dom:node-type ((self document-fragment)) :document-fragment)
-(defmethod dom:node-type ((self text)) :text)
-(defmethod dom:node-type ((self comment)) :comment)
-(defmethod dom:node-type ((self cdata-section)) :cdata-section)
-(defmethod dom:node-type ((self attribute)) :attribute)
-(defmethod dom:node-type ((self element)) :element)
-(defmethod dom:node-type ((self document-type)) :document-type)
-(defmethod dom:node-type ((self notation)) :notation)
-(defmethod dom:node-type ((self entity)) :entity)
-(defmethod dom:node-type ((self entity-reference)) :entity-reference)
-(defmethod dom:node-type ((self processing-instruction)) :processing-instruction)
-
-;; node-value
-
-(defmethod dom:node-value ((self document)) nil)
-(defmethod dom:node-value ((self document-fragment)) nil)
-(defmethod dom:node-value ((self character-data)) (dom:data self))
-(defmethod dom:node-value ((self attribute)) (dom:name self))
-(defmethod dom:node-value ((self element)) nil)
-(defmethod dom:node-value ((self document-type)) nil)
-(defmethod dom:node-value ((self notation)) nil)
-(defmethod dom:node-value ((self entity)) nil)
-(defmethod dom:node-value ((self entity-reference)) nil)
-(defmethod dom:node-value ((self processing-instruction)) (dom:data self))
-
-;; attributes
-
-;; (gibt es nur auf element)
-
-(defmethod dom:attributes ((self node))
- nil)
-
-;; dann fehlt noch can-adopt und attribute conventions fuer adoption
-
-;;; NAMED-NODE-MAP
-
-(defmethod dom:get-named-item ((self named-node-map) name)
- (setf name (rod name))
- (with-slots (items) self
- (dolist (k items nil)
- (cond ((rod= name (dom:node-name k))
- (return k))))))
-
-(defmethod dom:set-named-item ((self named-node-map) arg)
- (let ((name (dom:node-name arg)))
- (with-slots (items) self
- (dolist (k items (progn (setf items (cons arg items))nil))
- (cond ((rod= name (dom:node-name k))
- (setf items (cons arg (delete k items)))
- (return k)))))))
-
-(defmethod dom:remove-named-item ((self named-node-map) name)
- (setf name (rod name))
- (with-slots (items) self
- (dolist (k items nil)
- (cond ((rod= name (dom:node-name k))
- (setf items (delete k items))
- (return k))))))
-
-(defmethod dom:length ((self named-node-map))
- (with-slots (items) self
- (length items)))
-
-(defmethod dom:item ((self named-node-map) index)
- (with-slots (items) self
- (elt items index)))
-
-;;; CHARACTER-DATA
-
-(defmethod dom:length ((node character-data))
- (length (slot-value node 'value)))
-
-(defmethod dom:substring-data ((node character-data) offset count)
- (subseq (slot-value node 'value) offset (+ offset count)))
-
-(defmethod dom:append-data ((node character-data) arg)
- (setq arg (rod arg))
- (with-slots (value) node
- (setf value (concatenate (type-of value) value arg)))
- (values))
-
-(defmethod dom:delete-data ((node character-data) offset count)
- (with-slots (value) node
- (let ((new (make-array (- (length value) count) :element-type (type-of value))))
- (replace new value
- :start1 0 :end1 offset
- :start2 0 :end2 offset)
- (replace new value
- :start1 offset :end1 (length new)
- :start2 (+ offset count) :end2 (length value))
- (setf value new)))
- (values))
-
-(defmethod dom:replace-data ((node character-data) offset count arg)
- (setf arg (rod arg))
- (with-slots (value) node
- (replace value arg
- :start1 offset :end1 (+ offset count)
- :start2 0 :end2 count))
- (values))
-
-;;; ATTR
-
-;; hmm... value muss noch entities lesen und text-nodes in die hierarchie hängen.
-
-(defmethod (setf dom:value) (new-value (node attribute))
- (setf (slot-value node 'value) (rod new-value)))
-
-;;; ELEMENT
-
-(defmethod dom:get-attribute-node ((element element) name)
- (dom:get-named-item (dom:attributes element) name))
-
-(defmethod dom:set-attribute-node ((element element) (new-attr attribute))
- (dom:set-named-item (dom:attributes element) new-attr))
-
-(defmethod dom:get-attribute ((element element) name)
- (let ((a (dom:get-attribute-node element name)))
- (if a
- (dom:value a)
- nil)))
-
-(defmethod dom:set-attribute ((element element) name value)
- (with-slots (owner) element
- (dom:set-attribute-node
- element (make-instance 'attribute
- :owner owner
- :name name
- :value value
- :specified-p t))
- (values)))
-
-(defmethod dom:remove-attribute-node ((element element) (old-attr attribute))
- (let ((res (dom:remove-named-item element (dom:name old-attr))))
- (if res
- res
- ;; NOT_FOUND_ERR
- (error "Attribute not found."))))
-
-(defmethod dom:get-elements-by-tag-name ((element element) name)
- name
- (error "Not implemented."))
-
-(defmethod dom:normalize ((element element))
- (error "Not implemented.") )
-
-;;; TEXT
-
-(defmethod dom:split-text ((text text) offset)
- offset
- (error "Not implemented."))
-
-;;; COMMENT -- nix
-;;; CDATA-SECTION -- nix
-
-;;; DOCUMENT-TYPE -- missing
-;;; NOTATION -- nix
-;;; ENTITY -- nix
-;;; ENTITY-REFERENCE -- nix
-;;; PROCESSING-INSTRUCTION -- nix
-
-;; Notbehelf!
-(defun can-adopt-p (x y) x y t)
-
-
-;;; predicates
-
-(defmethod dom:node-p ((object node)) t)
-(defmethod dom:node-p ((object t)) nil)
-
-(defmethod dom:document-p ((object document)) t)
-(defmethod dom:document-p ((object t)) nil)
-
-(defmethod dom:document-fragment-p ((object document-fragment)) t)
-(defmethod dom:document-fragment-p ((object t)) nil)
-
-(defmethod dom:character-data-p ((object character-data)) t)
-(defmethod dom:character-data-p ((object t)) nil)
-
-(defmethod dom:attribute-p ((object attribute)) t)
-(defmethod dom:attribute-p ((object t)) nil)
-
-(defmethod dom:element-p ((object element)) t)
-(defmethod dom:element-p ((object t)) nil)
-
-(defmethod dom:text-node-p ((object text)) t)
-(defmethod dom:text-node-p ((object t)) nil)
-
-(defmethod dom:comment-p ((object comment)) t)
-(defmethod dom:comment-p ((object t)) nil)
-
-(defmethod dom:cdata-section-p ((object cdata-section)) t)
-(defmethod dom:cdata-section-p ((object t)) nil)
-
-(defmethod dom:document-type-p ((object document-type)) t)
-(defmethod dom:document-type-p ((object t)) nil)
-
-(defmethod dom:notation-p ((object notation)) t)
-(defmethod dom:notation-p ((object t)) nil)
-
-(defmethod dom:entity-p ((object entity)) t)
-(defmethod dom:entity-p ((object t)) nil)
-
-(defmethod dom:entity-reference-p ((object entity-reference)) t)
-(defmethod dom:entity-reference-p ((object t)) nil)
-
-(defmethod dom:processing-instruction-p ((object processing-instruction)) t)
-(defmethod dom:processing-instruction-p ((object t)) nil)
-
-(defmethod dom:named-node-map-p ((object named-node-map)) t)
-(defmethod dom:named-node-map-p ((object t)) nil)
diff --git a/xml/dompack.lisp b/xml/dompack.lisp
deleted file mode 100644
index 247d638..0000000
--- a/xml/dompack.lisp
+++ /dev/null
@@ -1,102 +0,0 @@
-(defpackage :dom
- (:use)
- (:export
-
- ;; methods
- #:has-feature
- #:doctype
- #:implementation
- #:document-element
- #:create-element
- #:create-document-fragment
- #:create-text-node
- #:create-comment
- #:create-cdata-section
- #:create-processing-instruction
- #:create-attribute
- #:create-entity-reference
- #:get-elements-by-tag-name
- #:node-name
- #:node-value
- #:node-type
- #:parent-node
- #:child-nodes
- #:first-child
- #:last-child
- #:previous-sibling
- #:next-sibling
- #:attributes
- #:owner-document
- #:insert-before
- #:replace-child
- #:remove-child
- #:append-child
- #:has-child-nodes
- #:clone-node
- #:item
- #:length
- #:get-named-item
- #:set-named-item
- #:remove-named-item
- #:data
- #:substring-data
- #:append-data
- #:insert-data
- #:delete-data
- #:replace-data
- #:name
- #:specified
- #:value
- #:tag-name
- #:get-attribute
- #:set-attribute
- #:remove-atttribute
- #:get-attribute-node
- #:set-attribute-node
- #:remove-attribute-node
- #:normalize
- #:split-text
- #:entities
- #:notations
- #:public-id
- #:system-id
- #:notation-name
- #:target
-
- ;; protocol classes
- #:dom-implementation
- #:document-fragment
- #:document
- #:node
- #:node-list
- #:named-node-map
- #:character-data
- #:attr
- #:element
- #:text
- #:comment
- #:cdata-section
- #:document-type
- #:notation
- #:entity
- #:entity-reference
- #:processing-instruction
- ;;
- #:items
- ;;
- #:node-p
- #:document-p
- #:document-fragment-p
- #:character-data-p
- #:attribute-p
- #:element-p
- #:text-node-p
- #:comment-p
- #:cdata-section-p
- #:document-type-p
- #:notation-p
- #:entity-p
- #:entity-reference-p
- #:processing-instruction-p
- #:named-node-map-p
- ))
\ No newline at end of file
diff --git a/xml/encodings-data.lisp b/xml/encodings-data.lisp
deleted file mode 100644
index e29a683..0000000
--- a/xml/encodings-data.lisp
+++ /dev/null
@@ -1,568 +0,0 @@
-(in-package :encoding)
-
-(progn
- (add-name :us-ascii "ANSI_X3.4-1968")
- (add-name :us-ascii "iso-ir-6")
- (add-name :us-ascii "ANSI_X3.4-1986")
- (add-name :us-ascii "ISO_646.irv:1991")
- (add-name :us-ascii "ASCII")
- (add-name :us-ascii "ISO646-US")
- (add-name :us-ascii "US-ASCII")
- (add-name :us-ascii "us")
- (add-name :us-ascii "IBM367")
- (add-name :us-ascii "cp367")
- (add-name :us-ascii "csASCII")
-
- (add-name :iso-8859-1 "ISO_8859-1:1987")
- (add-name :iso-8859-1 "iso-ir-100")
- (add-name :iso-8859-1 "ISO_8859-1")
- (add-name :iso-8859-1 "ISO-8859-1")
- (add-name :iso-8859-1 "latin1")
- (add-name :iso-8859-1 "l1")
- (add-name :iso-8859-1 "IBM819")
- (add-name :iso-8859-1 "CP819")
- (add-name :iso-8859-1 "csISOLatin1")
-
- (add-name :iso-8859-2 "ISO_8859-2:1987")
- (add-name :iso-8859-2 "iso-ir-101")
- (add-name :iso-8859-2 "ISO_8859-2")
- (add-name :iso-8859-2 "ISO-8859-2")
- (add-name :iso-8859-2 "latin2")
- (add-name :iso-8859-2 "l2")
- (add-name :iso-8859-2 "csISOLatin2")
-
- (add-name :iso-8859-3 "ISO_8859-3:1988")
- (add-name :iso-8859-3 "iso-ir-109")
- (add-name :iso-8859-3 "ISO_8859-3")
- (add-name :iso-8859-3 "ISO-8859-3")
- (add-name :iso-8859-3 "latin3")
- (add-name :iso-8859-3 "l3")
- (add-name :iso-8859-3 "csISOLatin3")
-
- (add-name :iso-8859-4 "ISO_8859-4:1988")
- (add-name :iso-8859-4 "iso-ir-110")
- (add-name :iso-8859-4 "ISO_8859-4")
- (add-name :iso-8859-4 "ISO-8859-4")
- (add-name :iso-8859-4 "latin4")
- (add-name :iso-8859-4 "l4")
- (add-name :iso-8859-4 "csISOLatin4")
-
- (add-name :iso-8859-6 "ISO_8859-6:1987")
- (add-name :iso-8859-6 "iso-ir-127")
- (add-name :iso-8859-6 "ISO_8859-6")
- (add-name :iso-8859-6 "ISO-8859-6")
- (add-name :iso-8859-6 "ECMA-114")
- (add-name :iso-8859-6 "ASMO-708")
- (add-name :iso-8859-6 "arabic")
- (add-name :iso-8859-6 "csISOLatinArabic")
-
- (add-name :iso-8859-7 "ISO_8859-7:1987")
- (add-name :iso-8859-7 "iso-ir-126")
- (add-name :iso-8859-7 "ISO_8859-7")
- (add-name :iso-8859-7 "ISO-8859-7")
- (add-name :iso-8859-7 "ELOT_928")
- (add-name :iso-8859-7 "ECMA-118")
- (add-name :iso-8859-7 "greek")
- (add-name :iso-8859-7 "greek8")
- (add-name :iso-8859-7 "csISOLatinGreek")
-
- (add-name :iso-8859-8 "ISO_8859-8:1988")
- (add-name :iso-8859-8 "iso-ir-138")
- (add-name :iso-8859-8 "ISO_8859-8")
- (add-name :iso-8859-8 "ISO-8859-8")
- (add-name :iso-8859-8 "hebrew")
- (add-name :iso-8859-8 "csISOLatinHebrew")
-
- (add-name :iso-8859-5 "ISO_8859-5:1988")
- (add-name :iso-8859-5 "iso-ir-144")
- (add-name :iso-8859-5 "ISO_8859-5")
- (add-name :iso-8859-5 "ISO-8859-5")
- (add-name :iso-8859-5 "cyrillic")
- (add-name :iso-8859-5 "csISOLatinCyrillic")
-
- (add-name :iso-8859-9 "ISO_8859-9:1989")
- (add-name :iso-8859-9 "iso-ir-148")
- (add-name :iso-8859-9 "ISO_8859-9")
- (add-name :iso-8859-9 "ISO-8859-9")
- (add-name :iso-8859-9 "latin5")
- (add-name :iso-8859-9 "l5")
- (add-name :iso-8859-9 "csISOLatin5")
-
- (add-name :iso-8859-15 "ISO_8859-15")
- (add-name :iso-8859-15 "ISO-8859-15")
-
- (add-name :iso-8859-14 "ISO_8859-14")
- (add-name :iso-8859-14 "ISO-8859-14")
-
- (add-name :koi8-r "KOI8-R")
- (add-name :koi8-r "csKOI8R")
-
- (add-name :utf-8 "UTF-8")
-
- (add-name :utf-16 "UTF-16")
-
- (add-name :ucs-4 "ISO-10646-UCS-4")
- (add-name :ucs-4 "UCS-4")
-
- (add-name :ucs-2 "ISO-10646-UCS-2")
- (add-name :ucs-2 "UCS-2") )
-
-
-(progn
- (define-encoding :iso-8859-1
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-1)))
-
- (define-encoding :iso-8859-2
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-2)))
-
- (define-encoding :iso-8859-3
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-3)))
-
- (define-encoding :iso-8859-4
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-4)))
-
- (define-encoding :iso-8859-5
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-5)))
-
- (define-encoding :iso-8859-6
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-6)))
-
- (define-encoding :iso-8859-7
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-7)))
-
- (define-encoding :iso-8859-8
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-8)))
-
- (define-encoding :iso-8859-14
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-14)))
-
- (define-encoding :iso-8859-15
- (make-simple-8-bit-encoding
- :charset (find-charset :iso-8859-15)))
-
- (define-encoding :koi8-r
- (make-simple-8-bit-encoding
- :charset (find-charset :koi8-r)))
-
- (define-encoding :utf-8 :utf-8)
- )
-
-(progn
- (define-8-bit-charset :iso-8859-1
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
- #| #o25x |# #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
- #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
- #| #o27x |# #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF
- #| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
- #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
- #| #o32x |# #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
- #| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF
- #| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
- #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
- #| #o36x |# #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
- #| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
-
- (define-8-bit-charset :iso-8859-2
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x0104 #x02D8 #x0141 #x00A4 #x013D #x015A #x00A7
- #| #o25x |# #x00A8 #x0160 #x015E #x0164 #x0179 #x00AD #x017D #x017B
- #| #o26x |# #x00B0 #x0105 #x02DB #x0142 #x00B4 #x013E #x015B #x02C7
- #| #o27x |# #x00B8 #x0161 #x015F #x0165 #x017A #x02DD #x017E #x017C
- #| #o30x |# #x0154 #x00C1 #x00C2 #x0102 #x00C4 #x0139 #x0106 #x00C7
- #| #o31x |# #x010C #x00C9 #x0118 #x00CB #x011A #x00CD #x00CE #x010E
- #| #o32x |# #x0110 #x0143 #x0147 #x00D3 #x00D4 #x0150 #x00D6 #x00D7
- #| #o33x |# #x0158 #x016E #x00DA #x0170 #x00DC #x00DD #x0162 #x00DF
- #| #o34x |# #x0155 #x00E1 #x00E2 #x0103 #x00E4 #x013A #x0107 #x00E7
- #| #o35x |# #x010D #x00E9 #x0119 #x00EB #x011B #x00ED #x00EE #x010F
- #| #o36x |# #x0111 #x0144 #x0148 #x00F3 #x00F4 #x0151 #x00F6 #x00F7
- #| #o37x |# #x0159 #x016F #x00FA #x0171 #x00FC #x00FD #x0163 #x02D9)
-
- (define-8-bit-charset :iso-8859-3
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x0126 #x02D8 #x00A3 #x00A4 #xFFFF #x0124 #x00A7
- #| #o25x |# #x00A8 #x0130 #x015E #x011E #x0134 #x00AD #xFFFF #x017B
- #| #o26x |# #x00B0 #x0127 #x00B2 #x00B3 #x00B4 #x00B5 #x0125 #x00B7
- #| #o27x |# #x00B8 #x0131 #x015F #x011F #x0135 #x00BD #xFFFF #x017C
- #| #o30x |# #x00C0 #x00C1 #x00C2 #xFFFF #x00C4 #x010A #x0108 #x00C7
- #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
- #| #o32x |# #xFFFF #x00D1 #x00D2 #x00D3 #x00D4 #x0120 #x00D6 #x00D7
- #| #o33x |# #x011C #x00D9 #x00DA #x00DB #x00DC #x016C #x015C #x00DF
- #| #o34x |# #x00E0 #x00E1 #x00E2 #xFFFF #x00E4 #x010B #x0109 #x00E7
- #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
- #| #o36x |# #xFFFF #x00F1 #x00F2 #x00F3 #x00F4 #x0121 #x00F6 #x00F7
- #| #o37x |# #x011D #x00F9 #x00FA #x00FB #x00FC #x016D #x015D #x02D9)
-
- (define-8-bit-charset :iso-8859-4
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x0104 #x0138 #x0156 #x00A4 #x0128 #x013B #x00A7
- #| #o25x |# #x00A8 #x0160 #x0112 #x0122 #x0166 #x00AD #x017D #x00AF
- #| #o26x |# #x00B0 #x0105 #x02DB #x0157 #x00B4 #x0129 #x013C #x02C7
- #| #o27x |# #x00B8 #x0161 #x0113 #x0123 #x0167 #x014A #x017E #x014B
- #| #o30x |# #x0100 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x012E
- #| #o31x |# #x010C #x00C9 #x0118 #x00CB #x0116 #x00CD #x00CE #x012A
- #| #o32x |# #x0110 #x0145 #x014C #x0136 #x00D4 #x00D5 #x00D6 #x00D7
- #| #o33x |# #x00D8 #x0172 #x00DA #x00DB #x00DC #x0168 #x016A #x00DF
- #| #o34x |# #x0101 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x012F
- #| #o35x |# #x010D #x00E9 #x0119 #x00EB #x0117 #x00ED #x00EE #x012B
- #| #o36x |# #x0111 #x0146 #x014D #x0137 #x00F4 #x00F5 #x00F6 #x00F7
- #| #o37x |# #x00F8 #x0173 #x00FA #x00FB #x00FC #x0169 #x016B #x02D9)
-
- (define-8-bit-charset :iso-8859-5
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407
- #| #o25x |# #x0408 #x0409 #x040A #x040B #x040C #x00AD #x040E #x040F
- #| #o26x |# #x0410 #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417
- #| #o27x |# #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E #x041F
- #| #o30x |# #x0420 #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427
- #| #o31x |# #x0428 #x0429 #x042A #x042B #x042C #x042D #x042E #x042F
- #| #o32x |# #x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437
- #| #o33x |# #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E #x043F
- #| #o34x |# #x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447
- #| #o35x |# #x0448 #x0449 #x044A #x044B #x044C #x044D #x044E #x044F
- #| #o36x |# #x2116 #x0451 #x0452 #x0453 #x0454 #x0455 #x0456 #x0457
- #| #o37x |# #x0458 #x0459 #x045A #x045B #x045C #x00A7 #x045E #x045F)
-
- (define-8-bit-charset :iso-8859-6
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0660 #x0661 #x0662 #x0663 #x0664 #x0665 #x0666 #x0667
- #| #o07x |# #x0668 #x0669 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #xFFFF #xFFFF #xFFFF #x00A4 #xFFFF #xFFFF #xFFFF
- #| #o25x |# #xFFFF #xFFFF #xFFFF #xFFFF #x060C #x00AD #xFFFF #xFFFF
- #| #o26x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o27x |# #xFFFF #xFFFF #xFFFF #x061B #xFFFF #xFFFF #xFFFF #x061F
- #| #o30x |# #xFFFF #x0621 #x0622 #x0623 #x0624 #x0625 #x0626 #x0627
- #| #o31x |# #x0628 #x0629 #x062A #x062B #x062C #x062D #x062E #x062F
- #| #o32x |# #x0630 #x0631 #x0632 #x0633 #x0634 #x0635 #x0636 #x0637
- #| #o33x |# #x0638 #x0639 #x063A #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o34x |# #x0640 #x0641 #x0642 #x0643 #x0644 #x0645 #x0646 #x0647
- #| #o35x |# #x0648 #x0649 #x064A #x064B #x064C #x064D #x064E #x064F
- #| #o36x |# #x0650 #x0651 #x0652 #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o37x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF)
-
- (define-8-bit-charset :iso-8859-7
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x02BD #x02BC #x00A3 #xFFFF #xFFFF #x00A6 #x00A7
- #| #o25x |# #x00A8 #x00A9 #xFFFF #x00AB #x00AC #x00AD #xFFFF #x2015
- #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x0384 #x0385 #x0386 #x00B7
- #| #o27x |# #x0388 #x0389 #x038A #x00BB #x038C #x00BD #x038E #x038F
- #| #o30x |# #x0390 #x0391 #x0392 #x0393 #x0394 #x0395 #x0396 #x0397
- #| #o31x |# #x0398 #x0399 #x039A #x039B #x039C #x039D #x039E #x039F
- #| #o32x |# #x03A0 #x03A1 #xFFFF #x03A3 #x03A4 #x03A5 #x03A6 #x03A7
- #| #o33x |# #x03A8 #x03A9 #x03AA #x03AB #x03AC #x03AD #x03AE #x03AF
- #| #o34x |# #x03B0 #x03B1 #x03B2 #x03B3 #x03B4 #x03B5 #x03B6 #x03B7
- #| #o35x |# #x03B8 #x03B9 #x03BA #x03BB #x03BC #x03BD #x03BE #x03BF
- #| #o36x |# #x03C0 #x03C1 #x03C2 #x03C3 #x03C4 #x03C5 #x03C6 #x03C7
- #| #o37x |# #x03C8 #x03C9 #x03CA #x03CB #x03CC #x03CD #x03CE #xFFFF)
-
- (define-8-bit-charset :iso-8859-8
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #xFFFF #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
- #| #o25x |# #x00A8 #x00A9 #x00D7 #x00AB #x00AC #x00AD #x00AE #x203E
- #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
- #| #o27x |# #x00B8 #x00B9 #x00F7 #x00BB #x00BC #x00BD #x00BE #xFFFF
- #| #o30x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o31x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o32x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o33x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #x2017
- #| #o34x |# #x05D0 #x05D1 #x05D2 #x05D3 #x05D4 #x05D5 #x05D6 #x05D7
- #| #o35x |# #x05D8 #x05D9 #x05DA #x05DB #x05DC #x05DD #x05DE #x05DF
- #| #o36x |# #x05E0 #x05E1 #x05E2 #x05E3 #x05E4 #x05E5 #x05E6 #x05E7
- #| #o37x |# #x05E8 #x05E9 #x05EA #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF)
-
- (define-8-bit-charset :iso-8859-9
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
- #| #o25x |# #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
- #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
- #| #o27x |# #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF
- #| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
- #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
- #| #o32x |# #x011E #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
- #| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x0130 #x015E #x00DF
- #| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
- #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
- #| #o36x |# #x011F #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
- #| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x0131 #x015F #x00FF)
-
- (define-8-bit-charset :iso-8859-14
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x1E02 #x1E03 #x00A3 #x010A #x010B #x1E0A #x00A7
- #| #o25x |# #x1E80 #x00A9 #x1E82 #x1E0B #x1EF2 #x00AD #x00AE #x0178
- #| #o26x |# #x1E1E #x1E1F #x0120 #x0121 #x1E40 #x1E41 #x00B6 #x1E56
- #| #o27x |# #x1E81 #x1E57 #x1E83 #x1E60 #x1EF3 #x1E84 #x1E85 #x1E61
- #| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
- #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
- #| #o32x |# #x0174 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x1E6A
- #| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x0176 #x00DF
- #| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
- #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
- #| #o36x |# #x0175 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x1E6B
- #| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x0177 #x00FF)
-
- (define-8-bit-charset :iso-8859-15
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
- #| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x20AC #x00A5 #x0160 #x00A7
- #| #o25x |# #x0161 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
- #| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x017D #x00B5 #x00B6 #x00B7
- #| #o27x |# #x017E #x00B9 #x00BA #x00BB #x0152 #x0153 #x0178 #x00BF
- #| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
- #| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
- #| #o32x |# #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
- #| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF
- #| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
- #| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
- #| #o36x |# #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
- #| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
-
- (define-8-bit-charset :koi8-r
- #| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
- #| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
- #| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
- #| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
- #| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
- #| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
- #| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
- #| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
- #| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
- #| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
- #| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
- #| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
- #| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
- #| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
- #| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
- #| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
- #| #o20x |# #x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
- #| #o21x |# #x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
- #| #o22x |# #x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
- #| #o23x |# #x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
- #| #o24x |# #x2550 #x2551 #x2552 #x0451 #x2553 #x2554 #x2555 #x2556
- #| #o25x |# #x2557 #x2558 #x2559 #x255A #x255B #x255C #x255D #x255E
- #| #o26x |# #x255F #x2560 #x2561 #x0401 #x2562 #x2563 #x2564 #x2565
- #| #o27x |# #x2566 #x2567 #x2568 #x2569 #x256A #x256B #x256C #x00A9
- #| #o30x |# #x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
- #| #o31x |# #x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
- #| #o32x |# #x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
- #| #o33x |# #x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
- #| #o34x |# #x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
- #| #o35x |# #x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
- #| #o36x |# #x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
- #| #o37x |# #x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A)
- )
-
diff --git a/xml/encodings.lisp b/xml/encodings.lisp
deleted file mode 100644
index 96e7f98..0000000
--- a/xml/encodings.lisp
+++ /dev/null
@@ -1,347 +0,0 @@
-(in-package :encoding)
-
-;;;; ---------------------------------------------------------------------------
-;;;; Encoding names
-;;;;
-
-(defvar *names* (make-hash-table :test #'eq))
-
-(defun canon-name (string)
- (with-output-to-string (bag)
- (map nil (lambda (ch)
- (cond ((char= ch #\_) (write-char #\- bag))
- (t (write-char (char-upcase ch) bag))))
- string)))
-
-(defun canon-name-2 (string)
- (with-output-to-string (bag)
- (map nil (lambda (ch)
- (cond ((char= ch #\_))
- ((char= ch #\-))
- (t (write-char (char-upcase ch) bag))))
- string)))
-
-(defmethod encoding-names ((encoding symbol))
- (gethash encoding *names*))
-
-(defmethod (setf encoding-names) (new-value (encoding symbol))
- (setf (gethash encoding *names*) new-value))
-
-(defun add-name (encoding name)
- (pushnew (canon-name name) (encoding-names encoding) :test #'string=))
-
-(defun resolve-name (string)
- (cond ((symbolp string)
- string)
- (t
- (setq string (canon-name string))
- (or
- (block nil
- (maphash (lambda (x y)
- (when (member string y :test #'string=)
- (return x)))
- *names*)
- nil)
- (block nil
- (maphash (lambda (x y)
- (when (member string y
- :test #'(lambda (x y)
- (string= (canon-name-2 x)
- (canon-name-2 y))))
- (return x)))
- *names*)
- nil)))))
-
-;;;; ---------------------------------------------------------------------------
-;;;; Encodings
-;;;;
-
-(defvar *encodings* (make-hash-table :test #'eq))
-
-(defmacro define-encoding (name init-form)
- `(progn
- (setf (gethash ',name *encodings*)
- (list nil (lambda () ,init-form)))
- ',name))
-
-(defun find-encoding (name)
- (let ((x (gethash (resolve-name name) *encodings*)))
- (and x
- (or (first x)
- (setf (first x) (funcall (second x)))))))
-
-(defclass encoding () ())
-
-(defclass simple-8-bit-encoding (encoding)
- ((table :initarg :table)))
-
-(defun make-simple-8-bit-encoding (&key charset)
- (make-instance 'simple-8-bit-encoding
- :table (coerce (to-unicode-table charset) '(simple-array (unsigned-byte 16) (256)))))
-
-;;;;;;;
-
-(defmacro fx-op (op &rest xs)
- `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
-(defmacro fx-pred (op &rest xs)
- `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
-
-(defmacro %+ (&rest xs) `(fx-op + ,@xs))
-(defmacro %- (&rest xs) `(fx-op - ,@xs))
-(defmacro %* (&rest xs) `(fx-op * ,@xs))
-(defmacro %/ (&rest xs) `(fx-op floor ,@xs))
-(defmacro %and (&rest xs) `(fx-op logand ,@xs))
-(defmacro %ior (&rest xs) `(fx-op logior ,@xs))
-(defmacro %xor (&rest xs) `(fx-op logxor ,@xs))
-(defmacro %ash (&rest xs) `(fx-op ash ,@xs))
-(defmacro %mod (&rest xs) `(fx-op mod ,@xs))
-
-(defmacro %= (&rest xs) `(fx-pred = ,@xs))
-(defmacro %<= (&rest xs) `(fx-pred <= ,@xs))
-(defmacro %>= (&rest xs) `(fx-pred >= ,@xs))
-(defmacro %< (&rest xs) `(fx-pred < ,@xs))
-(defmacro %> (&rest xs) `(fx-pred > ,@xs))
-
-(defmethod decode-sequence ((encoding (eql :utf-16-big-endian))
- in in-start in-end out out-start out-end eof?)
- ;; -> new wptr, new rptr
- (let ((wptr out-start)
- (rptr in-start))
- (loop
- (when (%= wptr out-end)
- (return))
- (when (>= (%+ rptr 1) in-end)
- (return))
- (let ((hi (aref in rptr))
- (lo (aref in (%+ 1 rptr))))
- (setf rptr (%+ 2 rptr))
- (setf (aref out wptr) (logior (ash hi 8) lo))
- (setf wptr (%+ 1 wptr))))
- (values wptr rptr)))
-
-(defmethod decode-sequence ((encoding (eql :utf-16-little-endian))
- in in-start in-end out out-start out-end eof?)
- ;; -> new wptr, new rptr
- (let ((wptr out-start)
- (rptr in-start))
- (loop
- (when (%= wptr out-end)
- (return))
- (when (>= (%+ rptr 1) in-end)
- (return))
- (let ((lo (aref in (%+ 0 rptr)))
- (hi (aref in (%+ 1 rptr))))
- (setf rptr (%+ 2 rptr))
- (setf (aref out wptr) (logior (ash hi 8) lo))
- (setf wptr (%+ 1 wptr))))
- (values wptr rptr)))
-
-(defmethod decode-sequence ((encoding (eql :utf-8))
- in in-start in-end out out-start out-end eof?)
- (declare (optimize (speed 3) (safety 0))
- (type (simple-array (unsigned-byte 8) (*)) in)
- (type (simple-array rune (*)) out)
- (type fixnum in-start in-end out-start out-end))
- (let ((wptr out-start)
- (rptr in-start)
- byte0)
- (macrolet ((put (x)
- `((lambda (x)
- (cond ((or (<= #xD800 x #xDBFF)
- (<= #xDC00 x #xDFFF))
- (error "Encoding UTF-16 in UTF-8? : #x~x." x)))
- '(unless (data-char-p x)
- (error "#x~x is not a data character." x))
- ;;(fresh-line)
- ;;(prin1 x) (princ "-> ")
- (cond ((%> x #xFFFF)
- (setf (aref out (%+ 0 wptr)) (%+ #xD7C0 (ash x -10))
- (aref out (%+ 1 wptr)) (%ior #xDC00 (%and x #x3FF)))
- (setf wptr (%+ wptr 2)))
- (t
- (setf (aref out wptr) x)
- (setf wptr (%+ wptr 1)))))
- ,x))
- (put1 (x)
- `(progn
- (setf (aref out wptr) ,x)
- (setf wptr (%+ wptr 1)))))
- (loop
- (when (%= (+ wptr 1) out-end) (return))
- (when (%>= rptr in-end) (return))
- (setq byte0 (aref in rptr))
- (cond ((= byte0 #x0D)
- ;; CR handling
- ;; we need to know the following character
- (cond ((>= (%+ rptr 1) in-end)
- ;; no characters in buffer
- (cond (eof?
- ;; at EOF, pass it as NL
- (put #x0A)
- (setf rptr (%+ rptr 1)))
- (t
- ;; demand more characters
- (return))))
- ((= (aref in (%+ rptr 1)) #x0A)
- ;; we see CR NL, so forget this CR and the next NL will be
- ;; inserted literally
- (setf rptr (%+ rptr 1)))
- (t
- ;; singleton CR, pass it as NL
- (put #x0A)
- (setf rptr (%+ rptr 1)))))
-
- ((%<= #|#b00000000|# byte0 #b01111111)
- (put1 byte0)
- (setf rptr (%+ rptr 1)))
-
- ((%<= #|#b10000000|# byte0 #b10111111)
- (error "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)
- (setf rptr (%+ rptr 1)))
-
- ((%<= #|#b11000000|# byte0 #b11011111)
- (cond ((< (%+ rptr 2) in-end)
- (put
- (dpb (ldb (byte 5 0) byte0) (byte 5 6)
- (dpb (ldb (byte 6 0) (aref in (%+ rptr 1))) (byte 6 0)
- 0)))
- (setf rptr (%+ rptr 2)))
- (t
- (return))))
-
- ((%<= #|#b11100000|# byte0 #b11101111)
- (cond ((< (%+ rptr 3) in-end)
- (put
- (dpb (ldb (byte 4 0) byte0) (byte 4 12)
- (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 6)
- (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 0)
- 0))))
- (setf rptr (%+ rptr 3)))
- (t
- (return))))
-
- ((%<= #|#b11110000|# byte0 #b11110111)
- (cond ((< (%+ rptr 4) in-end)
- (put
- (dpb (ldb (byte 3 0) byte0) (byte 3 18)
- (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 12)
- (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 6)
- (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 0)
- 0)))))
- (setf rptr (%+ rptr 4)))
- (t
- (return))))
-
- ((%<= #|#b11111000|# byte0 #b11111011)
- (cond ((< (%+ rptr 5) in-end)
- (put
- (dpb (ldb (byte 2 0) byte0) (byte 2 24)
- (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 18)
- (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 12)
- (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 6)
- (dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 0)
- 0))))))
- (setf rptr (%+ rptr 5)))
- (t
- (return))))
-
- ((%<= #|#b11111100|# byte0 #b11111101)
- (cond ((< (%+ rptr 6) in-end)
- (put
- (dpb (ldb (byte 1 0) byte0) (byte 1 30)
- (dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 24)
- (dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 18)
- (dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 12)
- (dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 6)
- (dpb (ldb (byte 6 0) (aref in (%+ 5 rptr))) (byte 6 0)
- 0)))))))
- (setf rptr (%+ rptr 6)))
- (t
- (return))))
-
- (t
- (error "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)) ) ))
- (values wptr rptr)) )
-
-(defmethod encoding-p ((object (eql :utf-16-little-endian))) t)
-(defmethod encoding-p ((object (eql :utf-16-big-endian))) t)
-(defmethod encoding-p ((object (eql :utf-8))) t)
-
-(defmethod encoding-p ((object encoding)) t)
-
-(defmethod decode-sequence ((encoding simple-8-bit-encoding)
- in in-start in-end
- out out-start out-end
- eof?)
- (declare (optimize (speed 3) (safety 0))
- (type (simple-array (unsigned-byte 8) (*)) in)
- (type (simple-array rune (*)) out)
- (type fixnum in-start in-end out-start out-end))
- (let ((wptr out-start)
- (rptr in-start)
- (byte 0)
- (table (slot-value encoding 'table)))
- (declare (type fixnum wptr rptr)
- (type (unsigned-byte 8) byte)
- (type (simple-array (unsigned-byte 16) (*)) table))
- (loop
- (when (%= wptr out-end) (return))
- (when (%>= rptr in-end) (return))
- (setq byte (aref in rptr))
- (cond ((= byte #x0D)
- ;; CR handling
- ;; we need to know the following character
- (cond ((>= (%+ rptr 1) in-end)
- ;; no characters in buffer
- (cond (eof?
- ;; at EOF, pass it as NL
- (setf (aref out wptr) #x0A)
- (setf wptr (%+ wptr 1))
- (setf rptr (%+ rptr 1)))
- (t
- ;; demand more characters
- (return))))
- ((= (aref in (%+ rptr 1)) #x0A)
- ;; we see CR NL, so forget this CR and the next NL will be
- ;; inserted literally
- (setf rptr (%+ rptr 1)))
- (t
- ;; singleton CR, pass it as NL
- (setf (aref out wptr) #x0A)
- (setf wptr (%+ wptr 1))
- (setf rptr (%+ rptr 1)))))
-
- (t
- (setf (aref out wptr) (aref table byte))
- (setf wptr (%+ wptr 1))
- (setf rptr (%+ rptr 1))) ))
- (values wptr rptr)))
-
-;;;; ---------------------------------------------------------------------------
-;;;; Character sets
-;;;;
-
-(defvar *charsets* (make-hash-table :test #'eq))
-
-(defclass 8-bit-charset ()
- ((name :initarg :name)
- (to-unicode-table
- :initarg :to-unicode-table
- :reader to-unicode-table)))
-
-(defmacro define-8-bit-charset (name &rest codes)
- (assert (= 256 (length codes)))
- `(progn
- (setf (gethash ',name *charsets*)
- (make-instance '8-bit-charset
- :name ',name
- :to-unicode-table
- ',(make-array 256
- :element-type '(unsigned-byte 16)
- :initial-contents codes)))
- ',name))
-
-(defun find-charset (name)
- (or (gethash name *charsets*)
- (error "There is no character set named ~S." name)))
-
diff --git a/xml/string-dom.lisp b/xml/string-dom.lisp
deleted file mode 100644
index 91e6458..0000000
--- a/xml/string-dom.lisp
+++ /dev/null
@@ -1,35 +0,0 @@
-(defpackage :string-dom
- (:use))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (do-external-symbols (var :cdom)
- (let* ((home-package
- (if (member var '(cdom:data cdom:name cdom:value cdom:tag-name
- cdom:node-name cdom:node-value
- cdom:substring-data cdom:get-attribute))
- :string-dom
- :cdom))
- (symbol (intern (symbol-name var) home-package)))
- (import symbol :string-dom)
- (export (list symbol) :string-dom))))
-
-(defpackage :string-dom-impl (:use :cl))
-(in-package :string-dom-impl)
-
-(defun rod-to-string (frob)
- (if (null frob)
- nil
- (map 'string #'code-char frob)))
-
-(defun string-dom:data (node) (rod-to-string (cdom:data node)))
-(defun string-dom:name (node) (rod-to-string (cdom:name node)))
-(defun string-dom:value (node) (rod-to-string (cdom:value node)))
-(defun string-dom:tag-name (node) (rod-to-string (cdom:tag-name node)))
-(defun string-dom:node-name (node) (rod-to-string (cdom:node-name node)))
-(defun string-dom:node-value (node) (rod-to-string (cdom:node-value node)))
-
-(defun string-dom:substring-data (node offset count)
- (rod-to-string (cdom:substring-data node offset count)))
-
-(defun string-dom:get-attribute (elt name)
- (rod-to-string (cdom:get-attribute elt name)))
diff --git a/xml/xml-canonic.lisp b/xml/xml-canonic.lisp
deleted file mode 100644
index f9e0d48..0000000
--- a/xml/xml-canonic.lisp
+++ /dev/null
@@ -1,172 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: glisp; Encoding: utf-8; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Dump canonic XML according to J.Clark
-;;; Created: 1999-09-09
-;;; Author: Gilbert Baumann
-;;; License: LGPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; © copyright 1999 by Gilbert Baumann
-
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Library General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 2 of the License, or (at your option) any later version.
-;;;
-;;; This library 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
-;;; Library General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Library General Public
-;;; License along with this library; if not, write to the
-;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;;; Boston, MA 02111-1307 USA.
-
-(in-package :xml)
-
-;;
-;; | Canonical XML
-;; | =============
-;; |
-;; | This document defines a subset of XML called canonical XML. The
-;; | intended use of canonical XML is in testing XML processors, as a
-;; | representation of the result of parsing an XML document.
-;; |
-;; | Every well-formed XML document has a unique structurally equivalent
-;; | canonical XML document. Two structurally equivalent XML documents have
-;; | a byte-for-byte identical canonical XML document. Canonicalizing an
-;; | XML document requires only information that an XML processor is
-;; | required to make available to an application.
-;; |
-;; | A canonical XML document conforms to the following grammar:
-;; |
-;; | CanonXML ::= Pi* element Pi*
-;; | element ::= Stag (Datachar | Pi | element)* Etag
-;; | Stag ::= '<' Name Atts '>'
-;; | Etag ::= ''
-;; | Pi ::= '' Char*)) '?>'
-;; | Atts ::= (' ' Name '=' '"' Datachar* '"')*
-;; | Datachar ::= '&' | '<' | '>' | '"'
-;; | | ' '| '
'| '
'
-;; | | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD))
-;; | Name ::= (see XML spec)
-;; | Char ::= (see XML spec)
-;; | S ::= (see XML spec)
-;; |
-;; | Attributes are in lexicographical order (in Unicode bit order).
-;; |
-;; | A canonical XML document is encoded in UTF-8.
-;; |
-;; | Ignorable white space is considered significant and is treated
-;; | equivalently to data.
-;;
-;; -- James Clark (jjc@jclark.com)
-
-(defvar *quux*) ;!!!BIG HACK!!!
-
-(defun unparse-document (doc sink)
- (mapc (rcurry #'unparse-node sink) (dom:child-nodes doc)))
-
-(defun unparse-node (node sink)
- (cond ((dom:element-p node)
- (write-rune #/< sink)
- (write-rod (dom:tag-name node) sink)
- ;; atts
- (let ((atts (sort (copy-list (dom:items (dom:attributes node)))
- #'rod< :key #'dom:name)))
- (dolist (a atts)
- (write-rune #/space sink)
- (write-rod (dom:name a) sink)
- (write-rune #/= sink)
- (write-rune #/\" sink)
- (let ((*quux* nil))
- (map nil (lambda (c) (unparse-datachar c sink)) (dom:value a)))
- (write-rune #/\" sink)))
- (write-rod '#.(string-rod ">") sink)
- (dolist (k (dom:child-nodes node))
- (unparse-node k sink))
- (write-rod '#.(string-rod "") sink))
- ((dom:processing-instruction-p node)
- (unless (rod-equal (dom:target node) '#.(string-rod "xml"))
- (write-rod '#.(string-rod "") sink) ))
- ((dom:text-node-p node)
- (let ((*quux* nil))
- (map nil (lambda (c) (unparse-datachar c sink))
- (dom:data node))))
- (t
- (error "Oops in unparse: ~S." node))))
-
-(defun unparse-datachar (c sink)
- (cond ((rune= c #/&) (write-rod '#.(string-rod "&") sink))
- ((rune= c #/<) (write-rod '#.(string-rod "<") sink))
- ((rune= c #/>) (write-rod '#.(string-rod ">") sink))
- ((rune= c #/\") (write-rod '#.(string-rod """) sink))
- ((rune= c #/U+0009) (write-rod '#.(string-rod " ") sink))
- ((rune= c #/U+000A) (write-rod '#.(string-rod "
") sink))
- ((rune= c #/U+000D) (write-rod '#.(string-rod "
") sink))
- (t
- (write-rune c sink))))
-
-(defun write-rod (rod sink)
- (let ((*quux* nil))
- (map nil (lambda (c) (write-rune c sink)) rod)))
-
-(defun write-rune (rune sink)
- (cond ((<= #xD800 rune #xDBFF)
- (setf *quux* rune))
- ((<= #xDC00 rune #xDFFF)
- (let ((q (logior (ash (- *quux* #xD7C0) 10) (- rune #xDC00))))
- (write-rune-0 q sink))
- (setf *quux* nil))
- (t
- (write-rune-0 rune sink))))
-
-(defun write-rune-0 (rune sink)
- (labels ((wr (x)
- (write-char (code-char x) sink)))
- (cond ((<= #x00000000 rune #x0000007F)
- (wr rune))
- ((<= #x00000080 rune #x000007FF)
- (wr (logior #b11000000 (ldb (byte 5 6) rune)))
- (wr (logior #b10000000 (ldb (byte 6 0) rune))))
- ((<= #x00000800 rune #x0000FFFF)
- (wr (logior #b11100000 (ldb (byte 4 12) rune)))
- (wr (logior #b10000000 (ldb (byte 6 6) rune)))
- (wr (logior #b10000000 (ldb (byte 6 0) rune))))
- ((<= #x00010000 rune #x001FFFFF)
- (wr (logior #b11110000 (ldb (byte 3 18) rune)))
- (wr (logior #b10000000 (ldb (byte 6 12) rune)))
- (wr (logior #b10000000 (ldb (byte 6 6) rune)))
- (wr (logior #b10000000 (ldb (byte 6 0) rune))))
- ((<= #x00200000 rune #x03FFFFFF)
- (wr (logior #b11111000 (ldb (byte 2 24) rune)))
- (wr (logior #b10000000 (ldb (byte 6 18) rune)))
- (wr (logior #b10000000 (ldb (byte 6 12) rune)))
- (wr (logior #b10000000 (ldb (byte 6 6) rune)))
- (wr (logior #b10000000 (ldb (byte 6 0) rune))))
- ((<= #x04000000 rune #x7FFFFFFF)
- (wr (logior #b11111100 (ldb (byte 1 30) rune)))
- (wr (logior #b10000000 (ldb (byte 6 24) rune)))
- (wr (logior #b10000000 (ldb (byte 6 18) rune)))
- (wr (logior #b10000000 (ldb (byte 6 12) rune)))
- (wr (logior #b10000000 (ldb (byte 6 6) rune)))
- (wr (logior #b10000000 (ldb (byte 6 0) rune)))))))
-
-(defun rod< (rod1 rod2)
- (do ((i 0 (+ i 1)))
- (nil)
- (cond ((= i (length rod1))
- (return t))
- ((= i (length rod2))
- (return nil))
- ((< (aref rod1 i) (aref rod2 i))
- (return t))
- ((> (aref rod1 i) (aref rod2 i))
- (return nil)))))
-
diff --git a/xml/xml-stream.lisp b/xml/xml-stream.lisp
deleted file mode 100644
index 7cd9d9f..0000000
--- a/xml/xml-stream.lisp
+++ /dev/null
@@ -1,370 +0,0 @@
-;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: glisp; Encoding: utf-8; -*-
-;;; ---------------------------------------------------------------------------
-;;; Title: Fast streams
-;;; Created: 1999-07-17
-;;; Author: Gilbert Baumann
-;;; License: LGPL (See file COPYING for details).
-;;; ---------------------------------------------------------------------------
-;;; © copyright 1999 by Gilbert Baumann
-
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Library General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 2 of the License, or (at your option) any later version.
-;;;
-;;; This library 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
-;;; Library General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Library General Public
-;;; License along with this library; if not, write to the
-;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;;; Boston, MA 02111-1307 USA.
-
-(in-package :xml)
-
-;;; API
-;;
-;; MAKE-XSTREAM cl-stream &key name speed initial-speed [function]
-;; MAKE-ROD-XSTREAM rod &key name [function]
-;; CLOSE-XSTREAM xstream [function]
-;; READ-RUNE xstream [macro]
-;; PEEK-RUNE xstream [macro]
-;; FREAD-RUNE xstream [function]
-;; FPEEK-RUNE xstream [function]
-;; XSTREAM-POSITION xstream [function]
-;; XSTREAM-LINE-NUMBER xstream [function]
-;; XSTREAM-COLUMN-NUMBER xstream [function]
-;; XSTREAM-PLIST xstream [accessor]
-;; XSTREAM-ENCODING xstream [accessor] <-- be careful here. [*]
-
-;; [*] swichting the encoding on the fly is only possible when the
-;; stream's buffer is empty; therefore to be able to switch the
-;; encoding, while some runes are already read, set the stream's speed
-;; to 1 initially (via the initial-speed argument for MAKE-XSTREAM)
-;; and later set it to full speed. (The encoding of the runes
-;; sequence, you fetch off with READ-RUNE is always UTF-16 though).
-
-;; An encoding is simply something, which provides the DECODE-SEQUENCE
-;; method.
-
-;;; Controller protocol
-;;
-;; READ-OCTECTS sequence os-stream start end -> first-non-written
-;; XSTREAM/CLOSE os-stream
-;;
-
-(eval-when (eval compile load)
- (defparameter *fast* '(optimize (speed 3) (safety 0)))
- ;;(defparameter *fast* '(optimize (speed 2) (safety 3)))
- )
-
-;; Let us first define fast fixnum arithmetric get rid of type
-;; checks. (After all we know what we do here).
-
-(defmacro fx-op (op &rest xs)
- `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
-(defmacro fx-pred (op &rest xs)
- `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
-
-(defmacro %+ (&rest xs) `(fx-op + ,@xs))
-(defmacro %- (&rest xs) `(fx-op - ,@xs))
-(defmacro %* (&rest xs) `(fx-op * ,@xs))
-(defmacro %/ (&rest xs) `(fx-op floor ,@xs))
-(defmacro %and (&rest xs) `(fx-op logand ,@xs))
-(defmacro %ior (&rest xs) `(fx-op logior ,@xs))
-(defmacro %xor (&rest xs) `(fx-op logxor ,@xs))
-(defmacro %ash (&rest xs) `(fx-op ash ,@xs))
-(defmacro %mod (&rest xs) `(fx-op mod ,@xs))
-
-(defmacro %= (&rest xs) `(fx-pred = ,@xs))
-(defmacro %<= (&rest xs) `(fx-pred <= ,@xs))
-(defmacro %>= (&rest xs) `(fx-pred >= ,@xs))
-(defmacro %< (&rest xs) `(fx-pred < ,@xs))
-(defmacro %> (&rest xs) `(fx-pred > ,@xs))
-
-(deftype buffer-index ()
- `(unsigned-byte ,(integer-length array-total-size-limit)))
-
-(deftype buffer-byte ()
- `(unsigned-byte 16))
-
-(deftype octet ()
- `(unsigned-byte 8))
-
-;; The usage of a special marker for EOF is experimental and
-;; considered unhygenic.
-
-(defconstant +end+ #xFFFF
- "Special marker inserted into stream buffers to indicate end of buffered data.")
-
-(defvar +null-buffer+ (make-array 0 :element-type 'buffer-byte))
-(defvar +null-octet-buffer+ (make-array 0 :element-type 'octet))
-
-(defstruct (xstream
- (:constructor make-xstream/low)
- (:copier nil)
- (:print-function print-xstream))
-
- ;;; Read buffer
-
- ;; the buffer itself
- (buffer +null-buffer+
- :type (simple-array buffer-byte (*)))
- ;; points to the next element of `buffer' containing the next rune
- ;; about to be read.
- (read-ptr 0 :type buffer-index)
- ;; points to the first element of `buffer' not containing a rune to
- ;; be read.
- (fill-ptr 0 :type buffer-index)
-
- ;;; OS buffer
-
- ;; a scratch pad for READ-SEQUENCE
- (os-buffer +null-octet-buffer+
- :type (simple-array octet (*)))
-
- ;; `os-left-start', `os-left-end' designate a region of os-buffer,
- ;; which still contains some undecoded data. This is needed because
- ;; of the DECODE-SEQUENCE protocol
- (os-left-start 0 :type buffer-index)
- (os-left-end 0 :type buffer-index)
-
- ;; How much to read each time
- (speed 0 :type buffer-index)
-
- ;; Some stream object obeying to a certain protcol
- os-stream
-
- ;; The external format
- ;; (some object offering the ENCODING protocol)
- (encoding :utf-8)
-
- ;;A STREAM-NAME object
- (name nil)
-
- ;; a plist a struct keeps the hack away
- (plist nil)
-
- ;; Stream Position
- (line-number 1 :type integer) ;current line number
- (line-start 0 :type integer) ;stream position the current line starts at
- (buffer-start 0 :type integer) ;stream position the current buffer starts at
-
- ;; There is no need to maintain a column counter for each character
- ;; read, since we can easily compute it from `line-start' and
- ;; `buffer-start'.
- )
-
-(defmacro read-rune (input)
- "Read a single rune off the xstream `input'. In case of end of file :EOF
- is returned."
- `((lambda (input)
- (declare (type xstream input)
- #.*fast*)
- (let ((rp (xstream-read-ptr input)))
- (declare (type buffer-index rp))
- (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
- rp)))
- (declare (type buffer-byte ch))
- (setf (xstream-read-ptr input) (%+ rp 1))
- (cond ((%= ch +end+)
- (the (or (member :eof) rune)
- (xstream-underflow input)))
- ((%= ch #x000A) ;line break
- (account-for-line-break input)
- (code-rune ch))
- (t
- (code-rune ch))))))
- ,input))
-
-(defmacro peek-rune (input)
- "Peek a single rune off the xstream `input'. In case of end of file :EOF
- is returned."
- `((lambda (input)
- (declare (type xstream input)
- #.*fast*)
- (let ((rp (xstream-read-ptr input)))
- (declare (type buffer-index rp))
- (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
- rp)))
- (declare (type buffer-byte ch))
- (cond ((%= ch +end+)
- (prog1
- (the (or (member :eof) rune) (xstream-underflow input))
- (setf (xstream-read-ptr input) 0)))
- (t
- (code-rune ch))))))
- ,input))
-
-(defmacro consume-rune (input)
- "Like READ-RUNE, but does not actually return the read rune."
- `((lambda (input)
- (declare (type xstream input)
- #.*fast*)
- (let ((rp (xstream-read-ptr input)))
- (declare (type buffer-index rp))
- (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
- rp)))
- (declare (type buffer-byte ch))
- (setf (xstream-read-ptr input) (%+ rp 1))
- (when (%= ch +end+)
- (xstream-underflow input))
- (when (%= ch #x000A) ;line break
- (account-for-line-break input) )))
- nil)
- ,input))
-
-(defsubst unread-rune (rune input)
- "Unread the last recently read rune; if there wasn't such a rune, you
- deserve to loose."
- (declare (ignore rune))
- (decf (xstream-read-ptr input))
- (when (%= (peek-rune input) #x000A) ;was it a line break?
- (unaccount-for-line-break input)))
-
-(defun fread-rune (input)
- (read-rune input))
-
-(defun fpeek-rune (input)
- (peek-rune input))
-
-;;; Line counting
-
-(defun account-for-line-break (input)
- (declare (type xstream input))
- (incf (xstream-line-number input))
- (setf (xstream-line-start input)
- (+ (xstream-buffer-start input) (xstream-read-ptr input))))
-
-(defun unaccount-for-line-break (input)
- ;; incomplete!
- ;; We better use a traditional lookahead technique or forbid unread-rune.
- (decf (xstream-line-number input)))
-
-;; User API:
-
-(defun xstream-position (input)
- (+ (xstream-buffer-start input) (xstream-read-ptr input)))
-
-;; xstream-line-number is structure accessor
-
-(defun xstream-column-number (input)
- (+ (- (xstream-position input)
- (xstream-line-start input))
- 1))
-
-;;; Underflow
-
-;;(defun read-runes (sequence input))
-
-(defun xstream-underflow (input)
- (declare (type xstream input))
- ;; we are about to fill new data into the buffer, so we need to
- ;; adjust buffer-start.
- (incf (xstream-buffer-start input)
- (- (xstream-fill-ptr input) 0))
- (let (n m)
- ;; when there is something left in the os-buffer, we move it to
- ;; the start of the buffer.
- (setf m (- (xstream-os-left-end input) (xstream-os-left-start input)))
- (unless (zerop m)
- (replace (xstream-os-buffer input) (xstream-os-buffer input)
- :start1 0 :end1 m
- :start2 (xstream-os-left-start input)
- :end2 (xstream-os-left-end input))
- ;; then we take care that the buffer is large enough to carry at
- ;; least 100 bytes (a random number)
- (unless (>= (length (xstream-os-buffer input)) 100)
- (error "You lost")
- ;; todo: enlarge buffer
- ))
- (setf n
- (read-octets (xstream-os-buffer input) (xstream-os-stream input)
- m (min (1- (length (xstream-os-buffer input)))
- (+ m (xstream-speed input)))))
- (cond ((%= n 0)
- (setf (xstream-read-ptr input) 0
- (xstream-fill-ptr input) n)
- (setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
- :eof)
- (t
- (multiple-value-bind (fnw fnr)
- (decode-sequence (xstream-encoding input)
- (xstream-os-buffer input) 0 n
- (xstream-buffer input) 0 (1- (length (xstream-buffer input)))
- (= n m))
- (setf (xstream-os-left-start input) fnr
- (xstream-os-left-end input) n
- (xstream-read-ptr input) 0
- (xstream-fill-ptr input) fnw)
- (setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
- (read-rune input))))))
-
-;;; constructor
-
-(defun make-xstream (os-stream &key name (speed 8192) (initial-speed speed))
- (let ()
- (multiple-value-bind (encoding preread) (figure-encoding os-stream)
- (let ((osbuf (make-array speed :element-type '(unsigned-byte 8))))
- (replace osbuf preread)
- (make-xstream/low
- :buffer (let ((r (make-array speed :element-type 'buffer-byte)))
- (setf (%rune r 0) #xFFFF)
- r)
- :read-ptr 0
- :fill-ptr 0
- :os-buffer osbuf
- :speed initial-speed
- :os-stream os-stream
- :os-left-start 0
- :os-left-end (length preread)
- :encoding encoding
- :name name)))))
-
-(defmethod figure-encoding ((stream glisp:gstream))
- ;; For HTML iso-8859-1 is the default
- (values (xml::find-encoding :iso-8859-1) nil))
-
-(defun make-rod-xstream (string &key name)
- (let ((n (length string)))
- (let ((buffer (make-array (1+ n) :element-type 'buffer-byte)))
- (declare (type (simple-array buffer-byte (*)) buffer))
- ;; copy the rod
- (do ((i (1- n) (- i 1)))
- ((< i 0))
- (declare (type fixnum i))
- (setf (aref buffer i) (rune-code (%rune string i))))
- (setf (aref buffer n) +end+)
- ;;
- (make-xstream/low :buffer buffer
- :read-ptr 0
- :fill-ptr n
- ;; :os-buffer nil
- :speed 1
- :os-stream nil
- :name name))))
-
-;;; misc
-
-(defun close-xstream (input)
- (xstream/close (xstream-os-stream input)))
-
-;;; controller implementations
-
-(defmethod read-octets (sequence (stream stream) start end)
- (#+CLISP lisp:read-byte-sequence
- #-CLISP read-sequence
- sequence stream :start start :end end))
-
-(defmethod read-octets (sequence (stream null) start end)
- (declare (ignore sequence start end))
- 0)
-
-(defmethod xstream/close ((stream stream))
- (close stream))
-
-(defmethod xstream/close ((stream null))
- nil)
-
diff --git a/xmlconf.lisp b/xmlconf.lisp
deleted file mode 100644
index 5bf59ee..0000000
--- a/xmlconf.lisp
+++ /dev/null
@@ -1,23 +0,0 @@
-(defpackage xmlconf
- (:use :cl)
- (:alias (:string-dom :dom)))
-(in-package :xmlconf)
-
-(defun test-xml-conformance (directory)
- (let ((xmlconf (xml:parse-file (merge-pathnames "xmlconf.xml" directory))))
- (dolist (test (dom:get-elements-by-tag-name xmlconf "test"))
- (when (equal (dom:get-attribute test "TYPE") "valid")
- (let* ((base (dom:get-attribute (dom:parent-node test) "xml:base"))
- (uri (dom:get-attribute test "URI")))
- (unless base
- (inspect test))
- (princ uri)
- (handler-case
- (progn
- (xml:parse-file
- (merge-pathnames uri (merge-pathnames base directory)))
- (format t " ok~%"))
- (serious-condition (c)
- (format t " FAILED:~% ~A~%[~A]~%"
- c
- (dom:data (car (dom:child-nodes test)))))))))))