From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 5 Oct 2001 19:20:30 +0000 (+0000)
Subject: Remove URL and rexp support, which are now in the runtime system.
X-Git-Tag: 20090517-FFI~2511
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5a621eccab2942f42bcc027fa824d7c285910828;p=mit-scheme.git

Remove URL and rexp support, which are now in the runtime system.
---

diff --git a/v7/src/imail/compile.scm b/v7/src/imail/compile.scm
index 47393588c..91c7ed9ce 100644
--- a/v7/src/imail/compile.scm
+++ b/v7/src/imail/compile.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: compile.scm,v 1.12 2001/08/15 03:10:30 cph Exp $
+;;; $Id: compile.scm,v 1.13 2001/10/05 19:20:01 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -34,9 +34,7 @@
 		"imail-util"
 		"imap-response"
 		"imap-syntax"
-		"parser"
-		"rexp"
-		"url"))
+		"parser"))
     (for-each (let ((syntax-table
 		     (access edwin-syntax-table (->environment '(EDWIN)))))
 		(lambda (filename)
diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm
index 12bf6d6b6..f32b51830 100644
--- a/v7/src/imail/ed-ffi.scm
+++ b/v7/src/imail/ed-ffi.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: ed-ffi.scm,v 1.14 2001/05/26 02:58:27 cph Exp $
+;;; $Id: ed-ffi.scm,v 1.15 2001/10/05 19:20:03 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -45,8 +45,4 @@
     ("imap-syntax"	(edwin imail imap-syntax)
 			system-global-syntax-table)
     ("parser"		(edwin imail parser)
-			system-global-syntax-table)
-    ("rexp"		(edwin imail rexp)
-			system-global-syntax-table)
-    ("url"		(edwin imail url)
 			system-global-syntax-table)))
\ No newline at end of file
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 8ce13281f..9af48c6cb 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.88 2001/09/28 00:41:16 cph Exp $
+;;; $Id: imail.pkg,v 1.89 2001/10/05 19:20:05 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -25,34 +25,6 @@
 (global-definitions "../sos/sos")
 (global-definitions "../edwin/edwinunx")
 
-(define-package (edwin imail rexp)
-  (files "rexp")
-  (parent (edwin imail))
-  (export (edwin imail)
-	  rexp*
-	  rexp+
-	  rexp->regexp
-	  rexp-alternatives
-	  rexp-any-char
-	  rexp-case-fold
-	  rexp-compile
-	  rexp-group
-	  rexp-line-end
-	  rexp-line-start
-	  rexp-not-syntax-char
-	  rexp-not-word-char
-	  rexp-not-word-edge
-	  rexp-optional
-	  rexp-sequence
-	  rexp-string-end
-	  rexp-string-start
-	  rexp-syntax-char
-	  rexp-word-char
-	  rexp-word-edge
-	  rexp-word-end
-	  rexp-word-start
-	  rexp?))
-
 (define-package (edwin imail parser)
   (files "parser")
   (parent (edwin imail))
@@ -82,32 +54,6 @@
 	  simple-parser
 	  string-matcher))
 
-(define-package (edwin imail url)
-  (files "url")
-  (parent (edwin imail))
-  (export (edwin imail)
-	  url:char-set:escaped
-	  url:char-set:extra
-	  url:char-set:national
-	  url:char-set:punctuation
-	  url:char-set:reserved
-	  url:char-set:safe
-	  url:char-set:unescaped
-	  url:char-set:unreserved
-	  url:decode-string
-	  url:decode-substring
-	  url:encode-string
-	  url:encode-substring
-	  url:rexp:escape
-	  url:rexp:host
-	  url:rexp:hostname
-	  url:rexp:hostnumber
-	  url:rexp:hostport
-	  url:rexp:uchar
-	  url:rexp:xchar
-	  url:string-encoded?
-	  url:substring-encoded?))
-
 (define-package (edwin imail)
   (files "imail-util"
 	 "imail-core")
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index 644a289f7..eec7adc87 100644
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.31 2001/09/28 19:18:42 cph Exp $
+;;; $Id: load.scm,v 1.32 2001/10/05 19:20:07 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -24,6 +24,7 @@
 (load-option 'HASH-TABLE)
 (load-option 'REGULAR-EXPRESSION)
 (load-option 'SOS)
+(load-option 'URL)
 (with-working-directory-pathname (directory-pathname (current-load-pathname))
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
diff --git a/v7/src/imail/rexp.scm b/v7/src/imail/rexp.scm
deleted file mode 100644
index 94651a8d1..000000000
--- a/v7/src/imail/rexp.scm
+++ /dev/null
@@ -1,217 +0,0 @@
-;;; -*-Scheme-*-
-;;;
-;;; $Id: rexp.scm,v 1.15 2000/07/08 00:41:45 cph Exp $
-;;;
-;;; Copyright (c) 2000 Massachusetts Institute of Technology
-;;;
-;;; 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., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;;; List-based Regular Expressions
-
-(declare (usual-integrations))
-
-(define (rexp? rexp)
-  (or (char-set? rexp)
-      (string? rexp)
-      (and (pair? rexp)
-	   (list? (cdr rexp))
-	   (let ((one-arg
-		  (lambda ()
-		    (and (fix:= 1 (length (cdr rexp)))
-			 (rexp? (cadr rexp))))))
-	     (case (car rexp)
-	       ((ALTERNATIVES SEQUENCE)
-		(for-all? (cdr rexp) rexp?))
-	       ((GROUP OPTIONAL * +)
-		(and (one-arg)
-		     (not (or (and (string? rexp)
-				   (string-null? rexp))
-			      (and (pair? rexp)
-				   (memq (car rexp) boundary-rexp-types))))))
-	       ((CASE-FOLD)
-		(and (fix:= 1 (length (cdr rexp)))
-		     (string? (cadr exp))))
-	       ((ANY-CHAR LINE-START LINE-END STRING-START STRING-END
-			  WORD-EDGE NOT-WORD-EDGE WORD-START WORD-END
-			  WORD-CHAR NOT-WORD-CHAR)
-		(null? (cdr rexp)))
-	       ((SYNTAX-CHAR NOT-SYNTAX-CHAR)
-		(and (one-arg)
-		     (assq (cadr rexp) syntax-type-alist)))
-	       (else #f))))))
-
-(define boundary-rexp-types
-  '(LINE-START LINE-END STRING-START STRING-END WORD-EDGE NOT-WORD-EDGE
-	       WORD-START WORD-END))
-
-(define syntax-type-alist
-  '((WHITESPACE . " ")
-    (PUNCTUATION . ".")
-    (WORD . "w")
-    (SYMBOL . "_")
-    (OPEN . "(")
-    (CLOSE . ")")
-    (QUOTE . "\'")
-    (STRING-DELIMITER . "\"")
-    (MATH-DELIMITER . "$")
-    (ESCAPE . "\\")
-    (CHAR-QUOTE . "/")
-    (COMMENT-START . "<")
-    (COMMENT-END . ">")))
-
-(define (rexp-alternatives . rexps)
-  `(ALTERNATIVES ,@rexps))
-
-(define (rexp-sequence . rexps)
-  (let ((rexps (simplify-sequence-args rexps)))
-    (if (pair? rexps)
-	(if (pair? (cdr rexps))
-	    `(SEQUENCE ,@rexps)
-	    (car rexps))
-	"")))
-
-(define (simplify-sequence-args rexps)
-  (append-map (lambda (rexp)
-		(cond ((and (string? rexp) (string-null? rexp))
-		       '())
-		      ((and (pair? rexp) (eq? 'SEQUENCE (car rexp)))
-		       (cdr rexp))
-		      ((and (pair? rexp) (eq? 'ALTERNATIVES (car rexp)))
-		       (list `(GROUP ,rexp)))
-		      (else
-		       (list rexp))))
-	      rexps))
-
-(define (rexp-group . rexps)
-  `(GROUP ,(apply rexp-sequence rexps)))
-
-(define (rexp-optional . rexps)
-  `(OPTIONAL ,(rexp-groupify (apply rexp-sequence rexps))))
-
-(define (rexp* . rexps)
-  `(* ,(rexp-groupify (apply rexp-sequence rexps))))
-
-(define (rexp+ . rexps)
-  `(+ ,(rexp-groupify (apply rexp-sequence rexps))))
-
-(define (rexp-groupify rexp)
-  (let ((group (lambda () `(GROUP ,rexp)))
-	(no-group (lambda () (error "Expression can't be grouped:" rexp))))
-    (cond ((and (string? rexp) (not (char-set? rexp)))
-	   (case (string-length rexp)
-	     ((0) (no-group))
-	     ((1) rexp)
-	     (else (group))))
-	  ((pair? rexp)
-	   (cond ((memq (car rexp) boundary-rexp-types)
-		  (no-group))
-		 ((memq (car rexp) '(ALTERNATIVES SEQUENCE OPTIONAL * +))
-		  (group))
-		 (else rexp)))
-	  (else rexp))))
-
-(define (rexp-any-char) `(ANY-CHAR))
-(define (rexp-line-start) `(LINE-START))
-(define (rexp-line-end) `(LINE-END))
-(define (rexp-string-start) `(STRING-START))
-(define (rexp-string-end) `(STRING-END))
-(define (rexp-word-edge) `(WORD-EDGE))
-(define (rexp-not-word-edge) `(NOT-WORD-EDGE))
-(define (rexp-word-start) `(WORD-START))
-(define (rexp-word-end) `(WORD-END))
-(define (rexp-word-char) `(WORD-CHAR))
-(define (rexp-not-word-char) `(NOT-WORD-CHAR))
-(define (rexp-syntax-char type) `(SYNTAX-CHAR ,type))
-(define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type))
-
-(define (rexp-case-fold rexp)
-  (cond ((and (string? rexp) (not (char-set? rexp)))
-	 `(CASE-FOLD ,rexp))
-	((and (pair? rexp)
-	      (memq (car rexp) '(ALTERNATIVES SEQUENCE GROUP OPTIONAL * +))
-	      (list? (cdr rexp)))
-	 (cons (car rexp)
-	       (map rexp-case-fold (cdr rexp))))
-	(else rexp)))
-
-(define (rexp-compile rexp)
-  (re-compile-pattern (rexp->regexp rexp) #f))
-
-(define (rexp->regexp rexp)
-  (let ((lose (lambda () (error "Malformed rexp:" rexp))))
-    (cond ((char-set? rexp)
-	   (char-set->regexp rexp))
-	  ((string? rexp)
-	   (re-quote-string rexp))
-	  ((and (pair? rexp) (list? (cdr rexp)))
-	   (let ((one-arg
-		  (lambda ()
-		    (if (fix:= 1 (length (cdr rexp)))
-			(cadr rexp)
-			(lose))))
-		 (rexp-args (lambda () (map rexp->regexp (cdr rexp)))))
-	     (let ((rexp-arg (lambda () (rexp->regexp (one-arg))))
-		   (syntax-type
-		    (lambda ()
-		      (let ((entry (assq (one-arg) syntax-type-alist)))
-			(if entry
-			    (cdr entry)
-			    (lose))))))
-	       (case (car rexp)
-		 ((ALTERNATIVES)
-		  (decorated-string-append "" "\\|" "" (rexp-args)))
-		 ((SEQUENCE) (apply string-append (rexp-args)))
-		 ((GROUP) (string-append "\\(" (rexp-arg) "\\)"))
-		 ((OPTIONAL) (string-append (rexp-arg) "?"))
-		 ((*) (string-append (rexp-arg) "*"))
-		 ((+) (string-append (rexp-arg) "+"))
-		 ((CASE-FOLD)
-		  (let ((arg (one-arg)))
-		    (if (and (string? arg) (not (char-set? arg)))
-			(case-fold-string arg)
-			(lose))))
-		 ((ANY-CHAR) ".")
-		 ((LINE-START) "^")
-		 ((LINE-END) "$")
-		 ((STRING-START) "\\`")
-		 ((STRING-END) "\\'")
-		 ((WORD-EDGE) "\\b")
-		 ((NOT-WORD-EDGE) "\\B")
-		 ((WORD-START) "\\<")
-		 ((WORD-END) "\\>")
-		 ((WORD-CHAR) "\\w")
-		 ((NOT-WORD-CHAR) "\\W")
-		 ((SYNTAX-CHAR) (string-append "\\s" (syntax-type)))
-		 ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type)))
-		 (else (lose))))))
-	  (else (lose)))))
-
-(define (case-fold-string s)
-  (let ((end (string-length s)))
-    (let loop ((start 0) (parts '()))
-      (let ((index
-	     (substring-find-next-char-in-set s start end
-					      char-set:alphabetic)))
-	(if index
-	    (loop (fix:+ index 1)
-		  (cons* (let ((char (string-ref s index)))
-			   (string-append "["
-					  (string (char-upcase char))
-					  (string (char-downcase char))
-					  "]"))
-			 (re-quote-string
-			  (substring s start index))
-			 parts))
-	    (apply string-append (reverse! parts)))))))
\ No newline at end of file
diff --git a/v7/src/imail/url.scm b/v7/src/imail/url.scm
deleted file mode 100644
index db461a84a..000000000
--- a/v7/src/imail/url.scm
+++ /dev/null
@@ -1,149 +0,0 @@
-;;; -*-Scheme-*-
-;;;
-;;; $Id: url.scm,v 1.8 2000/07/02 05:09:21 cph Exp $
-;;;
-;;; Copyright (c) 2000 Massachusetts Institute of Technology
-;;;
-;;; 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., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;;; URL Encoding
-
-(declare (usual-integrations))
-
-(define url:char-set:safe (string->char-set "$-_.+"))
-(define url:char-set:extra (string->char-set "!*'(),"))
-(define url:char-set:national (string->char-set "{}|\\^~[]`"))
-(define url:char-set:punctuation (string->char-set "<>#%\""))
-(define url:char-set:reserved (string->char-set ";/?:@&="))
-
-(define url:char-set:unreserved
-  (char-set-union char-set:alphanumeric
-		  url:char-set:safe
-		  url:char-set:extra))
-
-(define url:char-set:unescaped
-  (char-set-union url:char-set:unreserved
-		  url:char-set:reserved))
-
-(define url:char-set:escaped
-  (char-set-invert url:char-set:unescaped))
-
-(define url:rexp:escape
-  (let ((char-set:hex (string->char-set "0123456789ABCDEFabcdef")))
-    (rexp-sequence "%" char-set:hex char-set:hex)))
-
-(define url:rexp:uchar
-  (rexp-alternatives url:char-set:unreserved url:rexp:escape))
-
-(define url:rexp:xchar
-  (rexp-alternatives url:char-set:unescaped url:rexp:escape))
-
-(define url:rexp:hostname
-  (let ((tail
-	 (rexp-optional
-	  (rexp*
-	   (char-set-union char-set:alphanumeric (string->char-set "-")))
-	  char-set:alphanumeric)))
-    (rexp-sequence (rexp* char-set:alphanumeric tail ".")
-		   char-set:alphabetic
-		   tail)))
-
-(define url:rexp:hostnumber
-  (let ((n (rexp+ char-set:numeric)))
-    (rexp-sequence n "." n "." n "." n)))
-
-(define url:rexp:host
-  (rexp-alternatives url:rexp:hostname url:rexp:hostnumber))
-
-(define url:rexp:hostport
-  (rexp-sequence url:rexp:host (rexp-optional ":" (rexp+ char-set:numeric))))
-
-(define (url:string-encoded? string)
-  (url:substring-encoded? string 0 (string-length string)))
-
-(define (url:encode-string string)
-  (url:encode-substring string 0 (string-length string)))
-
-(define (url:decode-string string)
-  (url:decode-substring string 0 (string-length string)))
-
-(define url:substring-encoded?
-  (let ((pattern (rexp-compile url:rexp:xchar)))
-    (lambda (string start end)
-      (let ((regs (re-substring-match pattern string start end)))
-	(and regs
-	     (fix:= end (re-match-end-index 0 regs)))))))
-
-(define (url:encode-substring string start end)
-  (let ((n-to-encode
-	 (let loop ((start start) (n-to-encode 0))
-	   (let ((index
-		  (substring-find-next-char-in-set string start end
-						   url:char-set:escaped)))
-	     (if index
-		 (loop (fix:+ index 1) (fix:+ n-to-encode 1))
-		 n-to-encode)))))
-    (if (fix:= 0 n-to-encode)
-	(substring string start end)
-	(let ((encoded
-	       (make-string (fix:+ (fix:- end start) (fix:* 2 n-to-encode))))
-	      (digits "0123456789ABCDEF"))
-	  (let loop ((start start) (i 0))
-	    (let ((index
-		   (substring-find-next-char-in-set string start end
-						    url:char-set:escaped)))
-	      (if index
-		  (begin
-		    (substring-move! string start index encoded i)
-		    (let ((i (fix:+ i (fix:- index start)))
-			  (code (vector-8b-ref string index)))
-		      (string-set! encoded i #\%)
-		      (string-set! encoded
-				   (fix:+ i 1)
-				   (string-ref digits (fix:lsh code -4)))
-		      (string-set! encoded
-				   (fix:+ i 2)
-				   (string-ref digits (fix:and code #x0F)))
-		      (loop (fix:+ index 1) (fix:+ i 3))))
-		  (substring-move! string start end encoded i))))
-	  encoded))))
-
-(define (url:decode-substring string start end)
-  (let ((patt (rexp-compile url:rexp:escape)))
-    (let ((n-encoded
-	   (let loop ((start start) (n-encoded 0))
-	     (let ((regs (re-substring-search-forward patt string start end)))
-	       (if regs
-		   (loop (re-match-end-index 0 regs) (fix:+ n-encoded 1))
-		   n-encoded)))))
-      (if (fix:= 0 n-encoded)
-	  (substring string start end)
-	  (let ((decoded
-		 (make-string (fix:- (fix:- end start) (fix:* 2 n-encoded)))))
-	    (let loop ((start start) (i 0))
-	      (let ((regs (re-substring-search-forward patt string start end)))
-		(if regs
-		    (let ((index (re-match-start-index 0 regs)))
-		      (substring-move! string start index decoded i)
-		      (let ((i (fix:+ i (fix:- index start))))
-			(vector-8b-set!
-			 decoded i
-			 (substring->number string
-					     (fix:+ index 1)
-					     (fix:+ index 3)
-					     16))
-			(loop (fix:+ index 3) (fix:+ i 1))))
-		    (substring-move! string start end decoded i))))
-	    decoded)))))
\ No newline at end of file