From 3c07c904225e366e077186784291a066a990f9c0 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 27 Oct 2004 20:02:07 +0000 Subject: [PATCH] No longer used. --- v7/src/ssp/matcher.scm | 184 ------------------------------ v7/src/ssp/xhtml.scm | 246 ----------------------------------------- 2 files changed, 430 deletions(-) delete mode 100644 v7/src/ssp/matcher.scm delete mode 100644 v7/src/ssp/xhtml.scm 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 -- 2.25.1