From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 27 Oct 2004 20:02:07 +0000 (+0000)
Subject: No longer used.
X-Git-Tag: 20090517-FFI~1522
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3c07c904225e366e077186784291a066a990f9c0;p=mit-scheme.git

No longer used.
---

diff --git a/v7/src/ssp/matcher.scm b/v7/src/ssp/matcher.scm
deleted file mode 100644
index a1dafb89e..000000000
--- a/v7/src/ssp/matcher.scm
+++ /dev/null
@@ -1,184 +0,0 @@
-#| -*-Scheme-*-
-
-$Id: matcher.scm,v 1.1 2003/12/29 05:24:39 uid67408 Exp $
-
-Copyright 2003 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme 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.
-
-MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-USA.
-
-|#
-
-;;;; List matching
-
-(declare (usual-integrations))
-
-(define ((ml:matcher pattern) items)
-  (ml:apply pattern items))
-
-(define (ml:apply pattern items)
-  (guarantee-list items 'ML:APPLY)
-  (pattern (lambda (kf p r) kf p (r->v r))
-	   (lambda () #f)
-	   items))
-
-(define ((ml:match predicate) ks kf p)
-  (if (pair? p)
-      (let ((item (car p)))
-	(if (predicate item)
-	    (ks kf (cdr p) (r1 item))
-	    (kf)))
-      (kf)))
-
-(define ((ml:noise predicate) ks kf p)
-  (if (and (pair? p) (predicate (car p)))
-      (ks kf (cdr p) (r0))
-      (kf)))
-
-(define (ml:end ks kf p)
-  (if (null? p)
-      (ks kf p (r0))
-      (kf)))
-
-(define ((ml:* matcher) ks kf p)
-  (let ks* ((kf kf) (p p) (r (r0)))
-    (matcher (lambda (kf p r*) (ks* kf p (r+ r r*)))
-	     (lambda () (ks kf p r))
-	     p)))
-
-(define (ml:seq . matchers)
-  (let loop ((matchers matchers))
-    (if (pair? matchers)
-	(let ((m1 (car matchers))
-	      (matchers (cdr matchers)))
-	  (if (pair? matchers)
-	      (let ((m2 (loop matchers)))
-		(lambda (ks kf p)
-		  (m1 (lambda (kf p r1)
-			(m2 (lambda (kf p r2) (ks kf p (r+ r1 r2)))
-			    kf
-			    p))
-		      kf
-		      p)))
-	      m1))
-	(lambda (ks kf p) (ks kf p (r0))))))
-
-(define (ml:alt . matchers)
-  (if (pair? matchers)
-      (let loop ((matchers matchers))
-	(let ((m1 (car matchers))
-	      (matchers (cdr matchers)))
-	  (if (pair? matchers)
-	      (let ((m2 (loop matchers)))
-		(lambda (ks kf p)
-		  (m1 ks
-		      (lambda () (m2 ks kf p))
-		      p)))
-	      m1)))
-      (lambda (ks kf p) ks p (kf))))
-
-(define (ml:transform procedure matcher)
-  (transformer (lambda (v) (v->r (procedure v))) matcher))
-
-(define (ml:encapsulate procedure matcher)
-  (transformer (lambda (v) (r1 (procedure v))) matcher))
-
-(define (ml:map procedure matcher)
-  (transformer (lambda (v) (v->r (vector-map procedure v))) matcher))
-
-(define ((transformer transform matcher) ks kf p)
-  (matcher (lambda (kf p r) (ks kf p (transform (r->v r))))
-	   kf
-	   p))
-
-(define (ml:+ matcher)
-  (ml:seq matcher (ml:* matcher)))
-
-(define (ml:? matcher)
-  (ml:alt matcher (ml:seq)))
-
-(define ((ml:values . items) ks kf p)
-  (ks kf p (l->r items)))
-
-(define (ml:*-list matcher)
-  (ml:encapsulate vector->list (ml:* matcher)))
-
-(define-integrable (r0) '#())
-(define-integrable (r1 item) (vector item))
-(define-integrable (r->v r) r)
-(define-integrable (v->r v) v)
-(define-integrable (l->r l) (list->vector l))
-
-(define (r+ r1 r2)
-  (let ((n1 (vector-length r1))
-	(n2 (vector-length r2)))
-    (cond ((fix:= n1 0) r2)
-	  ((fix:= n2 0) r1)
-	  (else
-	   (let ((r (make-vector (fix:+ n1 n2))))
-	     (do ((i 0 (fix:+ i 1)))
-		 ((fix:= i n1))
-	       (vector-set! r i (vector-ref r1 i)))
-	     (do ((i 0 (fix:+ i 1))
-		  (j n1 (fix:+ j 1)))
-		 ((fix:= i n2))
-	       (vector-set! r j (vector-ref r2 i)))
-	     r)))))
-
-#|
-
-;;; If the set of items doesn't include #F or pairs, this should be
-;;; faster than the above.
-
-(define-integrable (r0) #f)
-(define-integrable (r1 item) item)
-
-(define (r+ r1 r2)
-  (cond ((not r1) r2)
-	((not r2) r1)
-	(else (cons r1 r2))))
-
-(define (r->v r)
-  (if r
-      (let ((n
-	     (let loop ((r r))
-	       (if (pair? r)
-		   (fix:+ (loop (car r))
-			  (loop (cdr r)))
-		   1))))
-	(let ((v (make-vector n)))
-	  (let loop ((r r) (i 0) (q '()))
-	    (if (pair? r)
-		(loop (car r)
-		      i
-		      (cons (cdr r) q))
-		(begin
-		  (vector-set! v i r)
-		  (if (pair? q)
-		      (loop (car q)
-			    (fix:+ i 1)
-			    (cdr q))))))
-	  v))
-      '#()))
-
-(define (v->r v)
-  ???)
-
-(define (l->r l)
-  ???)
-
-|#
\ No newline at end of file
diff --git a/v7/src/ssp/xhtml.scm b/v7/src/ssp/xhtml.scm
deleted file mode 100644
index 614087acb..000000000
--- a/v7/src/ssp/xhtml.scm
+++ /dev/null
@@ -1,246 +0,0 @@
-#| -*-Scheme-*-
-
-$Id: xhtml.scm,v 1.1 2003/12/29 05:24:55 uid67408 Exp $
-
-Copyright 2002,2003 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme 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.
-
-MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
-USA.
-
-|#
-
-;;;; XHTML support
-
-(declare (usual-integrations))
-
-(define xhtml-external-dtd
-  (make-xml-external-id "-//W3C//DTD XHTML 1.0 Strict//EN"
-			"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"))
-
-(define xhtml-dtd
-  (make-xml-dtd 'html xhtml-external-dtd '()))
-
-(define xhtml-iri
-  (make-xml-namespace-iri "http://www.w3.org/1999/xhtml"))
-
-(define-syntax define-standard-element
-  (sc-macro-transformer
-   (lambda (form environment)
-     environment
-     (if (syntax-match? '(IDENTIFIER) (cdr form))
-	 (let ((name (cadr form)))
-	   `(DEFINE ,name
-	      (STANDARD-ELEMENT-CONSTRUCTOR ',name XHTML-IRI)))
-	 (ill-formed-syntax form)))))
-
-(define (standard-element-constructor simple iri)
-  (let ((name (make-xml-name simple iri)))
-    (lambda (attrs . items)
-      (make-xml-element name
-			(if (not attrs)
-			    '()
-			    attrs)
-			(flatten-xml-element-contents items)))))
-
-(define (flatten-xml-element-contents item)
-  (letrec
-      ((scan-item
-	(lambda (item tail)
-	  (cond ((xml-content-item? item) (cons item tail))
-		((pair? item) (scan-list item tail))
-		((or (not item) (null? item)) tail)
-		(else (cons (convert-xhtml-string-value item) tail)))))
-       (scan-list
-	(lambda (items tail)
-	  (if (pair? items)
-	      (scan-item (car items)
-			 (scan-list (cdr items) tail))
-	      (begin
-		(if (not (null? items))
-		    (error:wrong-type-datum items "list"))
-		tail)))))
-    (scan-item item '())))
-
-(define (convert-xhtml-string-value value)
-  (cond ((symbol? value) (symbol-name value))
-	((number? value) (number->string value))
-	((xml-namespace-iri? value) (xml-namespace-iri-string value))
-	(else (error:wrong-type-datum value "string value"))))
-
-(define-standard-element a)
-(define-standard-element abbr)
-(define-standard-element acronym)
-(define-standard-element address)
-(define-standard-element b)
-(define-standard-element big)
-(define-standard-element blockquote)
-(define-standard-element body)
-(define-standard-element button)
-(define-standard-element caption)
-(define-standard-element cite)
-(define-standard-element code)
-(define-standard-element col)
-(define-standard-element colgroup)
-(define-standard-element dd)
-(define-standard-element defn)
-(define-standard-element del)
-(define-standard-element dir)
-(define-standard-element div)
-(define-standard-element dl)
-(define-standard-element dt)
-(define-standard-element em)
-(define-standard-element form)
-(define-standard-element h1)
-(define-standard-element h2)
-(define-standard-element h3)
-(define-standard-element h4)
-(define-standard-element h5)
-(define-standard-element head)
-(define-standard-element html)
-(define-standard-element i)
-(define-standard-element ins)
-(define-standard-element kbd)
-(define-standard-element li)
-(define-standard-element listing)
-(define-standard-element menu)
-(define-standard-element ol)
-(define-standard-element optgroup)
-(define-standard-element option)
-(define-standard-element p)
-(define-standard-element pre)
-(define-standard-element q)
-(define-standard-element s)
-(define-standard-element samp)
-(define-standard-element script)
-(define-standard-element select)
-(define-standard-element small)
-(define-standard-element span)
-(define-standard-element strike)
-(define-standard-element strong)
-(define-standard-element sub)
-(define-standard-element sup)
-(define-standard-element table)
-(define-standard-element tbody)
-(define-standard-element td)
-(define-standard-element textarea)
-(define-standard-element tfoot)
-(define-standard-element th)
-(define-standard-element thead)
-(define-standard-element title)
-(define-standard-element tr)
-(define-standard-element tt)
-(define-standard-element u)
-(define-standard-element ul)
-(define-standard-element var)
-
-(define-syntax define-empty-element
-  (sc-macro-transformer
-   (lambda (form environment)
-     environment
-     (if (syntax-match? '(IDENTIFIER) (cdr form))
-	 (let ((name (cadr form)))
-	   `(DEFINE ,name
-	      (EMPTY-ELEMENT-CONSTRUCTOR ',name XHTML-IRI)))
-	 (ill-formed-syntax form)))))
-
-(define (empty-element-constructor simple iri)
-  (let ((name (make-xml-name simple iri)))
-    (lambda keyword-list
-      (make-xml-element name
-			(if (and (pair? keyword-list)
-				 (list-of-type? (car keyword-list)
-				   xml-attribute?)
-				 (null? (cdr keyword-list)))
-			    (car keyword-list)
-			    (apply attributes keyword-list))
-			'()))))
-
-(define-empty-element br)
-(define-empty-element hr)
-(define-empty-element img)
-(define-empty-element input)
-(define-empty-element link)
-(define-empty-element meta)
-
-(define (attributes . keyword-list)
-  (let loop ((bindings keyword-list))
-    (if (and (pair? bindings)
-	     (xml-name? (car bindings))
-	     (pair? (cdr bindings)))
-	(let ((value (cadr bindings))
-	      (tail (loop (cddr bindings))))
-	  (if value
-	      (cons (make-xml-attribute
-		     (car bindings)
-		     (cond ((eq? value #t) (symbol-name (car bindings)))
-			   ((xml-char-data? value) value)
-			   (else (convert-xhtml-string-value value))))
-		    tail)
-	      tail))
-	(begin
-	  (if (not (null? bindings))
-	      (error:wrong-type-argument keyword-list
-					 "keyword list"
-					 'ATTRIBUTES))
-	  '()))))
-
-(define (href iri . contents)
-  (apply a
-	 (attributes 'href iri)
-	 contents))
-
-(define (id-def tag . contents)
-  (apply a
-	 (attributes 'id tag
-		     'name tag)
-	 contents))
-
-(define (id-ref tag . contents)
-  (apply href (string-append "#" tag) contents))
-
-(define (rel-link rel iri)
-  (link 'rel rel
-	'href iri))
-
-(define (style-link iri)
-  (link 'rel "stylesheet"
-	'href iri
-	'type "text/css"))
-
-(define (http-equiv name value)
-  (meta 'http-equiv name
-	'content value))
-
-(define (style . keyword-list)
-  (let loop ((bindings keyword-list))
-    (if (and (pair? bindings)
-	     (symbol? (car bindings))
-	     (pair? (cdr bindings))
-	     (string? (cadr bindings)))
-	(string-append (symbol-name (car bindings))
-		       ": "
-		       (cadr bindings)
-		       (if (pair? (cddr bindings))
-			   (string-append "; " (loop (cddr bindings)))
-			   ";"))
-	(begin
-	  (if (not (null? bindings))
-	      (error:wrong-type-argument keyword-list "keyword list" 'STYLE))
-	  ""))))
-
-(define (comment . strings)
-  (make-xml-comment (string-append " " (apply string-append strings) " ")))
\ No newline at end of file