#| -*-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,
(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)
#| -*-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,
(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)))
(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))
#| -*-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,
(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)))
(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))
(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))))
(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))
(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
(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)
(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)
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)))
#| -*-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,
(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))))
\f
(define default-char-image-strings/original-emacs
(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)))))))))))
\f
(define (group-column->index group start end start-column column tab-width
char-image-strings)
(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)))))))
(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
((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)
#| -*-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,
(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
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)
\f
(define-integrable (%find-next-newline group start end)
(group-find-next-char group start end #\newline))
(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)))))))
(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))
(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)))))))
(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))
#| -*-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,
(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)
buffer
(shrink-length 0)
(text-properties #f)
- (%hash-number #f))
+ (%hash-number #f)
+ %text)
(define-integrable group-point group-%point)
\f
(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))
(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)))
#| -*-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,
(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))))))
\f
(define-syntax chars-to-words-shift
(sc-macro-transformer
((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))
(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)
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)
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)
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))
(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)))
\f
(define (string-greatest-common-prefix strings)
(let loop
#| -*-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,
(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))
\f
(define (xstring-input-port/discard-chars port delimiters)
(let ((state (port/state port)))
/* -*-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,
#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)))
/* -*-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,
? (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)
/* -*-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,
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)); \
/* -*-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,
SUBSTRING_MODIFIER (char_downcase)
\f
#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)
}
\f
#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); \
}
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))
}
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
{
/* -*-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,
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))); \
/* -*-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,
#include "osfile.h"
#include "edwin.h"
#include "option.h"
+#include "prims.h"
extern long death_blow;
extern char * Term_Messages [];
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))
#| -*-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,
decorated-string-append
error:not-string
error:not-xstring
+ external-string-descriptor
external-string-length
external-string?
guarantee-string
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!)))
projects / mit-scheme.git / commitdiff