From a637ee4ec8be27fd0c8a103a19cbb0cb97b3cf30 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 13 Apr 2000 18:00:53 +0000 Subject: [PATCH] Fix compiler warnings. --- v7/src/imail/ed-ffi.scm | 6 ++--- v7/src/imail/imail-imap-url.scm | 10 ++++--- v7/src/imail/rexp.scm | 48 +++++++++------------------------ v7/src/runtime/rexp.scm | 48 +++++++++------------------------ 4 files changed, 33 insertions(+), 79 deletions(-) diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm index 460ec18a1..fb4923132 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.3 2000/04/13 15:36:00 cph Exp $ +;;; $Id: ed-ffi.scm,v 1.4 2000/04/13 18:00:53 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -28,6 +28,6 @@ ("imail-top" (edwin imail) edwin-syntax-table) ("imail-umail" (edwin imail) system-global-syntax-table) ("imail-util" (edwin imail) system-global-syntax-table) - ("rexp" (runtime rexp) system-global-syntax-table) + ("rexp" (edwin imail rexp) system-global-syntax-table) ("rfc822" (edwin imail) system-global-syntax-table) - ("url" (runtime url) system-global-syntax-table))) \ No newline at end of file + ("url" (edwin imail url) system-global-syntax-table))) \ No newline at end of file diff --git a/v7/src/imail/imail-imap-url.scm b/v7/src/imail/imail-imap-url.scm index 02139457e..dcaddb99a 100644 --- a/v7/src/imail/imail-imap-url.scm +++ b/v7/src/imail/imail-imap-url.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-imap-url.scm,v 1.5 2000/04/13 16:58:39 cph Exp $ +;;; $Id: imail-imap-url.scm,v 1.6 2000/04/13 17:57:52 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -165,10 +165,12 @@ (or (imap:match-quoted-string string start end) (imap:match-literal string start end))) +(define imap:char-set:achar + (char-set-union url:char-set:unreserved + (string->char-set "&=~"))) + (define imap:rexp:achar+ - (rexp+ (rexp-alternatives (char-set-union url:char-set:unreserved - (string->char-set "&=~")) - url:rexp:escape))) + (rexp+ (rexp-alternatives imap:char-set:achar url:rexp:escape))) (define imap:rexp:bchar+ (rexp+ (rexp-alternatives (char-set-union imap:char-set:achar diff --git a/v7/src/imail/rexp.scm b/v7/src/imail/rexp.scm index dcabc19fb..a54a4f255 100644 --- a/v7/src/imail/rexp.scm +++ b/v7/src/imail/rexp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rexp.scm,v 1.8 2000/04/13 16:56:49 cph Exp $ +;;; $Id: rexp.scm,v 1.9 2000/04/13 17:57:57 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -22,7 +22,7 @@ (declare (usual-integrations)) -(define (rexp? object) +(define (rexp? rexp) (or (string? rexp) (char-set? rexp) (and (pair? rexp) @@ -133,15 +133,14 @@ (define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type)) (define (rexp-case-fold rexp) - (let ((lose (lambda () (error "Malformed rexp:" rexp)))) - (cond ((string? 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)))) + (cond ((string? 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)) @@ -193,7 +192,7 @@ ((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 '())) @@ -210,27 +209,4 @@ (re-quote-string (substring s start index)) parts)) - (apply string-append (reverse! parts))))))) - -(define (separated-append tokens separator) - (cond ((not (pair? tokens)) "") - ((not (pair? (cdr tokens))) (car tokens)) - (else - (let ((string - (make-string - (let ((ns (string-length separator))) - (do ((tokens (cdr tokens) (cdr tokens)) - (count (string-length (car tokens)) - (fix:+ count - (fix:+ (string-length (car tokens)) - ns)))) - ((not (pair? tokens)) count)))))) - (let loop - ((tokens (cdr tokens)) - (index (string-move! (car tokens) string 0))) - (if (pair? tokens) - (loop (cdr tokens) - (string-move! (car tokens) - string - (string-move! separator string index))))) - string)))) \ No newline at end of file + (apply string-append (reverse! parts))))))) \ No newline at end of file diff --git a/v7/src/runtime/rexp.scm b/v7/src/runtime/rexp.scm index dcabc19fb..a54a4f255 100644 --- a/v7/src/runtime/rexp.scm +++ b/v7/src/runtime/rexp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rexp.scm,v 1.8 2000/04/13 16:56:49 cph Exp $ +;;; $Id: rexp.scm,v 1.9 2000/04/13 17:57:57 cph Exp $ ;;; ;;; Copyright (c) 2000 Massachusetts Institute of Technology ;;; @@ -22,7 +22,7 @@ (declare (usual-integrations)) -(define (rexp? object) +(define (rexp? rexp) (or (string? rexp) (char-set? rexp) (and (pair? rexp) @@ -133,15 +133,14 @@ (define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type)) (define (rexp-case-fold rexp) - (let ((lose (lambda () (error "Malformed rexp:" rexp)))) - (cond ((string? 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)))) + (cond ((string? 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)) @@ -193,7 +192,7 @@ ((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 '())) @@ -210,27 +209,4 @@ (re-quote-string (substring s start index)) parts)) - (apply string-append (reverse! parts))))))) - -(define (separated-append tokens separator) - (cond ((not (pair? tokens)) "") - ((not (pair? (cdr tokens))) (car tokens)) - (else - (let ((string - (make-string - (let ((ns (string-length separator))) - (do ((tokens (cdr tokens) (cdr tokens)) - (count (string-length (car tokens)) - (fix:+ count - (fix:+ (string-length (car tokens)) - ns)))) - ((not (pair? tokens)) count)))))) - (let loop - ((tokens (cdr tokens)) - (index (string-move! (car tokens) string 0))) - (if (pair? tokens) - (loop (cdr tokens) - (string-move! (car tokens) - string - (string-move! separator string index))))) - string)))) \ No newline at end of file + (apply string-append (reverse! parts))))))) \ No newline at end of file -- 2.25.1