mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 00:00:49 +02:00
1466 lines
42 KiB
Text
1466 lines
42 KiB
Text
;"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)
|