Commit c73b07b7 authored by david's avatar david

Revision: cxml--devel--1.0--patch-1

Archive: david@knowledgetools.de--cxml
Creator: David Lichteblau <david@knowledgetools.de>
Date: Wed Jan  7 16:31:19 CET 2004
Standard-date: 2004-01-07 15:31:19 GMT
Removed-files: glisp/.arch-ids/gendep.lisp.id
    glisp/gendep.lisp
Modified-files: cxml.asd glisp/dep-acl.lisp
    glisp/dep-acl5.lisp glisp/match.lisp glisp/package.lisp
    glisp/runes.lisp glisp/util.lisp xml/dom-impl.lisp
    xml/package.lisp xml/xml-name-rune-p.lisp
    xml/xml-parse.lisp
New-patches: david@knowledgetools.de--cxml/cxml--devel--1.0--patch-1
Summary: ACL port aktualisiert
Keywords:

  - #+(and allegro-version>= (version>= 5.0)) statt #+ALLEGRO-V5.0
  - mlisp port. :-(

Kompiliert jetzt und kann <test>foo</test> parsen!
parent 9e8ea2a7
......@@ -25,8 +25,8 @@
#+(AND :CMU (NOT :PTHREAD)) "dep-cmucl"
#+sbcl "dep-sbcl"
#+(AND :CMU :PTHREAD) "dep-cmucl-dtc"
#+(and allegro allegro-v5.0) "dep-acl5"
#+(and allegro (not allegro-v5.0)) "dep-acl"
#+(and allegro-version>= (version>= 5.0)) "dep-acl5"
#-(and allegro-version>= (version>= 5.0)) "dep-acl"
#+GCL "dep-gcl"
#-(or sbcl CLISP CMU allegro GCL) #.(error "Configure!"))
(:file "package"
......@@ -41,14 +41,14 @@
(asdf:defsystem :cxml
:default-component-class closure-source-file
:pathname (merge-pathnames
"cxml/"
"xml/"
(make-pathname :name nil :type nil :defaults *load-truename*))
:components
((:file "package")
(:file "encodings" :depends-on ("package"))
(:file "encodings-data" :depends-on ("package" "encodings"))
(:file "sax-handler")
(:file "dompack")
(:file "dompack" :depends-on ("package"))
(:file "dom-impl" :depends-on ("dompack"))
(:file "dom-builder" :depends-on ("dom-impl" "sax-handler"))
(:file "xml-stream" :depends-on ("package"))
......
......@@ -40,7 +40,7 @@
(defun glisp::read-char-sequence (&rest ap)
(apply #'read-sequence ap))
#+ALLEGRO-V5.0
#+(and allegro-version>= (version>= 5.0))
(defun glisp::open-inet-socket (hostname port)
(values
(socket:make-socket :remote-host hostname
......@@ -48,7 +48,7 @@
:format :binary)
:byte))
#-ALLEGRO-V5.0
#-(and allegro-version>= (version>= 5.0))
(defun glisp::open-inet-socket (hostname port)
(values
(ipc:open-network-stream :host hostname
......
......@@ -90,7 +90,7 @@
(ipc:open-network-stream :host hostname
:port port
:element-type '(unsigned-byte 8)
:class 'EXCL::BIDIRECTIONAL-BINARY-SOCKET-STREAM)
:class 'excl::bidirectional-binary-socket-stream)
:byte))
(defun glisp::mp/make-lock (&key name)
......@@ -159,4 +159,4 @@
(defun glisp::getenv (string)
(sys:getenv string))
\ No newline at end of file
(sys:getenv string))
......@@ -22,7 +22,7 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :GLISP)
(in-package :glisp)
;; Syntax
;; ------
......
......@@ -350,7 +350,7 @@
#+:CLISP ,@'(:lisp)
#+:CMU ,@'(:ext)
#+:sbcl ,@'(:sb-gray)
#+:ALLEGRO ,@'(:common-lisp :excl :stream)
#+:allegro ,@'(:common-lisp :excl :stream)
#+:HARLEQUIN-COMMON-LISP ,@'(:stream)
#+:OPENMCL ,@'(:ccl)
))
......@@ -363,7 +363,7 @@
(list sym)
nil)))
packages)
(progn (format T "~&There is no ~A in ~A." name packages)
(progn (format t "~&There is no ~A in ~A." name packages)
(finish-output)
nil)))
......@@ -377,7 +377,7 @@
(cond ((multiple-value-bind (sym2 res) (find-symbol nam :glisp)
(and sym2 (eq res :external)))
;;
(format T "~&;; ~S is pacthed." sym) )
(format t "~&;; ~S is pacthed." sym) )
(t
(setf sym (car sym))
;; CLISP has no (:import ..) ARG!
......@@ -386,17 +386,23 @@
,(symbol-name sym))
imports))))))
res)))
(unless (eq 'foo 'FOO)
;; mlisp :-(
(macrolet ((fixup (var) `(setf ,var (mapcar #'string-downcase ,var))))
(fixup *all-ansi-symbols*)
(fixup *gray-symbols*)
(fixup *export-from-glisp*)))
(setf export-ansi (grok *all-ansi-symbols* *packages*))
(setf export-gray (grok *gray-symbols* *gray-packages*))
`(progn
(defpackage "GLISP" (:use)
(defpackage :glisp (:use)
,@imports
(:export
,@(mapcar #'symbol-name export-ansi)
,@(mapcar #'symbol-name export-gray)
,@*export-from-glisp*))
(defpackage "GLUSER"
(:use "GLISP")) )))
(defpackage :gluser
(:use :glisp)))))
(defmacro define-glisp-package ()
(dump-defpackage))
......
......@@ -33,7 +33,7 @@
;; - Added rune reader
;;
(in-package :GLISP)
(in-package :glisp)
(deftype rune () '(unsigned-byte 16))
(deftype rod () '(array rune (*)))
......@@ -409,4 +409,4 @@
(let ((*print-array* nil)
(*print-pretty* nil))
(prin1 object stream))))
||#
\ No newline at end of file
||#
......@@ -29,7 +29,7 @@
;; subforms
;;
(in-package :GLISP)
(in-package :glisp)
(defun neq (x y) (not (eq x y)))
......@@ -122,13 +122,13 @@
x))
exprs))))
#+ALLEGRO
#+allegro
(defun current-function-name ()
(car COMPILER::.FUNCTIONS-DEFINED.))
(car compiler::.functions-defined.))
#-ALLEGRO
#-allegro
(defun current-function-name ()
'ANONYMOUS)
'anonymous)
;;; --------------------------------------------------------------------------------
;;; Multiple values
......@@ -140,10 +140,10 @@
(car xs))
(t
(let ((g (gensym)))
`(LET ((,g (MULTIPLE-VALUE-LIST ,(car xs))))
(IF (CAR ,g)
(VALUES-LIST ,g)
(MULTIPLE-VALUE-OR ,@(cdr xs))))))))
`(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
......@@ -633,15 +633,15 @@ Hmm unter PCL geht das nicht ;-(
;;----------------------------------------------------------------------------------------------------
(defun g/peek-char (&optional (peek-type nil) (source *standard-input*)
(eof-error-p T) eof-value)
(cond ((eq peek-type T)
(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)
((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)
......@@ -651,7 +651,7 @@ Hmm unter PCL geht das nicht ;-(
(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)) )) ) ))
(t (g/unread-char ch source) ch)))))))
......@@ -756,8 +756,8 @@ Hmm unter PCL geht das nicht ;-(
;; 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)
`(let ((,obj-var ,obj))
(symbol-macrolet ,(mapcar (lambda (slot)
(list slot
`(,(intern (concatenate 'string (symbol-name type) "-" (symbol-name slot))
(symbol-package type))
......@@ -818,50 +818,50 @@ Hmm unter PCL geht das nicht ;-(
(cond (initial-value?
`(LET* ((,$seq ,seq)
(,$start ,(or start 0))
(,$end ,(or end `(LENGTH ,$seq)))
(,$end ,(or end `(length ,$seq)))
(,$accu ,initial-value))
(DECLARE (TYPE FIXNUM ,$start ,$end))
(DO ((,$i (- ,$end 1) (THE FIXNUM (- ,$i 1))))
(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)) )))
(declare (type fixnum ,$i))
(setf ,$accu (funcall* ,fun (funcall* ,key (aref ,$seq ,$i)) ,$accu)) )))
(t
`(LET* ((,$seq ,seq)
`(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))))
(,$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)))))))) ))
(declare (type fixnum ,$i))
(setf ,$accu (funcall* ,fun (funcall* ,key (aref ,$seq ,$i)) ,$accu)))))))) ))
(t
(cond (initial-value?
`(LET* ((,$seq ,seq)
`(let* ((,$seq ,seq)
(,$start ,(or start 0))
(,$end ,(or end `(LENGTH ,$seq)))
(,$end ,(or end `(length ,$seq)))
(,$accu ,initial-value))
(DECLARE (TYPE FIXNUM ,$start ,$end))
(DO ((,$i ,$start (THE FIXNUM (+ ,$i 1))))
(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)))) )))
(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)))
(,$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)))))))))))))))
(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?))
......@@ -871,19 +871,19 @@ Hmm unter PCL geht das nicht ;-(
(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)))))))
`(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)))))))) ))) ))
`(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
......
......@@ -160,7 +160,7 @@
(when parent
(with-slots (children) parent
(do ((q children (cdr q)))
((null (cdr q)) niL)
((null (cdr q)) nil)
(cond ((eq (cadr q) node)
(return (car q)))))))))
......@@ -169,7 +169,7 @@
(when parent
(with-slots (children) parent
(do ((q children (cdr q)))
((null (cdr q)) niL)
((null (cdr q)) nil)
(cond ((eq (car q) node)
(return (cadr q)))))))))
......
......@@ -206,13 +206,13 @@
(setf (aref r i) 1))))) )
`(progn
(DEFSUBST NAME-RUNE-P (RUNE)
(AND (<= 0 RUNE ,*max*)
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
(= 1 (SBIT ',(predicate-to-bv #'name-rune-p)
(THE FIXNUM RUNE))))))
(DEFSUBST NAME-START-RUNE-P (RUNE)
(AND (<= 0 RUNE ,*MAX*)
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
(= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p)
(THE FIXNUM RUNE)))))))) ))))
\ No newline at end of file
(defsubst name-rune-p (rune)
(and (<= 0 rune ,*max*)
(locally (declare (optimize (safety 0) (speed 3)))
(= 1 (sbit ',(predicate-to-bv #'name-rune-p)
(the fixnum rune))))))
(defsubst name-start-rune-p (rune)
(and (<= 0 rune ,*max*)
(locally (declare (optimize (safety 0) (speed 3)))
(= 1 (sbit ',(predicate-to-bv #'name-start-rune-p)
(the fixnum rune)))))))) ))))
......@@ -195,7 +195,7 @@
(in-package :xml)
#+ALLEGRO
#+allegro
(setf (excl:named-readtable :glisp) *readtable*)
(eval-when (eval compile load)
......@@ -931,7 +931,7 @@
(let ((c (peek-rune input)))
(and (not (eq c :eof))
(space-rune-p c))))
(read-S? input)
(read-s? input)
(cond ((eq (peek-rune input) :eof)
nil)
((name-start-rune-p (peek-rune input))
......@@ -961,7 +961,7 @@
(perror input "Expected \";\"."))
(values :named name))))))
(defsubst read-S? (input)
(defsubst read-s? (input)
(while (member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D)
:test #'eq)
(consume-rune input)))
......@@ -1952,7 +1952,7 @@
(p/doctype-decl input)
(p/misc*-2 input))
;; element
(let ((*data-behaviour* :doc))
(let ((*data-behaviour* :DOC))
(p/element input))
;; optional Misc*
(p/misc*-2 input)
......@@ -2200,13 +2200,13 @@
;;;;
#+ALLEGRO
#+allegro
(defmacro sp (&body body)
`(progn
(prof:with-profiling (:type :space) .,body)
(prof:show-flat-profile)))
#+ALLEGRO
#+allegro
(defmacro tm (&body body)
`(progn
(prof:with-profiling (:type :time) .,body)
......@@ -2469,20 +2469,20 @@
(let ((input-var (gensym))
(collect (gensym))
(c (gensym)))
`(LET ((,input-var ,input))
(MULTIPLE-VALUE-BIND (,res ,res-start ,res-end)
(WITH-RUNE-COLLECTOR/RAW (,collect)
(LOOP
(LET ((,c (PEEK-RUNE ,input-var)))
(COND ((EQ ,c :EOF)
`(let ((,input-var ,input))
(multiple-value-bind (,res ,res-start ,res-end)
(with-rune-collector/raw (,collect)
(loop
(let ((,c (peek-rune ,input-var)))
(cond ((eq ,c :eof)
;; xxx error message
(RETURN))
((FUNCALL ,predicate ,c)
(RETURN))
(return))
((funcall ,predicate ,c)
(return))
(t
(,collect ,c)
(CONSUME-RUNE ,input-var))))))
(LOCALLY
(consume-rune ,input-var))))))
(locally
,@body)))))
(defun read-name-token (input)
......@@ -2571,7 +2571,7 @@
#+(or) ;; Do we need this? Not called anywhere
(defun ff (name)
(let ((input (make-zstream)))
(let ((*data-behaviour* :doc)
(let ((*data-behaviour* :DOC)
(*document* (make-instance 'simple-document)))
(recurse-on-entity
input name :general
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment