From 3c5ada1d053f8b826ac3784384912c303fb77f32 Mon Sep 17 00:00:00 2001 From: david Date: Sun, 13 Mar 2005 18:05:37 +0000 Subject: [PATCH] removed files left over from "cvs import" --- CLISP.diff | 17 - NEWS | 151 ------ dom/xml-canonic.lisp | 161 ------ domtest.lisp | 433 --------------- glisp/COPYING | 521 ------------------ glisp/characters.lisp | 132 ----- glisp/dep-acl.lisp | 127 ----- glisp/dep-acl5.lisp | 162 ------ glisp/dep-clisp.lisp | 176 ------ glisp/dep-cmucl-dtc.lisp | 212 -------- glisp/dep-cmucl.lisp | 241 --------- glisp/dep-gcl-2.lisp | 93 ---- glisp/dep-gcl.lisp | 344 ------------ glisp/dep-sbcl.lisp | 141 ----- glisp/gendep.lisp | 427 --------------- glisp/match.lisp | 207 ------- glisp/package.lisp | 406 -------------- glisp/runes.lisp | 412 -------------- glisp/syntax.lisp | 190 ------- glisp/util.lisp | 1113 -------------------------------------- xml/dom-builder.lisp | 46 -- xml/dom-impl.lisp | 512 ------------------ xml/dompack.lisp | 102 ---- xml/encodings-data.lisp | 568 ------------------- xml/encodings.lisp | 347 ------------ xml/string-dom.lisp | 35 -- xml/xml-canonic.lisp | 172 ------ xml/xml-stream.lisp | 370 ------------- xmlconf.lisp | 23 - 29 files changed, 7841 deletions(-) delete mode 100644 CLISP.diff delete mode 100644 NEWS delete mode 100644 dom/xml-canonic.lisp delete mode 100644 domtest.lisp delete mode 100644 glisp/COPYING delete mode 100644 glisp/characters.lisp delete mode 100644 glisp/dep-acl.lisp delete mode 100644 glisp/dep-acl5.lisp delete mode 100644 glisp/dep-clisp.lisp delete mode 100644 glisp/dep-cmucl-dtc.lisp delete mode 100644 glisp/dep-cmucl.lisp delete mode 100644 glisp/dep-gcl-2.lisp delete mode 100644 glisp/dep-gcl.lisp delete mode 100644 glisp/dep-sbcl.lisp delete mode 100644 glisp/gendep.lisp delete mode 100644 glisp/match.lisp delete mode 100644 glisp/package.lisp delete mode 100644 glisp/runes.lisp delete mode 100644 glisp/syntax.lisp delete mode 100644 glisp/util.lisp delete mode 100644 xml/dom-builder.lisp delete mode 100644 xml/dom-impl.lisp delete mode 100644 xml/dompack.lisp delete mode 100644 xml/encodings-data.lisp delete mode 100644 xml/encodings.lisp delete mode 100644 xml/string-dom.lisp delete mode 100644 xml/xml-canonic.lisp delete mode 100644 xml/xml-stream.lisp delete mode 100644 xmlconf.lisp 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)))))))))))