diff options
Diffstat (limited to 'mitcomp.pat')
| -rw-r--r-- | mitcomp.pat | 1466 |
1 files changed, 0 insertions, 1466 deletions
diff --git a/mitcomp.pat b/mitcomp.pat deleted file mode 100644 index 78cb9b9..0000000 --- a/mitcomp.pat +++ /dev/null @@ -1,1466 +0,0 @@ -;"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) |