summaryrefslogtreecommitdiffstats
path: root/mitcomp.pat
diff options
context:
space:
mode:
Diffstat (limited to 'mitcomp.pat')
-rw-r--r--mitcomp.pat1466
1 files changed, 1466 insertions, 0 deletions
diff --git a/mitcomp.pat b/mitcomp.pat
new file mode 100644
index 0000000..78cb9b9
--- /dev/null
+++ b/mitcomp.pat
@@ -0,0 +1,1466 @@
+;"mitcomp.pat", patch file of definitions for compiling SLIB with MitScheme.
+;;; Copyright (C) 1993 Matthew McDonald.
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+From: mafm@cs.uwa.edu.au (Matthew MCDONALD)
+
+ Added declarations to files providing these:
+dynamic alist hash hash-table logical random random-inexact modular
+prime charplot common-list-functions format generic-write pprint-file
+pretty-print-to-string object->string string-case printf line-i/o
+synchk priority-queue process red-black-tree sort
+
+(for-each cf
+ '("dynamic.scm" "alist.scm" "hash.scm" "hashtab.scm" "logical.scm"
+ "random.scm" "randinex.scm" "modular.scm" "prime.scm" "charplot.scm"
+ "comlist.scm" "format.scm" "genwrite.scm" "ppfile.scm" "pp2str.scm"
+ "obj2str.scm" "strcase.scm" "printf.scm" "lineio.scm" "synchk.scm"
+ "priorque.scm" "process.scm" "rbtree.scm" "sort.scm))
+
+while in the SLIB directory will compile all of these.
+
+ They all appear to still be working... They should be
+everything CScheme currently uses (except [1] below.)
+
+NOTES:
+
+[1] Not altered:
+ debug Not worth optimising
+ test " " "
+ fluid-let compiler chokes over
+ (lambda () . body)
+ scmacro Fails when compiled, not immediately obvious why
+ synclo " " "
+ r4rsyn " " "
+ yasos requires the macros
+ collect " " "
+
+[2] removed 'sort from list of MIT features. The library version is
+more complete (and needed for charplot.)
+
+[3] Remember that mitscheme.init gets the .bin put in the wrong place
+by the compiler and thus doesn't get recognised by LOAD.
+======================================================================
+diff -c slib/alist.scm nlib/alist.scm
+*** slib/alist.scm Thu Jan 21 00:01:34 1993
+--- nlib/alist.scm Tue Feb 9 00:21:07 1993
+***************
+*** 44,50 ****
+ ;(define rem (alist-remover string-ci=?))
+ ;(set! alist (rem alist "fOO"))
+
+! (define (predicate->asso pred)
+ (cond ((eq? eq? pred) assq)
+ ((eq? = pred) assv)
+ ((eq? eqv? pred) assv)
+--- 44,53 ----
+ ;(define rem (alist-remover string-ci=?))
+ ;(set! alist (rem alist "fOO"))
+
+! ;;; Declarations for CScheme
+! (declare (usual-integrations))
+!
+! (define-integrable (predicate->asso pred)
+ (cond ((eq? eq? pred) assq)
+ ((eq? = pred) assv)
+ ((eq? eqv? pred) assv)
+***************
+*** 57,69 ****
+ ((pred key (caar al)) (car al))
+ (else (l (cdr al)))))))))
+
+! (define (alist-inquirer pred)
+ (let ((assofun (predicate->asso pred)))
+ (lambda (alist key)
+ (let ((pair (assofun key alist)))
+ (and pair (cdr pair))))))
+
+! (define (alist-associator pred)
+ (let ((assofun (predicate->asso pred)))
+ (lambda (alist key val)
+ (let* ((pair (assofun key alist)))
+--- 60,72 ----
+ ((pred key (caar al)) (car al))
+ (else (l (cdr al)))))))))
+
+! (define-integrable (alist-inquirer pred)
+ (let ((assofun (predicate->asso pred)))
+ (lambda (alist key)
+ (let ((pair (assofun key alist)))
+ (and pair (cdr pair))))))
+
+! (define-integrable (alist-associator pred)
+ (let ((assofun (predicate->asso pred)))
+ (lambda (alist key val)
+ (let* ((pair (assofun key alist)))
+***************
+*** 71,77 ****
+ alist)
+ (else (cons (cons key val) alist)))))))
+
+! (define (alist-remover pred)
+ (lambda (alist key)
+ (cond ((null? alist) alist)
+ ((pred key (caar alist)) (cdr alist))
+--- 74,80 ----
+ alist)
+ (else (cons (cons key val) alist)))))))
+
+! (define-integrable (alist-remover pred)
+ (lambda (alist key)
+ (cond ((null? alist) alist)
+ ((pred key (caar alist)) (cdr alist))
+diff -c slib/charplot.scm nlib/charplot.scm
+*** slib/charplot.scm Sat Nov 14 21:50:54 1992
+--- nlib/charplot.scm Tue Feb 9 00:21:07 1993
+***************
+*** 7,12 ****
+--- 7,24 ----
+ ;are strings with names to label the x and y axii with.
+
+ ;;;;---------------------------------------------------------------
++
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate-external "sort"))
++ (declare (integrate
++ rows
++ columns
++ charplot:height
++ charplot:width
++ charplot:plot
++ plot!))
++
+ (require 'sort)
+
+ (define rows 24)
+***************
+*** 27,39 ****
+ (write-char char)
+ (charplot:printn! (+ n -1) char))))
+
+! (define (charplot:center-print! str width)
+ (let ((lpad (quotient (- width (string-length str)) 2)))
+ (charplot:printn! lpad #\ )
+ (display str)
+ (charplot:printn! (- width (+ (string-length str) lpad)) #\ )))
+
+! (define (scale-it z scale)
+ (if (and (exact? z) (integer? z))
+ (quotient (* z (car scale)) (cadr scale))
+ (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
+--- 39,51 ----
+ (write-char char)
+ (charplot:printn! (+ n -1) char))))
+
+! (define-integrable (charplot:center-print! str width)
+ (let ((lpad (quotient (- width (string-length str)) 2)))
+ (charplot:printn! lpad #\ )
+ (display str)
+ (charplot:printn! (- width (+ (string-length str) lpad)) #\ )))
+
+! (define-integrable (scale-it z scale)
+ (if (and (exact? z) (integer? z))
+ (quotient (* z (car scale)) (cadr scale))
+ (inexact->exact (round (/ (* z (car scale)) (cadr scale))))))
+diff -c slib/comlist.scm nlib/comlist.scm
+*** slib/comlist.scm Wed Jan 27 11:08:44 1993
+--- nlib/comlist.scm Tue Feb 9 00:21:08 1993
+***************
+*** 6,11 ****
+--- 6,14 ----
+
+ ;;;; LIST FUNCTIONS FROM COMMON LISP
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
+ ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
+ (define (make-list k . init)
+ (set! init (if (pair? init) (car init)))
+***************
+*** 13,21 ****
+ (result '() (cons init result)))
+ ((<= k 0) result)))
+
+! (define (copy-list lst) (append lst '()))
+
+! (define (adjoin e l) (if (memq e l) l (cons e l)))
+
+ (define (union l1 l2)
+ (cond ((null? l1) l2)
+--- 16,24 ----
+ (result '() (cons init result)))
+ ((<= k 0) result)))
+
+! (define-integrable (copy-list lst) (append lst '()))
+
+! (define-integrable (adjoin e l) (if (memq e l) l (cons e l)))
+
+ (define (union l1 l2)
+ (cond ((null? l1) l2)
+***************
+*** 33,39 ****
+ ((memv (car l1) l2) (set-difference (cdr l1) l2))
+ (else (cons (car l1) (set-difference (cdr l1) l2)))))
+
+! (define (position obj lst)
+ (letrec ((pos (lambda (n lst)
+ (cond ((null? lst) #f)
+ ((eqv? obj (car lst)) n)
+--- 36,42 ----
+ ((memv (car l1) l2) (set-difference (cdr l1) l2))
+ (else (cons (car l1) (set-difference (cdr l1) l2)))))
+
+! (define-integrable (position obj lst)
+ (letrec ((pos (lambda (n lst)
+ (cond ((null? lst) #f)
+ ((eqv? obj (car lst)) n)
+***************
+*** 45,51 ****
+ init
+ (reduce-init p (p init (car l)) (cdr l))))
+
+! (define (reduce p l)
+ (cond ((null? l) l)
+ ((null? (cdr l)) (car l))
+ (else (reduce-init p (car l) (cdr l)))))
+--- 48,54 ----
+ init
+ (reduce-init p (p init (car l)) (cdr l))))
+
+! (define-integrable (reduce p l)
+ (cond ((null? l) l)
+ ((null? (cdr l)) (car l))
+ (else (reduce-init p (car l) (cdr l)))))
+***************
+*** 58,64 ****
+ (or (null? l)
+ (and (pred (car l)) (every pred (cdr l)))))
+
+! (define (notevery pred l) (not (every pred l)))
+
+ (define (find-if t l)
+ (cond ((null? l) #f)
+--- 61,67 ----
+ (or (null? l)
+ (and (pred (car l)) (every pred (cdr l)))))
+
+! (define-integrable (notevery pred l) (not (every pred l)))
+
+ (define (find-if t l)
+ (cond ((null? l) #f)
+***************
+*** 121,141 ****
+ (define (nthcdr n lst)
+ (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst))))
+
+! (define (last lst n)
+ (nthcdr (- (length lst) n) lst))
+
+ ;;;; CONDITIONALS
+
+! (define (and? . args)
+ (cond ((null? args) #t)
+ ((car args) (apply and? (cdr args)))
+ (else #f)))
+
+! (define (or? . args)
+ (cond ((null? args) #f)
+ ((car args) #t)
+ (else (apply or? (cdr args)))))
+
+! (define (identity x) x)
+
+ (require 'rev3-procedures)
+--- 124,144 ----
+ (define (nthcdr n lst)
+ (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst))))
+
+! (define-integrable (last lst n)
+ (nthcdr (- (length lst) n) lst))
+
+ ;;;; CONDITIONALS
+
+! (define-integrable (and? . args)
+ (cond ((null? args) #t)
+ ((car args) (apply and? (cdr args)))
+ (else #f)))
+
+! (define-integrable (or? . args)
+ (cond ((null? args) #f)
+ ((car args) #t)
+ (else (apply or? (cdr args)))))
+
+! (define-integrable (identity x) x)
+
+ (require 'rev3-procedures)
+diff -c slib/dynamic.scm nlib/dynamic.scm
+*** slib/dynamic.scm Thu Sep 17 23:35:46 1992
+--- nlib/dynamic.scm Tue Feb 9 00:21:08 1993
+***************
+*** 31,36 ****
+--- 31,43 ----
+ ;
+ ;There was also a DYNAMIC-BIND macro which I haven't implemented.
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
++ (declare (integrate-external "record"))
++ (declare (integrate-external "dynwind"))
++ (declare (integrate dynamic:errmsg))
++
+ (require 'record)
+ (require 'dynamic-wind)
+
+***************
+*** 48,60 ****
+ (record-accessor dynamic-environment-rtd 'parent))
+
+ (define *current-dynamic-environment* #f)
+! (define (extend-current-dynamic-environment dynamic obj)
+ (set! *current-dynamic-environment*
+ (make-dynamic-environment dynamic obj
+ *current-dynamic-environment*)))
+
+ (define dynamic-rtd (make-record-type "dynamic" '()))
+! (define make-dynamic
+ (let ((dynamic-constructor (record-constructor dynamic-rtd)))
+ (lambda (obj)
+ (let ((dynamic (dynamic-constructor)))
+--- 55,69 ----
+ (record-accessor dynamic-environment-rtd 'parent))
+
+ (define *current-dynamic-environment* #f)
+!
+! (define-integrable (extend-current-dynamic-environment dynamic obj)
+ (set! *current-dynamic-environment*
+ (make-dynamic-environment dynamic obj
+ *current-dynamic-environment*)))
+
+ (define dynamic-rtd (make-record-type "dynamic" '()))
+!
+! (define-integrable make-dynamic
+ (let ((dynamic-constructor (record-constructor dynamic-rtd)))
+ (lambda (obj)
+ (let ((dynamic (dynamic-constructor)))
+***************
+*** 61,68 ****
+ (extend-current-dynamic-environment dynamic obj)
+ dynamic))))
+
+! (define dynamic? (record-predicate dynamic-rtd))
+! (define (guarantee-dynamic dynamic)
+ (or (dynamic? dynamic)
+ (slib:error "Not a dynamic" dynamic)))
+
+--- 70,78 ----
+ (extend-current-dynamic-environment dynamic obj)
+ dynamic))))
+
+! (define-integrable dynamic? (record-predicate dynamic-rtd))
+!
+! (define-integrable (guarantee-dynamic dynamic)
+ (or (dynamic? dynamic)
+ (slib:error "Not a dynamic" dynamic)))
+
+***************
+*** 69,75 ****
+ (define dynamic:errmsg
+ "No value defined for this dynamic in the current dynamic environment")
+
+! (define (dynamic-ref dynamic)
+ (guarantee-dynamic dynamic)
+ (let loop ((env *current-dynamic-environment*))
+ (cond ((not env)
+--- 79,85 ----
+ (define dynamic:errmsg
+ "No value defined for this dynamic in the current dynamic environment")
+
+! (define-integrable (dynamic-ref dynamic)
+ (guarantee-dynamic dynamic)
+ (let loop ((env *current-dynamic-environment*))
+ (cond ((not env)
+***************
+*** 79,85 ****
+ (else
+ (loop (dynamic-environment:parent env))))))
+
+! (define (dynamic-set! dynamic obj)
+ (guarantee-dynamic dynamic)
+ (let loop ((env *current-dynamic-environment*))
+ (cond ((not env)
+--- 89,95 ----
+ (else
+ (loop (dynamic-environment:parent env))))))
+
+! (define-integrable (dynamic-set! dynamic obj)
+ (guarantee-dynamic dynamic)
+ (let loop ((env *current-dynamic-environment*))
+ (cond ((not env)
+diff -c slib/format.scm nlib/format.scm
+*** slib/format.scm Tue Jan 5 14:56:48 1993
+--- nlib/format.scm Tue Feb 9 00:21:09 1993
+***************
+*** 78,84 ****
+ ; * removed C-style padding support
+ ;
+
+! ;;; SCHEME IMPLEMENTATION DEPENDENCIES ---------------------------------------
+
+ ;; To configure the format module for your scheme system, set the variable
+ ;; format:scheme-system to one of the symbols of (slib elk any). You may add
+--- 78,88 ----
+ ; * removed C-style padding support
+ ;
+
+! ;;; SCHEME IMPLEMENTATION DEPENDENCIES
+! ;;; ---------------------------------------
+!
+! ;;; (minimal) Declarations for CScheme
+! (declare (usual-integrations))
+
+ ;; To configure the format module for your scheme system, set the variable
+ ;; format:scheme-system to one of the symbols of (slib elk any). You may add
+diff -c slib/genwrite.scm nlib/genwrite.scm
+*** slib/genwrite.scm Mon Oct 19 14:49:06 1992
+--- nlib/genwrite.scm Tue Feb 9 00:21:10 1993
+***************
+*** 26,31 ****
+--- 26,34 ----
+ ;
+ ; where display-string = (lambda (s) (for-each write-char (string->list s)) #t)
+
++ ;;; (minimal) Declarations for CScheme
++ (declare (usual-integrations))
++
+ (define (generic-write obj display? width output)
+
+ (define (read-macro? l)
+diff -c slib/hash.scm nlib/hash.scm
+*** slib/hash.scm Thu Sep 10 00:05:52 1992
+--- nlib/hash.scm Tue Feb 9 00:21:10 1993
+***************
+*** 23,35 ****
+ ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =,
+ ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?.
+
+! (define (hash:hash-char char n)
+ (modulo (char->integer char) n))
+
+! (define (hash:hash-char-ci char n)
+ (modulo (char->integer (char-downcase char)) n))
+
+! (define (hash:hash-symbol sym n)
+ (hash:hash-string (symbol->string sym) n))
+
+ ;;; I am trying to be careful about overflow and underflow here.
+--- 23,40 ----
+ ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =,
+ ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?.
+
+!
+! ;;; Declarations for CScheme
+! (declare (usual-integrations))
+! (declare (integrate hash))
+!
+! (define-integrable (hash:hash-char char n)
+ (modulo (char->integer char) n))
+
+! (define-integrable (hash:hash-char-ci char n)
+ (modulo (char->integer (char-downcase char)) n))
+
+! (define-integrable (hash:hash-symbol sym n)
+ (hash:hash-string (symbol->string sym) n))
+
+ ;;; I am trying to be careful about overflow and underflow here.
+***************
+*** 173,179 ****
+
+ (define hashq hashv)
+
+! (define (predicate->hash pred)
+ (cond ((eq? pred eq?) hashq)
+ ((eq? pred eqv?) hashv)
+ ((eq? pred equal?) hash)
+--- 178,184 ----
+
+ (define hashq hashv)
+
+! (define-integrable (predicate->hash pred)
+ (cond ((eq? pred eq?) hashq)
+ ((eq? pred eqv?) hashv)
+ ((eq? pred equal?) hash)
+diff -c slib/hashtab.scm nlib/hashtab.scm
+*** slib/hashtab.scm Mon Oct 19 14:49:44 1992
+--- nlib/hashtab.scm Tue Feb 9 00:21:11 1993
+***************
+*** 36,47 ****
+ ;Returns a procedure of 2 arguments, hashtab and key, which modifies
+ ;hashtab so that the association whose key is key removed.
+
+ (require 'hash)
+ (require 'alist)
+
+! (define (make-hash-table k) (make-vector k '()))
+
+! (define (predicate->hash-asso pred)
+ (let ((hashfun (predicate->hash pred))
+ (asso (predicate->asso pred)))
+ (lambda (key hashtab)
+--- 36,53 ----
+ ;Returns a procedure of 2 arguments, hashtab and key, which modifies
+ ;hashtab so that the association whose key is key removed.
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
++ (declare (integrate-external "hash"))
++ (declare (integrate-external "alist"))
++
+ (require 'hash)
+ (require 'alist)
+
+! (define-integrable (make-hash-table k) (make-vector k '()))
+
+! (define-integrable (predicate->hash-asso pred)
+ (let ((hashfun (predicate->hash pred))
+ (asso (predicate->asso pred)))
+ (lambda (key hashtab)
+***************
+*** 48,54 ****
+ (asso key
+ (vector-ref hashtab (hashfun key (vector-length hashtab)))))))
+
+! (define (hash-inquirer pred)
+ (let ((hashfun (predicate->hash pred))
+ (ainq (alist-inquirer pred)))
+ (lambda (hashtab key)
+--- 54,60 ----
+ (asso key
+ (vector-ref hashtab (hashfun key (vector-length hashtab)))))))
+
+! (define-integrable (hash-inquirer pred)
+ (let ((hashfun (predicate->hash pred))
+ (ainq (alist-inquirer pred)))
+ (lambda (hashtab key)
+***************
+*** 55,61 ****
+ (ainq (vector-ref hashtab (hashfun key (vector-length hashtab)))
+ key))))
+
+! (define (hash-associator pred)
+ (let ((hashfun (predicate->hash pred))
+ (asso (alist-associator pred)))
+ (lambda (hashtab key val)
+--- 61,67 ----
+ (ainq (vector-ref hashtab (hashfun key (vector-length hashtab)))
+ key))))
+
+! (define-integrable (hash-associator pred)
+ (let ((hashfun (predicate->hash pred))
+ (asso (alist-associator pred)))
+ (lambda (hashtab key val)
+***************
+*** 64,70 ****
+ (asso (vector-ref hashtab num) key val)))
+ hashtab)))
+
+! (define (hash-remover pred)
+ (let ((hashfun (predicate->hash pred))
+ (arem (alist-remover pred)))
+ (lambda (hashtab key)
+--- 70,76 ----
+ (asso (vector-ref hashtab num) key val)))
+ hashtab)))
+
+! (define-integrable (hash-remover pred)
+ (let ((hashfun (predicate->hash pred))
+ (arem (alist-remover pred)))
+ (lambda (hashtab key)
+diff -c slib/lineio.scm nlib/lineio.scm
+*** slib/lineio.scm Sun Oct 25 01:40:38 1992
+--- nlib/lineio.scm Tue Feb 9 00:21:11 1993
+***************
+*** 28,33 ****
+--- 28,36 ----
+ ;unspecified value. Port may be ommited, in which case it defaults to
+ ;the value returned by current-input-port.
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
+ (define (read-line . arg)
+ (let* ((char (apply read-char arg)))
+ (if (eof-object? char)
+***************
+*** 56,61 ****
+ (+ 1 i) #f))))
+ (string-set! str i char)))))
+
+! (define (write-line str . arg)
+ (apply display str arg)
+ (apply newline arg))
+--- 59,64 ----
+ (+ 1 i) #f))))
+ (string-set! str i char)))))
+
+! (define-integrable (write-line str . arg)
+ (apply display str arg)
+ (apply newline arg))
+diff -c slib/logical.scm nlib/logical.scm
+*** slib/logical.scm Mon Feb 1 22:22:04 1993
+--- nlib/logical.scm Tue Feb 9 00:21:11 1993
+***************
+*** 48,53 ****
+--- 48,66 ----
+ ;
+ ;;;;------------------------------------------------------------------
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate logand ; Exported functions
++ logor
++ logxor
++ lognot
++ ash
++ logcount
++ integer-length
++ bit-extract
++ ipow-by-squaring
++ integer-expt))
++
+ (define logical:integer-expt
+ (if (provided? 'inexact)
+ expt
+***************
+*** 61,67 ****
+ (quotient k 2)
+ (if (even? k) acc (proc acc x))
+ proc))))
+-
+ (define (logical:logand n1 n2)
+ (cond ((= n1 n2) n1)
+ ((zero? n1) 0)
+--- 74,79 ----
+***************
+*** 90,102 ****
+ (vector-ref (vector-ref logical:boole-xor (modulo n1 16))
+ (modulo n2 16))))))
+
+! (define (logical:lognot n) (- -1 n))
+
+! (define (logical:bit-extract n start end)
+ (logical:logand (- (logical:integer-expt 2 (- end start)) 1)
+ (logical:ash n (- start))))
+
+! (define (logical:ash int cnt)
+ (if (negative? cnt)
+ (let ((n (logical:integer-expt 2 (- cnt))))
+ (if (negative? int)
+--- 102,114 ----
+ (vector-ref (vector-ref logical:boole-xor (modulo n1 16))
+ (modulo n2 16))))))
+
+! (define-integrable (logical:lognot n) (- -1 n))
+
+! (define-integrable (logical:bit-extract n start end)
+ (logical:logand (- (logical:integer-expt 2 (- end start)) 1)
+ (logical:ash n (- start))))
+
+! (define-integrable (logical:ash int cnt)
+ (if (negative? cnt)
+ (let ((n (logical:integer-expt 2 (- cnt))))
+ (if (negative? int)
+***************
+*** 104,110 ****
+ (quotient int n)))
+ (* (logical:integer-expt 2 cnt) int)))
+
+! (define (logical:ash-4 x)
+ (if (negative? x)
+ (+ -1 (quotient (+ 1 x) 16))
+ (quotient x 16)))
+--- 116,122 ----
+ (quotient int n)))
+ (* (logical:integer-expt 2 cnt) int)))
+
+! (define-integrable (logical:ash-4 x)
+ (if (negative? x)
+ (+ -1 (quotient (+ 1 x) 16))
+ (quotient x 16)))
+diff -c slib/mitscheme.init nlib/mitscheme.init
+*** slib/mitscheme.init Fri Jan 22 00:52:04 1993
+--- nlib/mitscheme.init Tue Feb 9 00:21:12 1993
+***************
+*** 48,55 ****
+
+ ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
+ ;;; use this definition if your system doesn't have such a procedure.
+! ;(define (force-output . arg) #t)
+! (define force-output flush-output)
+
+ ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
+ ;;; be returned by CHAR->INTEGER. It is defined by MITScheme.
+--- 47,54 ----
+
+ ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
+ ;;; use this definition if your system doesn't have such a procedure.
+! (define (force-output . arg) #t)
+! ;(define force-output flush-output)
+
+ ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
+ ;;; be returned by CHAR->INTEGER. It is defined by MITScheme.
+diff -c slib/modular.scm nlib/modular.scm
+*** slib/modular.scm Sun Feb 2 12:53:26 1992
+--- nlib/modular.scm Tue Feb 9 00:21:13 1993
+***************
+*** 36,41 ****
+--- 36,48 ----
+ ;Returns (k2 ^ k3) mod k1.
+ ;
+ ;;;;--------------------------------------------------------------
++
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
++ (declare (integrate-external "logical"))
++ (declare (integrate modular:negate extended-euclid))
++
+ (require 'logical)
+
+ ;;; from:
+***************
+*** 51,57 ****
+ (caddr res)
+ (- (cadr res) (* (quotient a b) (caddr res)))))))
+
+! (define (modular:invert m a)
+ (let ((d (modular:extended-euclid a m)))
+ (if (= 1 (car d))
+ (modulo (cadr d) m)
+--- 58,64 ----
+ (caddr res)
+ (- (cadr res) (* (quotient a b) (caddr res)))))))
+
+! (define-integrable (modular:invert m a)
+ (let ((d (modular:extended-euclid a m)))
+ (if (= 1 (car d))
+ (modulo (cadr d) m)
+***************
+*** 59,67 ****
+
+ (define modular:negate -)
+
+! (define (modular:+ m a b) (modulo (+ (- a m) b) m))
+
+! (define (modular:- m a b) (modulo (- a b) m))
+
+ ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+ ;;; with Splitting Facilities." ACM Transactions on Mathematical
+--- 66,74 ----
+
+ (define modular:negate -)
+
+! (define-integrable (modular:+ m a b) (modulo (+ (- a m) b) m))
+
+! (define-integrable (modular:- m a b) (modulo (- a b) m))
+
+ ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package
+ ;;; with Splitting Facilities." ACM Transactions on Mathematical
+***************
+*** 98,104 ****
+ (modulo (+ (if (positive? p) (- p m) p)
+ (* a0 (modulo b q))) m)))))
+
+! (define (modular:expt m a b)
+ (cond ((= a 1) 1)
+ ((= a (- m 1)) (if (odd? b) a 1))
+ ((zero? a) 0)
+--- 105,111 ----
+ (modulo (+ (if (positive? p) (- p m) p)
+ (* a0 (modulo b q))) m)))))
+
+! (define-integrable (modular:expt m a b)
+ (cond ((= a 1) 1)
+ ((= a (- m 1)) (if (odd? b) a 1))
+ ((zero? a) 0)
+diff -c slib/obj2str.scm nlib/obj2str.scm
+*** slib/obj2str.scm Mon Oct 19 14:49:08 1992
+--- nlib/obj2str.scm Tue Feb 9 00:21:13 1993
+***************
+*** 2,13 ****
+
+ (require 'generic-write)
+
+ ; (object->string obj) returns the textual representation of 'obj' as a
+ ; string.
+ ;
+ ; Note: (write obj) = (display (object->string obj))
+
+! (define (object->string obj)
+ (let ((result '()))
+ (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t))
+ (reverse-string-append result)))
+--- 2,17 ----
+
+ (require 'generic-write)
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate-external "genwrite"))
++
+ ; (object->string obj) returns the textual representation of 'obj' as a
+ ; string.
+ ;
+ ; Note: (write obj) = (display (object->string obj))
+
+! (define-integrable (object->string obj)
+ (let ((result '()))
+ (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t))
+ (reverse-string-append result)))
+diff -c slib/pp2str.scm nlib/pp2str.scm
+*** slib/pp2str.scm Mon Oct 19 14:49:08 1992
+--- nlib/pp2str.scm Tue Feb 9 00:21:13 1993
+***************
+*** 2,11 ****
+
+ (require 'generic-write)
+
+ ; (pretty-print-to-string obj) returns a string with the pretty-printed
+ ; textual representation of 'obj'.
+
+! (define (pp:pretty-print-to-string obj)
+ (let ((result '()))
+ (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t))
+ (reverse-string-append result)))
+--- 2,16 ----
+
+ (require 'generic-write)
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate-external "genwrite"))
++ (declare (integrate pretty-print-to-string))
++
+ ; (pretty-print-to-string obj) returns a string with the pretty-printed
+ ; textual representation of 'obj'.
+
+! (define-integrable (pp:pretty-print-to-string obj)
+ (let ((result '()))
+ (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t))
+ (reverse-string-append result)))
+diff -c slib/ppfile.scm nlib/ppfile.scm
+*** slib/ppfile.scm Mon Oct 19 14:49:08 1992
+--- nlib/ppfile.scm Tue Feb 9 00:21:14 1993
+***************
+*** 10,15 ****
+--- 10,19 ----
+ ;
+ (require 'pretty-print)
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate-external "pp"))
++
+ (define (pprint-file ifile . optarg)
+ (let ((lst (call-with-input-file ifile
+ (lambda (iport)
+diff -c slib/prime.scm nlib/prime.scm
+*** slib/prime.scm Mon Feb 8 20:49:46 1993
+--- nlib/prime.scm Tue Feb 9 00:24:16 1993
+***************
+*** 24,29 ****
+--- 24,39 ----
+ ;(sort! (factor k) <)
+
+ ;;;;--------------------------------------------------------------
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate-external "random"))
++ (declare (integrate-external "modular"))
++ (declare (integrate
++ jacobi-symbol
++ prime?
++ factor))
++
++
+ (require 'random)
+ (require 'modular)
+
+***************
+*** 56,62 ****
+ ;;; choosing prime:trials=30 should be enough
+ (define prime:trials 30)
+ ;;; prime:product is a product of small primes.
+! (define prime:product
+ (let ((p 210))
+ (for-each (lambda (s) (set! p (or (string->number s) p)))
+ '("2310" "30030" "510510" "9699690" "223092870"
+--- 66,72 ----
+ ;;; choosing prime:trials=30 should be enough
+ (define prime:trials 30)
+ ;;; prime:product is a product of small primes.
+! (define-integrable prime:product
+ (let ((p 210))
+ (for-each (lambda (s) (set! p (or (string->number s) p)))
+ '("2310" "30030" "510510" "9699690" "223092870"
+***************
+*** 86,92 ****
+ ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even
+
+ ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m.
+!
+ ;It may be illuminating to consider the relation of the Lankinen function in
+ ;a `computational hierarchy' of other factoring functions.* Assumptions are
+ ;made herein on the basis of conventional digital (binary) computers. Also,
+--- 96,102 ----
+ ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even
+
+ ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m.
+!
+ ;It may be illuminating to consider the relation of the Lankinen function in
+ ;a `computational hierarchy' of other factoring functions.* Assumptions are
+ ;made herein on the basis of conventional digital (binary) computers. Also,
+***************
+*** 94,100 ****
+ ;be factored is prime). However, all algorithms would probably perform to
+ ;the same constant multiple of the given orders for complete composite
+ ;factorizations.
+!
+ ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and
+ ; O(n*log2(n)) in space.
+ ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime
+--- 104,110 ----
+ ;be factored is prime). However, all algorithms would probably perform to
+ ;the same constant multiple of the given orders for complete composite
+ ;factorizations.
+!
+ ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and
+ ; O(n*log2(n)) in space.
+ ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime
+diff -c slib/priorque.scm nlib/priorque.scm
+*** slib/priorque.scm Mon Oct 19 14:49:42 1992
+--- nlib/priorque.scm Tue Feb 9 00:21:15 1993
+***************
+*** 22,41 ****
+ ;;; 1989 MIT Press.
+
+ (require 'record)
+ (define heap-rtd (make-record-type "heap" '(array size heap<?)))
+! (define make-heap
+ (let ((cstr (record-constructor heap-rtd)))
+ (lambda (pred<?)
+ (cstr (make-vector 4) 0 pred<?))))
+! (define heap-ref
+ (let ((ra (record-accessor heap-rtd 'array)))
+ (lambda (a i)
+ (vector-ref (ra a) (+ -1 i)))))
+! (define heap-set!
+ (let ((ra (record-accessor heap-rtd 'array)))
+ (lambda (a i v)
+ (vector-set! (ra a) (+ -1 i) v))))
+! (define heap-exchange
+ (let ((aa (record-accessor heap-rtd 'array)))
+ (lambda (a i j)
+ (set! i (+ -1 i))
+--- 22,53 ----
+ ;;; 1989 MIT Press.
+
+ (require 'record)
++
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
++ (declare (integrate
++ heap-size
++ heap<?))
++
+ (define heap-rtd (make-record-type "heap" '(array size heap<?)))
+!
+! (define-integrable make-heap
+ (let ((cstr (record-constructor heap-rtd)))
+ (lambda (pred<?)
+ (cstr (make-vector 4) 0 pred<?))))
+!
+! (define-integrable heap-ref
+ (let ((ra (record-accessor heap-rtd 'array)))
+ (lambda (a i)
+ (vector-ref (ra a) (+ -1 i)))))
+!
+! (define-integrable heap-set!
+ (let ((ra (record-accessor heap-rtd 'array)))
+ (lambda (a i v)
+ (vector-set! (ra a) (+ -1 i) v))))
+!
+! (define-integrable heap-exchange
+ (let ((aa (record-accessor heap-rtd 'array)))
+ (lambda (a i j)
+ (set! i (+ -1 i))
+***************
+*** 44,51 ****
+--- 56,66 ----
+ (tmp (vector-ref ra i)))
+ (vector-set! ra i (vector-ref ra j))
+ (vector-set! ra j tmp)))))
++
+ (define heap-size (record-accessor heap-rtd 'size))
++
+ (define heap<? (record-accessor heap-rtd 'heap<?))
++
+ (define heap-set-size
+ (let ((aa (record-accessor heap-rtd 'array))
+ (am (record-modifier heap-rtd 'array))
+***************
+*** 59,68 ****
+ (vector-set! nra i (vector-ref ra i)))))
+ (sm a s)))))
+
+! (define (heap-parent i) (quotient i 2))
+! (define (heap-left i) (* 2 i))
+! (define (heap-right i) (+ 1 (* 2 i)))
+
+ (define (heapify a i)
+ (define l (heap-left i))
+ (define r (heap-right i))
+--- 74,85 ----
+ (vector-set! nra i (vector-ref ra i)))))
+ (sm a s)))))
+
+! (define-integrable (heap-parent i) (quotient i 2))
+
++ (define-integrable (heap-left i) (* 2 i))
++
++ (define-integrable (heap-right i) (+ 1 (* 2 i)))
++
+ (define (heapify a i)
+ (define l (heap-left i))
+ (define r (heap-right i))
+***************
+*** 99,104 ****
+--- 116,122 ----
+ max))
+
+ (define heap #f)
++
+ (define (heap-test)
+ (set! heap (make-heap char>?))
+ (heap-insert! heap #\A)
+diff -c slib/process.scm nlib/process.scm
+*** slib/process.scm Wed Nov 4 12:26:50 1992
+--- nlib/process.scm Tue Feb 9 00:21:15 1993
+***************
+*** 21,30 ****
+ ;
+ ;;;;----------------------------------------------------------------------
+
+ (require 'full-continuation)
+ (require 'queue)
+
+! (define (add-process! thunk1)
+ (cond ((procedure? thunk1)
+ (defer-ints)
+ (enqueue! process:queue thunk1)
+--- 21,33 ----
+ ;
+ ;;;;----------------------------------------------------------------------
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
+ (require 'full-continuation)
+ (require 'queue)
+
+! (define-integrable (add-process! thunk1)
+ (cond ((procedure? thunk1)
+ (defer-ints)
+ (enqueue! process:queue thunk1)
+***************
+*** 55,63 ****
+ (define ints-disabled #f)
+ (define alarm-deferred #f)
+
+! (define (defer-ints) (set! ints-disabled #t))
+
+! (define (allow-ints)
+ (set! ints-disabled #f)
+ (cond (alarm-deferred
+ (set! alarm-deferred #f)
+--- 58,66 ----
+ (define ints-disabled #f)
+ (define alarm-deferred #f)
+
+! (define-integrable (defer-ints) (set! ints-disabled #t))
+
+! (define-integrable (allow-ints)
+ (set! ints-disabled #f)
+ (cond (alarm-deferred
+ (set! alarm-deferred #f)
+***************
+*** 66,72 ****
+ ;;; Make THE process queue.
+ (define process:queue (make-queue))
+
+! (define (alarm-interrupt)
+ (alarm 1)
+ (if ints-disabled (set! alarm-deferred #t)
+ (process:schedule!)))
+--- 69,75 ----
+ ;;; Make THE process queue.
+ (define process:queue (make-queue))
+
+! (define-integrable (alarm-interrupt)
+ (alarm 1)
+ (if ints-disabled (set! alarm-deferred #t)
+ (process:schedule!)))
+diff -c slib/randinex.scm nlib/randinex.scm
+*** slib/randinex.scm Wed Nov 18 22:59:20 1992
+--- nlib/randinex.scm Tue Feb 9 00:21:16 1993
+***************
+*** 47,52 ****
+--- 47,59 ----
+ ;For an exponential distribution with mean U use (* U (random:exp)).
+ ;;;;-----------------------------------------------------------------
+
++
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate-external "random"))
++ (declare (integrate
++ random:float-radix))
++
+ (define random:float-radix
+ (+ 1 (exact->inexact random:MASK)))
+
+***************
+*** 56,61 ****
+--- 63,69 ----
+ (if (= 1.0 (+ 1 x))
+ l
+ (random:size-float (+ l 1) (/ x random:float-radix))))
++
+ (define random:chunks/float (random:size-float 1 1.0))
+
+ (define (random:uniform-chunk n state)
+***************
+*** 67,73 ****
+ random:float-radix)))
+
+ ;;; Generate an inexact real between 0 and 1.
+! (define (random:uniform state)
+ (random:uniform-chunk random:chunks/float state))
+
+ ;;; If x and y are independent standard normal variables, then with
+--- 75,81 ----
+ random:float-radix)))
+
+ ;;; Generate an inexact real between 0 and 1.
+! (define-integrable (random:uniform state)
+ (random:uniform-chunk random:chunks/float state))
+
+ ;;; If x and y are independent standard normal variables, then with
+***************
+*** 89,95 ****
+ (do! n (* r (cos t)))
+ (if (positive? n) (do! (- n 1) (* r (sin t)))))))))
+
+! (define random:normal
+ (let ((vect (make-vector 1)))
+ (lambda args
+ (apply random:normal-vector! vect args)
+--- 97,103 ----
+ (do! n (* r (cos t)))
+ (if (positive? n) (do! (- n 1) (* r (sin t)))))))))
+
+! (define-integrable random:normal
+ (let ((vect (make-vector 1)))
+ (lambda args
+ (apply random:normal-vector! vect args)
+***************
+*** 98,104 ****
+ ;;; For the uniform distibution on the hollow sphere, pick a normal
+ ;;; family and scale.
+
+! (define (random:hollow-sphere! vect . args)
+ (let ((ms (sqrt (apply random:normal-vector! vect args))))
+ (do ((n (- (vector-length vect) 1) (- n 1)))
+ ((negative? n))
+--- 106,112 ----
+ ;;; For the uniform distibution on the hollow sphere, pick a normal
+ ;;; family and scale.
+
+! (define-integrable (random:hollow-sphere! vect . args)
+ (let ((ms (sqrt (apply random:normal-vector! vect args))))
+ (do ((n (- (vector-length vect) 1) (- n 1)))
+ ((negative? n))
+***************
+*** 117,123 ****
+ ((negative? n))
+ (vector-set! vect n (* r (vector-ref vect n))))))
+
+! (define (random:exp . args)
+ (let ((state (if (null? args) *random-state* (car args))))
+ (- (log (random:uniform state)))))
+
+--- 125,131 ----
+ ((negative? n))
+ (vector-set! vect n (* r (vector-ref vect n))))))
+
+! (define-integrable (random:exp . args)
+ (let ((state (if (null? args) *random-state* (car args))))
+ (- (log (random:uniform state)))))
+
+diff -c slib/random.scm nlib/random.scm
+*** slib/random.scm Tue Feb 2 00:02:58 1993
+--- nlib/random.scm Tue Feb 9 00:21:18 1993
+***************
+*** 35,40 ****
+--- 35,50 ----
+ ;procedures for generating inexact distributions.
+ ;;;;------------------------------------------------------------------
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate-external "logical"))
++ (declare (integrateb
++ random:tap-1
++ random:size
++ random:chunk-size
++ random:MASK
++ random))
++
+ (require 'logical)
+
+ (define random:tap 24)
+***************
+*** 45,50 ****
+--- 55,61 ----
+ (if (and (exact? trial) (>= most-positive-fixnum trial))
+ l
+ (random:size-int (- l 1)))))
++
+ (define random:chunk-size (* 4 (random:size-int 8)))
+
+ (define random:MASK
+***************
+*** 107,113 ****
+ ;;;random:uniform is in randinex.scm. It is needed only if inexact is
+ ;;;supported.
+
+! (define (random:make-random-state . args)
+ (let ((state (if (null? args) *random-state* (car args))))
+ (list->vector (vector->list state))))
+
+--- 118,124 ----
+ ;;;random:uniform is in randinex.scm. It is needed only if inexact is
+ ;;;supported.
+
+! (define-integrable (random:make-random-state . args)
+ (let ((state (if (null? args) *random-state* (car args))))
+ (list->vector (vector->list state))))
+
+diff -c slib/rbtree.scm nlib/rbtree.scm
+*** slib/rbtree.scm Sat Jan 9 13:40:56 1993
+--- nlib/rbtree.scm Tue Feb 9 00:21:18 1993
+***************
+*** 5,11 ****
+--- 5,24 ----
+ ;;;; PGS, 6 Jul 1990
+ ;;; jaffer@ai.mit.edu Ported to SLIB, 1/6/93
+
++
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++ (declare (integrate
++ rb-tree-root
++ set-rb-tree-root!
++ rb-tree-left-rotation-field-maintainer
++ rb-tree-right-rotation-field-maintainer
++ rb-tree-insertion-field-maintainer
++ rb-tree-deletion-field-maintainer
++ rb-tree-prior?))
++
+ (require 'record)
++
+ (define rb-tree
+ (make-record-type
+ "rb-tree"
+***************
+*** 227,233 ****
+ y)
+ (set! x y)
+ (set! y (rb-node-parent y)))))
+-
+
+ ;;;; Deletion. We do not entirely follow Cormen, Leiserson and Rivest's lead
+ ;;;; here, because their use of sentinels is in rather obscenely poor taste.
+--- 240,245 ----
+diff -c slib/sort.scm nlib/sort.scm
+*** slib/sort.scm Wed Nov 6 00:50:38 1991
+--- nlib/sort.scm Tue Feb 9 00:22:03 1993
+***************
+*** 118,123 ****
+--- 118,125 ----
+ ; in Scheme.
+ ;;; --------------------------------------------------------------------
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations)) ; Honestly, nothing defined here clashes!
+
+ ;;; (sorted? sequence less?)
+ ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
+diff -c slib/printf.scm nlib/printf.scm
+*** slib/printf.scm Mon Oct 19 14:48:58 1992
+--- nlib/printf.scm Tue Feb 9 00:22:03 1993
+***************
+*** 3,8 ****
+--- 3,19 ----
+
+ ;;; Floating point is not handled yet. It should not be hard to do.
+
++ ;;; Declarations for CScheme
++ (declare (usual-integrations))
++
++ (declare (integrate
++ printf
++ fprintf
++ sprintf
++ stdin
++ stdout
++ stderr))
++
+ (define (stdio:iprintf out format . args)
+ (let loop ((pos 0) (args args))
+ (if (< pos (string-length format))
+***************
+*** 96,105 ****
+ (else (out (string-ref format pos))
+ (loop (+ pos 1) args))))))
+
+! (define (stdio:printf format . args)
+ (apply stdio:iprintf display format args))
+
+! (define (stdio:fprintf port format . args)
+ (if (equal? port (current-output-port))
+ (apply stdio:iprintf display format args)
+ (apply stdio:iprintf (lambda (x) (display x port)) format args)))
+--- 107,116 ----
+ (else (out (string-ref format pos))
+ (loop (+ pos 1) args))))))
+
+! (define-integrable (stdio:printf format . args)
+ (apply stdio:iprintf display format args))
+
+! (define-integrable (stdio:fprintf port format . args)
+ (if (equal? port (current-output-port))
+ (apply stdio:iprintf display format args)
+ (apply stdio:iprintf (lambda (x) (display x port)) format args)))
+diff -c slib/strcase.scm nlib/strcase.scm
+*** slib/strcase.scm Wed Nov 18 14:15:18 1992
+--- nlib/strcase.scm Tue Feb 9 00:22:03 1993
+***************
+*** 8,27 ****
+ ;string-upcase!, string-downcase!, string-capitalize!
+ ; are destructive versions.
+
+! (define (string-upcase! str)
+ (do ((i (- (string-length str) 1) (- i 1)))
+ ((< i 0) str)
+ (string-set! str i (char-upcase (string-ref str i)))))
+
+! (define (string-upcase str)
+ (string-upcase! (string-copy str)))
+
+! (define (string-downcase! str)
+ (do ((i (- (string-length str) 1) (- i 1)))
+ ((< i 0) str)
+ (string-set! str i (char-downcase (string-ref str i)))))
+
+! (define (string-downcase str)
+ (string-downcase! (string-copy str)))
+
+ (define (string-capitalize! str) ; "hello" -> "Hello"
+--- 8,30 ----
+ ;string-upcase!, string-downcase!, string-capitalize!
+ ; are destructive versions.
+
+! ;;; Declarations for CScheme
+! (declare (usual-integrations))
+!
+! (define-integrable (string-upcase! str)
+ (do ((i (- (string-length str) 1) (- i 1)))
+ ((< i 0) str)
+ (string-set! str i (char-upcase (string-ref str i)))))
+
+! (define-integrable (string-upcase str)
+ (string-upcase! (string-copy str)))
+
+! (define-integrable (string-downcase! str)
+ (do ((i (- (string-length str) 1) (- i 1)))
+ ((< i 0) str)
+ (string-set! str i (char-downcase (string-ref str i)))))
+
+! (define-integrable (string-downcase str)
+ (string-downcase! (string-copy str)))
+
+ (define (string-capitalize! str) ; "hello" -> "Hello"
+***************
+*** 38,42 ****
+ (string-set! str i (char-upcase c))))
+ (set! non-first-alpha #f))))))
+
+! (define (string-capitalize str)
+ (string-capitalize! (string-copy str)))
+--- 41,45 ----
+ (string-set! str i (char-upcase c))))
+ (set! non-first-alpha #f))))))
+
+! (define-integrable (string-capitalize str)
+ (string-capitalize! (string-copy str)))
+diff -c slib/synchk.scm nlib/synchk.scm
+*** slib/synchk.scm Mon Jan 27 09:28:48 1992
+--- nlib/synchk.scm Tue Feb 9 00:22:03 1993
+***************
+*** 35,45 ****
+ ;;; written by Alan Bawden
+ ;;; modified by Chris Hanson
+
+! (define (syntax-check pattern form)
+ (if (not (syntax-match? (cdr pattern) (cdr form)))
+ (syntax-error "ill-formed special form" form)))
+
+! (define (ill-formed-syntax form)
+ (syntax-error "ill-formed special form" form))
+
+ (define (syntax-match? pattern object)
+--- 35,48 ----
+ ;;; written by Alan Bawden
+ ;;; modified by Chris Hanson
+
+! ;;; Declarations for CScheme
+! (declare (usual-integrations))
+!
+! (define-integrable (syntax-check pattern form)
+ (if (not (syntax-match? (cdr pattern) (cdr form)))
+ (syntax-error "ill-formed special form" form)))
+
+! (define-integrable (ill-formed-syntax form)
+ (syntax-error "ill-formed special form" form))
+
+ (define (syntax-match? pattern object)