From: Taylor R. Campbell Date: Sun, 1 Apr 2007 17:33:07 +0000 (+0000) Subject: Use external strings to store the contents of Edwin buffers. Edwin can X-Git-Tag: 20090517-FFI~701 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f88f54bdfe00ece27a6cd666eb1eceff48e42a17;p=mit-scheme.git Use external strings to store the contents of Edwin buffers. Edwin can now edit files and buffers up to 32 MB without occupying more than a small and (roughly) constant amount of space in the Scheme heap. New procedures in the system global environment: EXTERNAL-STRING-DESCRIPTOR (Edwin needs this to initialize the group structure so that the microcode can get at it.) XSTRING-FILL! XSTRING-REF XSTRING-SET! XSUBSTRING (This was in imail/imail-util.scm.) XSUBSTRING-FILL! XSUBSTRING-FIND-NEXT-CHAR XSUBSTRING-FIND-NEXT-CHAR-CI XSUBSTRING-FIND-NEXT-CHAR-IN-SET XSUBSTRING-FIND-PREVIOUS-CHAR XSUBSTRING-FIND-PREVIOUS-CHAR-CI XSUBSTRING-FIND-PREVIOUS-CHAR-IN-SET (There is probably a better way to deal with most of the above procedures -- I expect that wouldn't hurt just to fold them into the string operations by similar names, since we already check argument types in those operations. This kludginess works for now, though.) --- diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index f127f8181..25b5f18b2 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: bufwin.scm,v 1.318 2007/01/05 21:19:23 cph Exp $ +$Id: bufwin.scm,v 1.319 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -631,21 +631,21 @@ USA. (define (%window-line-start-index? window index) (or (%window-group-start-index? window index) - (char=? (string-ref (group-text (%window-group window)) - (fix:- (group-index->position-integrable - (%window-group window) - index - #f) - 1)) + (char=? (xstring-ref (group-text (%window-group window)) + (fix:- (group-index->position-integrable + (%window-group window) + index + #f) + 1)) #\newline))) (define (%window-line-end-index? window index) (or (%window-group-end-index? window index) - (char=? (string-ref (group-text (%window-group window)) - (group-index->position-integrable - (%window-group window) - index - #t)) + (char=? (xstring-ref (group-text (%window-group window)) + (group-index->position-integrable + (%window-group window) + index + #t)) #\newline))) (define (clip-mark-to-display window mark) diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index 69dc4643b..7782100ba 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fileio.scm,v 1.170 2007/01/05 21:19:23 cph Exp $ +$Id: fileio.scm,v 1.171 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -232,7 +232,11 @@ of the predicates is satisfied, the file is written in the usual way." (end (fix:+ start length))) (let loop ((i start)) (if (fix:< i end) - (let ((n (input-port/read-substring! port text i end))) + (let ((n + (input-port/read-external-substring! port + text + i + end))) (if (fix:> n 0) (loop (fix:+ i n)) (fix:- i start))) @@ -696,9 +700,10 @@ Otherwise, a message is written both before and after long file writes." (group-write-to-port group start end port)))) (define (group-write-to-port group start end port) - (%group-write group start end - (lambda (string start end) - (output-port/write-substring port string start end)))) + (%group-write + group start end + (lambda (string start end) + (output-port/write-external-substring port string start end)))) (define (%group-write group start end writer) (let ((text (group-text group)) diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm index 427100cd8..3b52216ed 100644 --- a/v7/src/edwin/grpops.scm +++ b/v7/src/edwin/grpops.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: grpops.scm,v 1.33 2007/01/05 21:19:23 cph Exp $ +$Id: grpops.scm,v 1.34 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -78,12 +78,12 @@ USA. (fix:+ start* (fix:- gap-start start))))))) (define (group-left-char group index) - (string-ref (group-text group) - (fix:- (group-index->position-integrable group index #f) 1))) + (xstring-ref (group-text group) + (fix:- (group-index->position-integrable group index #f) 1))) (define (group-right-char group index) - (string-ref (group-text group) - (group-index->position-integrable group index #t))) + (xstring-ref (group-text group) + (group-index->position-integrable group index #t))) (define (group-extract-and-delete-string! group start end) (let ((string (group-extract-string group start end))) @@ -100,11 +100,7 @@ USA. (error:bad-range-argument n 'GROUP-INSERT-CHARS!)) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) (prepare-gap-for-insert! group index n) - (let ((text (group-text group)) - (end (fix:+ index n))) - (do ((index index (fix:+ index 1))) - ((fix:= index end)) - (string-set! text index char))) + (xsubstring-fill! (group-text group) index (fix:+ index n) char) (finish-group-insert! group index n) (set-interrupt-enables! interrupt-mask) unspecific)) @@ -222,7 +218,7 @@ USA. (set-group-gap-end! group gap-end) (set-group-gap-length! group (fix:- gap-end start)) (if (and (group-shrink-length group) - (fix:<= (fix:- (string-length text) + (fix:<= (fix:- (xstring-length text) (fix:- gap-end start)) (group-shrink-length group))) (shrink-group! group)))) @@ -266,9 +262,9 @@ USA. (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)) (end-index (fix:+ index 1))) (prepare-gap-for-replace! group index end-index) - (string-set! (group-text group) - (group-index->position-integrable group index #t) - char) + (xstring-set! (group-text group) + (group-index->position-integrable group index #t) + char) (finish-group-replace! group index end-index) (set-interrupt-enables! interrupt-mask) unspecific)) @@ -333,7 +329,7 @@ USA. (gap-start (group-gap-start group)) (gap-end (group-gap-end group)) (realloc-factor (group-reallocation-factor group))) - (let ((text-length (string-length text)) + (let ((text-length (xstring-length text)) (gap-delta (- new-gap-start gap-start))) (let ((n-chars (- text-length (group-gap-length group)))) (let ((new-text-length @@ -343,7 +339,7 @@ USA. (if (< length minimum-text-length) (loop length) length)))))) - (let ((new-text (string-allocate new-text-length)) + (let ((new-text (allocate-buffer-storage new-text-length)) (new-gap-length (- new-text-length n-chars))) (let ((new-gap-end (+ new-gap-start new-gap-length))) (cond ((= gap-delta 0) @@ -370,9 +366,10 @@ USA. (define (shrink-group! group) (let ((text (group-text group)) + (gap-start (group-gap-start group)) (gap-length (group-gap-length group)) (realloc-factor (group-reallocation-factor group))) - (let ((text-length (string-length text))) + (let ((text-length (xstring-length text))) (let ((n-chars (- text-length gap-length))) (let ((new-text-length (if (= n-chars 0) @@ -385,18 +382,20 @@ USA. length (loop length))))))) (gap-end (group-gap-end group))) - (let ((delta (- text-length new-text-length))) + (let ((new-text (allocate-buffer-storage new-text-length)) + (delta (- text-length new-text-length))) (let ((new-gap-end (- gap-end delta))) - (%substring-move! text gap-end text-length text new-gap-end) + (%substring-move! text 0 gap-start new-text 0) + (%substring-move! text gap-end text-length new-text new-gap-end) (set-group-gap-end! group new-gap-end) - (set-group-gap-length! group (- gap-length delta)))) - (set-string-maximum-length! text new-text-length)))) + (set-group-gap-length! group (- gap-length delta))) + (set-group-text! group new-text))))) (memoize-shrink-length! group realloc-factor))) (define (memoize-shrink-length! group realloc-factor) (set-group-shrink-length! group - (compute-shrink-length (string-length (group-text group)) realloc-factor))) + (compute-shrink-length (xstring-length (group-text group)) realloc-factor))) (define (compute-shrink-length length realloc-factor) (floor (/ (floor (/ length realloc-factor)) realloc-factor))) diff --git a/v7/src/edwin/image.scm b/v7/src/edwin/image.scm index d421e8f5e..151ad18f4 100644 --- a/v7/src/edwin/image.scm +++ b/v7/src/edwin/image.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: image.scm,v 1.142 2007/01/05 21:19:23 cph Exp $ +$Id: image.scm,v 1.143 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -64,19 +64,21 @@ USA. (do ((index start (fix:+ index 1)) (column column (fix:+ column - (let ((ascii (vector-8b-ref string index))) - (if (fix:= ascii (char->integer #\tab)) + (let ((char (xstring-ref string index))) + (if (char=? char #\tab) (fix:- tab-width (fix:remainder column tab-width)) (string-length - (vector-ref char-image-strings ascii))))))) + (vector-ref char-image-strings + (char->integer char)))))))) ((fix:= index end) column)) (do ((index start (fix:+ index 1)) (column column (fix:+ column (string-length (vector-ref char-image-strings - (vector-8b-ref string index)))))) + (char->integer + (xstring-ref string index))))))) ((fix:= index end) column)))) (define default-char-image-strings/original-emacs @@ -160,27 +162,28 @@ USA. (let loop ((index start) (column column)) (if (fix:= index end) (cons index column) - (let ((ascii (vector-8b-ref string index))) - (if (fix:= ascii (char->integer #\newline)) + (let ((char (xstring-ref string index))) + (if (char=? char #\newline) (cons index column) (loop (fix:+ index 1) (fix:+ column - (if (fix:= ascii (char->integer #\tab)) + (if (char=? char #\tab) (fix:- tab-width (fix:remainder column tab-width)) (string-length (vector-ref char-image-strings - ascii))))))))) + (char->integer char)))))))))) (let loop ((index start) (column column)) (if (fix:= index end) (cons index column) - (let ((ascii (vector-8b-ref string index))) - (if (fix:= ascii (char->integer #\newline)) + (let ((char (xstring-ref string index))) + (if (char=? char #\newline) (cons index column) (loop (fix:+ index 1) (fix:+ column (string-length - (vector-ref char-image-strings ascii)))))))))) + (vector-ref char-image-strings + (char->integer char))))))))))) (define (group-column->index group start end start-column column tab-width char-image-strings) @@ -235,28 +238,30 @@ USA. (let loop ((index start) (c start-column)) (if (or (fix:= c column) (fix:= index end) - (fix:= (char->integer #\newline) (vector-8b-ref string index))) + (char=? #\newline (xstring-ref string index))) (vector index c 0) (let ((c (fix:+ c - (let ((ascii (vector-8b-ref string index))) - (if (fix:= ascii (char->integer #\tab)) + (let ((char (xstring-ref string index))) + (if (char=? char #\tab) (fix:- tab-width (fix:remainder c tab-width)) (string-length - (vector-ref char-image-strings ascii))))))) + (vector-ref char-image-strings + (char->integer char)))))))) (if (fix:> c column) (vector index column (fix:- c column)) (loop (fix:+ index 1) c))))) (let loop ((index start) (c start-column)) (if (or (fix:= c column) (fix:= index end) - (fix:= (char->integer #\newline) (vector-8b-ref string index))) + (char=? #\newline (xstring-ref string index))) (vector index c 0) (let ((c (fix:+ c (string-length (vector-ref char-image-strings - (vector-8b-ref string index)))))) + (char->integer + (xstring-ref string index))))))) (if (fix:> c column) (vector index column (fix:- c column)) (loop (fix:+ index 1) c))))))) @@ -272,13 +277,13 @@ USA. (vector-set! results 0 string-index) (vector-set! results 1 image-index) (vector-set! results 2 0)) - (let ((ascii (vector-8b-ref string string-index)) + (let ((char (xstring-ref string string-index)) (partial (lambda (partial) (vector-set! results 0 string-index) (vector-set! results 1 image-end) (vector-set! results 2 partial)))) - (if (and (fix:= ascii (char->integer #\tab)) tab-width) + (if (and (char=? char #\tab) tab-width) (let ((n (fix:- tab-width (fix:remainder (fix:+ column-offset @@ -298,7 +303,8 @@ USA. ((fix:= image-index image-end)) (string-set! image image-index #\space)) (partial (fix:- end image-end)))))) - (let* ((image-string (vector-ref char-image-strings ascii)) + (let* ((image-string (vector-ref char-image-strings + (char->integer char))) (image-len (string-length image-string))) (string-set! image image-index (string-ref image-string 0)) (if (fix:= image-len 1) diff --git a/v7/src/edwin/search.scm b/v7/src/edwin/search.scm index 672795481..32b6c82b3 100644 --- a/v7/src/edwin/search.scm +++ b/v7/src/edwin/search.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: search.scm,v 1.161 2007/01/05 21:19:24 cph Exp $ +$Id: search.scm,v 1.162 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -64,11 +64,11 @@ USA. (GROUP-GAP-LENGTH GROUP)))))))))))) (define-next-char-search group-find-next-char - substring-find-next-char) + xsubstring-find-next-char) (define-next-char-search group-find-next-char-ci - substring-find-next-char-ci) + xsubstring-find-next-char-ci) (define-next-char-search group-find-next-char-in-set - substring-find-next-char-in-set) + xsubstring-find-next-char-in-set) (define-syntax define-prev-char-search (sc-macro-transformer @@ -102,11 +102,11 @@ USA. CHAR))))))))) (define-prev-char-search group-find-previous-char - substring-find-previous-char) + xsubstring-find-previous-char) (define-prev-char-search group-find-previous-char-ci - substring-find-previous-char-ci) + xsubstring-find-previous-char-ci) (define-prev-char-search group-find-previous-char-in-set - substring-find-previous-char-in-set) + xsubstring-find-previous-char-in-set) (define-integrable (%find-next-newline group start end) (group-find-next-char group start end #\newline)) @@ -127,7 +127,7 @@ USA. (let loop ((i1 s1) (i2 s2)) (if (or (fix:= i1 e1) (fix:= i2 string-end) - (not (char=? (string-ref text i1) + (not (char=? (xstring-ref text i1) (string-ref string i2)))) i1 (loop (fix:+ i1 1) (fix:+ i2 1))))))) @@ -155,7 +155,7 @@ USA. (let ((match (lambda (s1 e1 e2) (let loop ((i1 (fix:- e1 1)) (i2 (fix:- e2 1))) - (cond ((not (char=? (string-ref text i1) + (cond ((not (char=? (xstring-ref text i1) (string-ref string i2))) (fix:+ i1 1)) ((or (fix:= i1 s1) (fix:= i2 string-start)) @@ -193,7 +193,7 @@ USA. (let loop ((i1 s1) (i2 s2)) (if (or (fix:= i1 e1) (fix:= i2 string-end) - (not (char-ci=? (string-ref text i1) + (not (char-ci=? (xstring-ref text i1) (string-ref string i2)))) i1 (loop (fix:+ i1 1) (fix:+ i2 1))))))) @@ -221,7 +221,7 @@ USA. (let ((match (lambda (s1 e1 e2) (let loop ((i1 (fix:- e1 1)) (i2 (fix:- e2 1))) - (cond ((not (char-ci=? (string-ref text i1) + (cond ((not (char-ci=? (xstring-ref text i1) (string-ref string i2))) (fix:+ i1 1)) ((or (fix:= i1 s1) (fix:= i2 string-start)) diff --git a/v7/src/edwin/struct.scm b/v7/src/edwin/struct.scm index 8b15adcff..3d36f7376 100644 --- a/v7/src/edwin/struct.scm +++ b/v7/src/edwin/struct.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: struct.scm,v 1.103 2007/01/05 21:19:24 cph Exp $ +$Id: struct.scm,v 1.104 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -74,10 +74,10 @@ USA. (named) (constructor %make-group (buffer))) ;; The microcode file "edwin.h" depends on this structure being a - ;; named vector, and knows the indexes of the fields TEXT, + ;; named vector, and knows the indexes of the fields TEXT-DESCRIPTOR, ;; GAP-START, GAP-LENGTH, GAP-END, START-MARK, END-MARK, and ;; MODIFIED?. - (text (string-allocate 0)) + text-descriptor (gap-start 0) (gap-length 0) (gap-end 0) @@ -97,12 +97,14 @@ USA. buffer (shrink-length 0) (text-properties #f) - (%hash-number #f)) + (%hash-number #f) + %text) (define-integrable group-point group-%point) (define (make-group buffer) (let ((group (%make-group buffer))) + (set-group-text! group (allocate-buffer-storage 0)) (let ((start (make-permanent-mark group 0 #f))) (set-group-start-mark! group start) (set-group-display-start! group start)) @@ -112,8 +114,17 @@ USA. (set-group-%point! group (make-permanent-mark group 0 #t)) group)) +(define (set-group-text! group text) + (without-interrupts + (lambda () + (set-group-%text! group text) + (set-group-text-descriptor! group (external-string-descriptor text))))) + +(define-integrable (group-text group) + (group-%text group)) + (define (group-length group) - (fix:- (string-length (group-text group)) (group-gap-length group))) + (fix:- (xstring-length (group-text group)) (group-gap-length group))) (define-integrable (group-start-index group) (mark-index (group-start-mark group))) diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 550d2d44b..9705f6d74 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: utils.scm,v 1.59 2007/01/05 21:19:24 cph Exp $ +$Id: utils.scm,v 1.60 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -59,6 +59,25 @@ USA. (condition-signaller condition-type:allocation-failure '(N-WORDS OPERATOR) standard-error-handler)) + +(define (allocate-buffer-storage n-chars) + ;; Too much of Edwin relies on fixnum-specific arithmetic for this + ;; to be safe. Unfortunately, this means that Edwin can't edit + ;; files >32MB. + (let ((signal-failure + (lambda () + (error:allocation-failure (chars->words n-chars) + 'ALLOCATE-BUFFER-STORAGE)))) + (if (not (fix:fixnum? n-chars)) + (signal-failure) + ;; The ALLOCATE-EXTERNAL-STRING signals a bad-range-argument + ;; if the allocation with `malloc' (or `mmap') fails. + (bind-condition-handler (list condition-type:bad-range-argument) + (lambda (condition) + condition + (signal-failure)) + (lambda () + (allocate-external-string n-chars)))))) (define-syntax chars-to-words-shift (sc-macro-transformer @@ -73,6 +92,11 @@ USA. ((8) -3) (else (error "Can't support this word size:" chars-per-word))))))) +(define-integrable (chars->words n-chars) + (fix:lsh (fix:+ (fix:+ n-chars 1) ;Add 1 for NUL termination. + (fix:not (fix:lsh -1 (fix:- 0 (chars-to-words-shift))))) + (chars-to-words-shift))) + (define (edwin-string-allocate n-chars) (if (not (fix:fixnum? n-chars)) (error:wrong-type-argument n-chars "fixnum" 'STRING-ALLOCATE)) @@ -80,7 +104,8 @@ USA. (error:bad-range-argument n-chars 'STRING-ALLOCATE)) (with-interrupt-mask interrupt-mask/none (lambda (mask) - (let ((n-words (fix:+ (fix:lsh n-chars (chars-to-words-shift)) 3))) + (let ((n-words ;Add two, for manifest & length. + (fix:+ 2 (chars->words n-chars)))) (if (not ((ucode-primitive heap-available? 1) n-words)) (with-interrupt-mask interrupt-mask/gc-normal (lambda (ignore) @@ -93,7 +118,7 @@ USA. 0 ((ucode-primitive primitive-object-set-type 2) (ucode-type manifest-nm-vector) - (fix:- n-words 1))) + (fix:- n-words 1))) ;Subtract one for the manifest. (set-string-length! result n-chars) ;; This won't work if range-checking is turned on. (string-set! result n-chars #\nul) @@ -117,7 +142,7 @@ USA. 0 ((ucode-primitive primitive-object-set-type 2) (ucode-type manifest-nm-vector) - (fix:+ (fix:lsh n-chars (chars-to-words-shift)) 2))) + (fix:+ 1 (chars->words n-chars)))) ;Add one word for the length. (set-string-length! string n-chars) ;; This won't work if range-checking is turned on. (string-set! string n-chars #\nul) @@ -138,6 +163,9 @@ USA. target start-target) (cond ((not (fix:< start-source end-source)) unspecific) + ((or (external-string? source) (external-string? target)) + (xsubstring-move! source start-source end-source + target start-target)) ((not (eq? source target)) (if (fix:< (fix:- end-source start-source) 32) (do ((scan-source start-source (fix:+ scan-source 1)) @@ -170,20 +198,6 @@ USA. (string-ref source scan-source))) (substring-move-left! source start-source end-source source start-target))))) - -(define (string-append-char string char) - (let ((size (string-length string))) - (let ((result (string-allocate (fix:+ size 1)))) - (%substring-move! string 0 size result 0) - (string-set! result size char) - result))) - -(define (string-append-substring string1 string2 start2 end2) - (let ((length1 (string-length string1))) - (let ((result (string-allocate (fix:+ length1 (fix:- end2 start2))))) - (%substring-move! string1 0 length1 result 0) - (%substring-move! string2 start2 end2 result length1) - result))) (define (string-greatest-common-prefix strings) (let loop diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index c6e5e07b1..73c61c6ee 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: imail-util.scm,v 1.48 2007/01/05 21:19:25 cph Exp $ +$Id: imail-util.scm,v 1.49 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -477,11 +477,6 @@ USA. (set-istate-buffer-end! state end) (xsubstring-move! xstring start end buffer 0))) #t))))) - -(define (xsubstring xstring start end) - (let ((buffer (make-string (- end start)))) - (xsubstring-move! xstring start end buffer 0) - buffer)) (define (xstring-input-port/discard-chars port delimiters) (let ((state (port/state port))) diff --git a/v7/src/microcode/edwin.h b/v7/src/microcode/edwin.h index 420aa39cf..e0e298894 100644 --- a/v7/src/microcode/edwin.h +++ b/v7/src/microcode/edwin.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: edwin.h,v 1.13 2007/01/05 21:19:25 cph Exp $ +$Id: edwin.h,v 1.14 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -31,6 +31,9 @@ USA. #define GROUP_P VECTOR_P #define GROUP_TEXT(group) (VECTOR_REF ((group), 1)) +#define GROUP_TEXT_LOC(group, offset) \ + (((unsigned char *) (integer_to_ulong (GROUP_TEXT (group)))) + (offset)) + #define GROUP_GAP_START(group) \ (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF ((group), 2))) diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h index 5565170d9..3782ff311 100644 --- a/v7/src/microcode/prims.h +++ b/v7/src/microcode/prims.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: prims.h,v 9.55 2007/01/12 03:45:55 cph Exp $ +$Id: prims.h,v 9.56 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -108,6 +108,7 @@ extern long EXFUN (arg_ascii_integer, (int)); ? (STRING_POINTER (ARG_REF (arg))) \ : ((error_wrong_type_arg (arg)), ((char *) 0))) +extern PTR EXFUN (lookup_external_string, (SCHEME_OBJECT, unsigned long *)); extern PTR EXFUN (arg_extended_string, (unsigned int, unsigned long *)); #define BOOLEAN_ARG(arg) ((ARG_REF (arg)) != SHARP_F) diff --git a/v7/src/microcode/rgxprim.c b/v7/src/microcode/rgxprim.c index 6e1716701..65d6dde3e 100644 --- a/v7/src/microcode/rgxprim.c +++ b/v7/src/microcode/rgxprim.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: rgxprim.c,v 1.17 2007/01/05 21:19:25 cph Exp $ +$Id: rgxprim.c,v 1.18 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -197,7 +197,7 @@ DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-BACKWARD", Prim_re_search_substr_backward group = (ARG_REF (5)); \ match_start = (arg_nonnegative_integer (6)); \ match_end = (arg_nonnegative_integer (7)); \ - text = (STRING_LOC ((GROUP_TEXT (group)), 0)); \ + text = (GROUP_TEXT_LOC (group, 0)); \ text_start = (MARK_INDEX (GROUP_START_MARK (group))); \ text_end = (MARK_INDEX (GROUP_END_MARK (group))); \ gap_start = (GROUP_GAP_START (group)); \ diff --git a/v7/src/microcode/string.c b/v7/src/microcode/string.c index 845bca5cb..eb547d793 100644 --- a/v7/src/microcode/string.c +++ b/v7/src/microcode/string.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: string.c,v 9.52 2007/01/12 03:45:55 cph Exp $ +$Id: string.c,v 9.53 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -288,15 +288,14 @@ DEFINE_PRIMITIVE ("SUBSTRING-DOWNCASE!", Prim_substring_downcase, 3, 3, 0) SUBSTRING_MODIFIER (char_downcase) #define VECTOR_8B_SUBSTRING_PREFIX() \ - long start, end, ascii; \ + unsigned long start, end, length, ascii; \ unsigned char *string_start, *scan, *limit; \ PRIMITIVE_HEADER (4); \ - CHECK_ARG (1, STRING_P); \ - string_start = (STRING_LOC ((ARG_REF (1)), 0)); \ + string_start = (arg_extended_string (1, (&length))); \ start = (arg_nonnegative_integer (2)); \ end = (arg_nonnegative_integer (3)); \ ascii = (arg_ascii_integer (4)); \ - if (end > (STRING_LENGTH (ARG_REF (1)))) \ + if (end > length) \ error_bad_range_arg (3); \ if (start > end) \ error_bad_range_arg (2) @@ -362,16 +361,15 @@ DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR-CI", Prim_vec_8b_find_prev_char_ } #define SUBSTR_FIND_CHAR_IN_SET_PREFIX() \ - long start, end; \ + unsigned long start, end, length; \ unsigned char *char_set, *string_start, *scan, *limit; \ PRIMITIVE_HEADER (4); \ - CHECK_ARG (1, STRING_P); \ - string_start = (STRING_LOC ((ARG_REF (1)), 0)); \ + string_start = (arg_extended_string (1, (&length))); \ start = (arg_nonnegative_integer (2)); \ end = (arg_nonnegative_integer (3)); \ CHECK_ARG (4, STRING_P); \ char_set = (STRING_LOC ((ARG_REF (4)), 0)); \ - if (end > (STRING_LENGTH (ARG_REF (1)))) \ + if (end > length) \ error_bad_range_arg (3); \ if (start > end) \ error_bad_range_arg (2); \ @@ -642,7 +640,23 @@ DEFINE_PRIMITIVE ("EXTENDED-STRING-LENGTH", Prim_extended_string_length, 1, 1, 0 } PTR -DEFUN (arg_extended_string, (n), unsigned int n AND unsigned long * lp) +DEFUN (lookup_external_string, (descriptor, lp), + SCHEME_OBJECT descriptor AND + unsigned long * lp) +{ + ht_record_t * record; + if (external_strings == 0) + external_strings = (make_hash_table ()); + record = (ht_lookup (external_strings, (integer_to_ulong (descriptor)))); + if (record == 0) + return NULL; + if (lp != 0) + (*lp) = (HT_RECORD_N_BYTES (record)); + return (HT_RECORD_PTR (record)); +} + +PTR +DEFUN (arg_extended_string, (n, lp), unsigned int n AND unsigned long * lp) { SCHEME_OBJECT object = (ARG_REF (n)); if (STRING_P (object)) @@ -653,15 +667,10 @@ DEFUN (arg_extended_string, (n), unsigned int n AND unsigned long * lp) } else if ((INTEGER_P (object)) && (integer_to_ulong_p (object))) { - ht_record_t * record; - if (external_strings == 0) - external_strings = (make_hash_table ()); - record = (ht_lookup (external_strings, (integer_to_ulong (object)))); - if (record == 0) + PTR result = (lookup_external_string (object, lp)); + if (result == NULL) error_wrong_type_arg (n); - if (lp != 0) - (*lp) = (HT_RECORD_N_BYTES (record)); - return (HT_RECORD_PTR (record)); + return result; } else { diff --git a/v7/src/microcode/syntax.c b/v7/src/microcode/syntax.c index 7c49fd1eb..871302b02 100644 --- a/v7/src/microcode/syntax.c +++ b/v7/src/microcode/syntax.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: syntax.c,v 1.37 2007/01/05 21:19:25 cph Exp $ +$Id: syntax.c,v 1.38 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -220,7 +220,7 @@ DEFINE_PRIMITIVE ("CHAR->SYNTAX-CODE", Prim_char_to_syntax_code, 2, 2, 0) syntax_table = (ARG_REF (1)); \ CHECK_ARG (2, GROUP_P); \ group = (ARG_REF (2)); \ - first_char = (STRING_LOC ((GROUP_TEXT (group)), 0)); \ + first_char = (GROUP_TEXT_LOC (group, 0)); \ start = (first_char + (arg_nonnegative_integer (3))); \ end = (first_char + (arg_nonnegative_integer (4))); \ gap_start = (first_char + (GROUP_GAP_START (group))); \ diff --git a/v7/src/microcode/term.c b/v7/src/microcode/term.c index 85394e9dd..b57c3dafa 100644 --- a/v7/src/microcode/term.c +++ b/v7/src/microcode/term.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: term.c,v 1.22 2007/01/05 21:19:25 cph Exp $ +$Id: term.c,v 1.23 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -32,6 +32,7 @@ USA. #include "osfile.h" #include "edwin.h" #include "option.h" +#include "prims.h" extern long death_blow; extern char * Term_Messages []; @@ -285,8 +286,9 @@ DEFUN_VOID (edwin_auto_save) SCHEME_OBJECT group = (PAIR_CAR (entry)); char * namestring = ((char *) (STRING_LOC ((PAIR_CDR (entry)), 0))); SCHEME_OBJECT text = (GROUP_TEXT (group)); - unsigned char * start = (STRING_LOC (text, 0)); - unsigned char * end = (start + (STRING_LENGTH (text))); + unsigned long length; + unsigned char * start = (lookup_external_string (text, (&length))); + unsigned char * end = (start + length); unsigned char * gap_start = (start + (GROUP_GAP_START (group))); unsigned char * gap_end = (start + (GROUP_GAP_END (group))); if ((start < gap_start) || (gap_end < end)) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 60f8068b2..4ce303133 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.613 2007/03/21 15:06:16 cph Exp $ +$Id: runtime.pkg,v 14.614 2007/04/01 17:33:07 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -766,6 +766,7 @@ USA. decorated-string-append error:not-string error:not-xstring + external-string-descriptor external-string-length external-string? guarantee-string @@ -891,12 +892,21 @@ USA. vector-8b-find-previous-char-ci vector-8b-ref vector-8b-set! + xstring-fill! xstring-length xstring-move! + xstring-ref + xstring-set! xstring? + xsubstring + xsubstring-fill! + xsubstring-find-next-char + xsubstring-find-next-char-ci + xsubstring-find-next-char-in-set + xsubstring-find-previous-char + xsubstring-find-previous-char-ci + xsubstring-find-previous-char-in-set xsubstring-move!) - (export (runtime primitive-io) - external-string-descriptor) (export (runtime generic-i/o-port) %substring-move!) (initialization (initialize-package!)))