| 1 | ;"mitcomp.pat", patch file of definitions for compiling SLIB with MitScheme. |
| 2 | ;;; Copyright (C) 1993 Matthew McDonald. |
| 3 | ; |
| 4 | ;Permission to copy this software, to redistribute it, and to use it |
| 5 | ;for any purpose is granted, subject to the following restrictions and |
| 6 | ;understandings. |
| 7 | ; |
| 8 | ;1. Any copy made of this software must include this copyright notice |
| 9 | ;in full. |
| 10 | ; |
| 11 | ;2. I have made no warrantee or representation that the operation of |
| 12 | ;this software will be error-free, and I am under no obligation to |
| 13 | ;provide any services, by way of maintenance, update, or otherwise. |
| 14 | ; |
| 15 | ;3. In conjunction with products arising from the use of this |
| 16 | ;material, there shall be no use of my name in any advertising, |
| 17 | ;promotional, or sales literature without prior written consent in |
| 18 | ;each case. |
| 19 | |
| 20 | From: mafm@cs.uwa.edu.au (Matthew MCDONALD) |
| 21 | |
| 22 | Added declarations to files providing these: |
| 23 | dynamic alist hash hash-table logical random random-inexact modular |
| 24 | prime charplot common-list-functions format generic-write pprint-file |
| 25 | pretty-print-to-string object->string string-case printf line-i/o |
| 26 | synchk priority-queue process red-black-tree sort |
| 27 | |
| 28 | (for-each cf |
| 29 | '("dynamic.scm" "alist.scm" "hash.scm" "hashtab.scm" "logical.scm" |
| 30 | "random.scm" "randinex.scm" "modular.scm" "prime.scm" "charplot.scm" |
| 31 | "comlist.scm" "format.scm" "genwrite.scm" "ppfile.scm" "pp2str.scm" |
| 32 | "obj2str.scm" "strcase.scm" "printf.scm" "lineio.scm" "synchk.scm" |
| 33 | "priorque.scm" "process.scm" "rbtree.scm" "sort.scm)) |
| 34 | |
| 35 | while in the SLIB directory will compile all of these. |
| 36 | |
| 37 | They all appear to still be working... They should be |
| 38 | everything CScheme currently uses (except [1] below.) |
| 39 | |
| 40 | NOTES: |
| 41 | |
| 42 | [1] Not altered: |
| 43 | debug Not worth optimising |
| 44 | test " " " |
| 45 | fluid-let compiler chokes over |
| 46 | (lambda () . body) |
| 47 | scmacro Fails when compiled, not immediately obvious why |
| 48 | synclo " " " |
| 49 | r4rsyn " " " |
| 50 | yasos requires the macros |
| 51 | collect " " " |
| 52 | |
| 53 | [2] removed 'sort from list of MIT features. The library version is |
| 54 | more complete (and needed for charplot.) |
| 55 | |
| 56 | [3] Remember that mitscheme.init gets the .bin put in the wrong place |
| 57 | by the compiler and thus doesn't get recognised by LOAD. |
| 58 | ====================================================================== |
| 59 | diff -c slib/alist.scm nlib/alist.scm |
| 60 | *** slib/alist.scm Thu Jan 21 00:01:34 1993 |
| 61 | --- nlib/alist.scm Tue Feb 9 00:21:07 1993 |
| 62 | *************** |
| 63 | *** 44,50 **** |
| 64 | ;(define rem (alist-remover string-ci=?)) |
| 65 | ;(set! alist (rem alist "fOO")) |
| 66 | |
| 67 | ! (define (predicate->asso pred) |
| 68 | (cond ((eq? eq? pred) assq) |
| 69 | ((eq? = pred) assv) |
| 70 | ((eq? eqv? pred) assv) |
| 71 | --- 44,53 ---- |
| 72 | ;(define rem (alist-remover string-ci=?)) |
| 73 | ;(set! alist (rem alist "fOO")) |
| 74 | |
| 75 | ! ;;; Declarations for CScheme |
| 76 | ! (declare (usual-integrations)) |
| 77 | ! |
| 78 | ! (define-integrable (predicate->asso pred) |
| 79 | (cond ((eq? eq? pred) assq) |
| 80 | ((eq? = pred) assv) |
| 81 | ((eq? eqv? pred) assv) |
| 82 | *************** |
| 83 | *** 57,69 **** |
| 84 | ((pred key (caar al)) (car al)) |
| 85 | (else (l (cdr al))))))))) |
| 86 | |
| 87 | ! (define (alist-inquirer pred) |
| 88 | (let ((assofun (predicate->asso pred))) |
| 89 | (lambda (alist key) |
| 90 | (let ((pair (assofun key alist))) |
| 91 | (and pair (cdr pair)))))) |
| 92 | |
| 93 | ! (define (alist-associator pred) |
| 94 | (let ((assofun (predicate->asso pred))) |
| 95 | (lambda (alist key val) |
| 96 | (let* ((pair (assofun key alist))) |
| 97 | --- 60,72 ---- |
| 98 | ((pred key (caar al)) (car al)) |
| 99 | (else (l (cdr al))))))))) |
| 100 | |
| 101 | ! (define-integrable (alist-inquirer pred) |
| 102 | (let ((assofun (predicate->asso pred))) |
| 103 | (lambda (alist key) |
| 104 | (let ((pair (assofun key alist))) |
| 105 | (and pair (cdr pair)))))) |
| 106 | |
| 107 | ! (define-integrable (alist-associator pred) |
| 108 | (let ((assofun (predicate->asso pred))) |
| 109 | (lambda (alist key val) |
| 110 | (let* ((pair (assofun key alist))) |
| 111 | *************** |
| 112 | *** 71,77 **** |
| 113 | alist) |
| 114 | (else (cons (cons key val) alist))))))) |
| 115 | |
| 116 | ! (define (alist-remover pred) |
| 117 | (lambda (alist key) |
| 118 | (cond ((null? alist) alist) |
| 119 | ((pred key (caar alist)) (cdr alist)) |
| 120 | --- 74,80 ---- |
| 121 | alist) |
| 122 | (else (cons (cons key val) alist))))))) |
| 123 | |
| 124 | ! (define-integrable (alist-remover pred) |
| 125 | (lambda (alist key) |
| 126 | (cond ((null? alist) alist) |
| 127 | ((pred key (caar alist)) (cdr alist)) |
| 128 | diff -c slib/charplot.scm nlib/charplot.scm |
| 129 | *** slib/charplot.scm Sat Nov 14 21:50:54 1992 |
| 130 | --- nlib/charplot.scm Tue Feb 9 00:21:07 1993 |
| 131 | *************** |
| 132 | *** 7,12 **** |
| 133 | --- 7,24 ---- |
| 134 | ;are strings with names to label the x and y axii with. |
| 135 | |
| 136 | ;;;;--------------------------------------------------------------- |
| 137 | + |
| 138 | + ;;; Declarations for CScheme |
| 139 | + (declare (usual-integrations)) |
| 140 | + (declare (integrate-external "sort")) |
| 141 | + (declare (integrate |
| 142 | + rows |
| 143 | + columns |
| 144 | + charplot:height |
| 145 | + charplot:width |
| 146 | + charplot:plot |
| 147 | + plot!)) |
| 148 | + |
| 149 | (require 'sort) |
| 150 | |
| 151 | (define rows 24) |
| 152 | *************** |
| 153 | *** 27,39 **** |
| 154 | (write-char char) |
| 155 | (charplot:printn! (+ n -1) char)))) |
| 156 | |
| 157 | ! (define (charplot:center-print! str width) |
| 158 | (let ((lpad (quotient (- width (string-length str)) 2))) |
| 159 | (charplot:printn! lpad #\ ) |
| 160 | (display str) |
| 161 | (charplot:printn! (- width (+ (string-length str) lpad)) #\ ))) |
| 162 | |
| 163 | ! (define (scale-it z scale) |
| 164 | (if (and (exact? z) (integer? z)) |
| 165 | (quotient (* z (car scale)) (cadr scale)) |
| 166 | (inexact->exact (round (/ (* z (car scale)) (cadr scale)))))) |
| 167 | --- 39,51 ---- |
| 168 | (write-char char) |
| 169 | (charplot:printn! (+ n -1) char)))) |
| 170 | |
| 171 | ! (define-integrable (charplot:center-print! str width) |
| 172 | (let ((lpad (quotient (- width (string-length str)) 2))) |
| 173 | (charplot:printn! lpad #\ ) |
| 174 | (display str) |
| 175 | (charplot:printn! (- width (+ (string-length str) lpad)) #\ ))) |
| 176 | |
| 177 | ! (define-integrable (scale-it z scale) |
| 178 | (if (and (exact? z) (integer? z)) |
| 179 | (quotient (* z (car scale)) (cadr scale)) |
| 180 | (inexact->exact (round (/ (* z (car scale)) (cadr scale)))))) |
| 181 | diff -c slib/comlist.scm nlib/comlist.scm |
| 182 | *** slib/comlist.scm Wed Jan 27 11:08:44 1993 |
| 183 | --- nlib/comlist.scm Tue Feb 9 00:21:08 1993 |
| 184 | *************** |
| 185 | *** 6,11 **** |
| 186 | --- 6,14 ---- |
| 187 | |
| 188 | ;;;; LIST FUNCTIONS FROM COMMON LISP |
| 189 | |
| 190 | + ;;; Declarations for CScheme |
| 191 | + (declare (usual-integrations)) |
| 192 | + |
| 193 | ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) |
| 194 | (define (make-list k . init) |
| 195 | (set! init (if (pair? init) (car init))) |
| 196 | *************** |
| 197 | *** 13,21 **** |
| 198 | (result '() (cons init result))) |
| 199 | ((<= k 0) result))) |
| 200 | |
| 201 | ! (define (copy-list lst) (append lst '())) |
| 202 | |
| 203 | ! (define (adjoin e l) (if (memq e l) l (cons e l))) |
| 204 | |
| 205 | (define (union l1 l2) |
| 206 | (cond ((null? l1) l2) |
| 207 | --- 16,24 ---- |
| 208 | (result '() (cons init result))) |
| 209 | ((<= k 0) result))) |
| 210 | |
| 211 | ! (define-integrable (copy-list lst) (append lst '())) |
| 212 | |
| 213 | ! (define-integrable (adjoin e l) (if (memq e l) l (cons e l))) |
| 214 | |
| 215 | (define (union l1 l2) |
| 216 | (cond ((null? l1) l2) |
| 217 | *************** |
| 218 | *** 33,39 **** |
| 219 | ((memv (car l1) l2) (set-difference (cdr l1) l2)) |
| 220 | (else (cons (car l1) (set-difference (cdr l1) l2))))) |
| 221 | |
| 222 | ! (define (position obj lst) |
| 223 | (letrec ((pos (lambda (n lst) |
| 224 | (cond ((null? lst) #f) |
| 225 | ((eqv? obj (car lst)) n) |
| 226 | --- 36,42 ---- |
| 227 | ((memv (car l1) l2) (set-difference (cdr l1) l2)) |
| 228 | (else (cons (car l1) (set-difference (cdr l1) l2))))) |
| 229 | |
| 230 | ! (define-integrable (position obj lst) |
| 231 | (letrec ((pos (lambda (n lst) |
| 232 | (cond ((null? lst) #f) |
| 233 | ((eqv? obj (car lst)) n) |
| 234 | *************** |
| 235 | *** 45,51 **** |
| 236 | init |
| 237 | (reduce-init p (p init (car l)) (cdr l)))) |
| 238 | |
| 239 | ! (define (reduce p l) |
| 240 | (cond ((null? l) l) |
| 241 | ((null? (cdr l)) (car l)) |
| 242 | (else (reduce-init p (car l) (cdr l))))) |
| 243 | --- 48,54 ---- |
| 244 | init |
| 245 | (reduce-init p (p init (car l)) (cdr l)))) |
| 246 | |
| 247 | ! (define-integrable (reduce p l) |
| 248 | (cond ((null? l) l) |
| 249 | ((null? (cdr l)) (car l)) |
| 250 | (else (reduce-init p (car l) (cdr l))))) |
| 251 | *************** |
| 252 | *** 58,64 **** |
| 253 | (or (null? l) |
| 254 | (and (pred (car l)) (every pred (cdr l))))) |
| 255 | |
| 256 | ! (define (notevery pred l) (not (every pred l))) |
| 257 | |
| 258 | (define (find-if t l) |
| 259 | (cond ((null? l) #f) |
| 260 | --- 61,67 ---- |
| 261 | (or (null? l) |
| 262 | (and (pred (car l)) (every pred (cdr l))))) |
| 263 | |
| 264 | ! (define-integrable (notevery pred l) (not (every pred l))) |
| 265 | |
| 266 | (define (find-if t l) |
| 267 | (cond ((null? l) #f) |
| 268 | *************** |
| 269 | *** 121,141 **** |
| 270 | (define (nthcdr n lst) |
| 271 | (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst)))) |
| 272 | |
| 273 | ! (define (last lst n) |
| 274 | (nthcdr (- (length lst) n) lst)) |
| 275 | |
| 276 | ;;;; CONDITIONALS |
| 277 | |
| 278 | ! (define (and? . args) |
| 279 | (cond ((null? args) #t) |
| 280 | ((car args) (apply and? (cdr args))) |
| 281 | (else #f))) |
| 282 | |
| 283 | ! (define (or? . args) |
| 284 | (cond ((null? args) #f) |
| 285 | ((car args) #t) |
| 286 | (else (apply or? (cdr args))))) |
| 287 | |
| 288 | ! (define (identity x) x) |
| 289 | |
| 290 | (require 'rev3-procedures) |
| 291 | --- 124,144 ---- |
| 292 | (define (nthcdr n lst) |
| 293 | (if (zero? n) lst (nthcdr (+ -1 n) (cdr lst)))) |
| 294 | |
| 295 | ! (define-integrable (last lst n) |
| 296 | (nthcdr (- (length lst) n) lst)) |
| 297 | |
| 298 | ;;;; CONDITIONALS |
| 299 | |
| 300 | ! (define-integrable (and? . args) |
| 301 | (cond ((null? args) #t) |
| 302 | ((car args) (apply and? (cdr args))) |
| 303 | (else #f))) |
| 304 | |
| 305 | ! (define-integrable (or? . args) |
| 306 | (cond ((null? args) #f) |
| 307 | ((car args) #t) |
| 308 | (else (apply or? (cdr args))))) |
| 309 | |
| 310 | ! (define-integrable (identity x) x) |
| 311 | |
| 312 | (require 'rev3-procedures) |
| 313 | diff -c slib/dynamic.scm nlib/dynamic.scm |
| 314 | *** slib/dynamic.scm Thu Sep 17 23:35:46 1992 |
| 315 | --- nlib/dynamic.scm Tue Feb 9 00:21:08 1993 |
| 316 | *************** |
| 317 | *** 31,36 **** |
| 318 | --- 31,43 ---- |
| 319 | ; |
| 320 | ;There was also a DYNAMIC-BIND macro which I haven't implemented. |
| 321 | |
| 322 | + ;;; Declarations for CScheme |
| 323 | + (declare (usual-integrations)) |
| 324 | + |
| 325 | + (declare (integrate-external "record")) |
| 326 | + (declare (integrate-external "dynwind")) |
| 327 | + (declare (integrate dynamic:errmsg)) |
| 328 | + |
| 329 | (require 'record) |
| 330 | (require 'dynamic-wind) |
| 331 | |
| 332 | *************** |
| 333 | *** 48,60 **** |
| 334 | (record-accessor dynamic-environment-rtd 'parent)) |
| 335 | |
| 336 | (define *current-dynamic-environment* #f) |
| 337 | ! (define (extend-current-dynamic-environment dynamic obj) |
| 338 | (set! *current-dynamic-environment* |
| 339 | (make-dynamic-environment dynamic obj |
| 340 | *current-dynamic-environment*))) |
| 341 | |
| 342 | (define dynamic-rtd (make-record-type "dynamic" '())) |
| 343 | ! (define make-dynamic |
| 344 | (let ((dynamic-constructor (record-constructor dynamic-rtd))) |
| 345 | (lambda (obj) |
| 346 | (let ((dynamic (dynamic-constructor))) |
| 347 | --- 55,69 ---- |
| 348 | (record-accessor dynamic-environment-rtd 'parent)) |
| 349 | |
| 350 | (define *current-dynamic-environment* #f) |
| 351 | ! |
| 352 | ! (define-integrable (extend-current-dynamic-environment dynamic obj) |
| 353 | (set! *current-dynamic-environment* |
| 354 | (make-dynamic-environment dynamic obj |
| 355 | *current-dynamic-environment*))) |
| 356 | |
| 357 | (define dynamic-rtd (make-record-type "dynamic" '())) |
| 358 | ! |
| 359 | ! (define-integrable make-dynamic |
| 360 | (let ((dynamic-constructor (record-constructor dynamic-rtd))) |
| 361 | (lambda (obj) |
| 362 | (let ((dynamic (dynamic-constructor))) |
| 363 | *************** |
| 364 | *** 61,68 **** |
| 365 | (extend-current-dynamic-environment dynamic obj) |
| 366 | dynamic)))) |
| 367 | |
| 368 | ! (define dynamic? (record-predicate dynamic-rtd)) |
| 369 | ! (define (guarantee-dynamic dynamic) |
| 370 | (or (dynamic? dynamic) |
| 371 | (slib:error "Not a dynamic" dynamic))) |
| 372 | |
| 373 | --- 70,78 ---- |
| 374 | (extend-current-dynamic-environment dynamic obj) |
| 375 | dynamic)))) |
| 376 | |
| 377 | ! (define-integrable dynamic? (record-predicate dynamic-rtd)) |
| 378 | ! |
| 379 | ! (define-integrable (guarantee-dynamic dynamic) |
| 380 | (or (dynamic? dynamic) |
| 381 | (slib:error "Not a dynamic" dynamic))) |
| 382 | |
| 383 | *************** |
| 384 | *** 69,75 **** |
| 385 | (define dynamic:errmsg |
| 386 | "No value defined for this dynamic in the current dynamic environment") |
| 387 | |
| 388 | ! (define (dynamic-ref dynamic) |
| 389 | (guarantee-dynamic dynamic) |
| 390 | (let loop ((env *current-dynamic-environment*)) |
| 391 | (cond ((not env) |
| 392 | --- 79,85 ---- |
| 393 | (define dynamic:errmsg |
| 394 | "No value defined for this dynamic in the current dynamic environment") |
| 395 | |
| 396 | ! (define-integrable (dynamic-ref dynamic) |
| 397 | (guarantee-dynamic dynamic) |
| 398 | (let loop ((env *current-dynamic-environment*)) |
| 399 | (cond ((not env) |
| 400 | *************** |
| 401 | *** 79,85 **** |
| 402 | (else |
| 403 | (loop (dynamic-environment:parent env)))))) |
| 404 | |
| 405 | ! (define (dynamic-set! dynamic obj) |
| 406 | (guarantee-dynamic dynamic) |
| 407 | (let loop ((env *current-dynamic-environment*)) |
| 408 | (cond ((not env) |
| 409 | --- 89,95 ---- |
| 410 | (else |
| 411 | (loop (dynamic-environment:parent env)))))) |
| 412 | |
| 413 | ! (define-integrable (dynamic-set! dynamic obj) |
| 414 | (guarantee-dynamic dynamic) |
| 415 | (let loop ((env *current-dynamic-environment*)) |
| 416 | (cond ((not env) |
| 417 | diff -c slib/format.scm nlib/format.scm |
| 418 | *** slib/format.scm Tue Jan 5 14:56:48 1993 |
| 419 | --- nlib/format.scm Tue Feb 9 00:21:09 1993 |
| 420 | *************** |
| 421 | *** 78,84 **** |
| 422 | ; * removed C-style padding support |
| 423 | ; |
| 424 | |
| 425 | ! ;;; SCHEME IMPLEMENTATION DEPENDENCIES --------------------------------------- |
| 426 | |
| 427 | ;; To configure the format module for your scheme system, set the variable |
| 428 | ;; format:scheme-system to one of the symbols of (slib elk any). You may add |
| 429 | --- 78,88 ---- |
| 430 | ; * removed C-style padding support |
| 431 | ; |
| 432 | |
| 433 | ! ;;; SCHEME IMPLEMENTATION DEPENDENCIES |
| 434 | ! ;;; --------------------------------------- |
| 435 | ! |
| 436 | ! ;;; (minimal) Declarations for CScheme |
| 437 | ! (declare (usual-integrations)) |
| 438 | |
| 439 | ;; To configure the format module for your scheme system, set the variable |
| 440 | ;; format:scheme-system to one of the symbols of (slib elk any). You may add |
| 441 | diff -c slib/genwrite.scm nlib/genwrite.scm |
| 442 | *** slib/genwrite.scm Mon Oct 19 14:49:06 1992 |
| 443 | --- nlib/genwrite.scm Tue Feb 9 00:21:10 1993 |
| 444 | *************** |
| 445 | *** 26,31 **** |
| 446 | --- 26,34 ---- |
| 447 | ; |
| 448 | ; where display-string = (lambda (s) (for-each write-char (string->list s)) #t) |
| 449 | |
| 450 | + ;;; (minimal) Declarations for CScheme |
| 451 | + (declare (usual-integrations)) |
| 452 | + |
| 453 | (define (generic-write obj display? width output) |
| 454 | |
| 455 | (define (read-macro? l) |
| 456 | diff -c slib/hash.scm nlib/hash.scm |
| 457 | *** slib/hash.scm Thu Sep 10 00:05:52 1992 |
| 458 | --- nlib/hash.scm Tue Feb 9 00:21:10 1993 |
| 459 | *************** |
| 460 | *** 23,35 **** |
| 461 | ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =, |
| 462 | ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?. |
| 463 | |
| 464 | ! (define (hash:hash-char char n) |
| 465 | (modulo (char->integer char) n)) |
| 466 | |
| 467 | ! (define (hash:hash-char-ci char n) |
| 468 | (modulo (char->integer (char-downcase char)) n)) |
| 469 | |
| 470 | ! (define (hash:hash-symbol sym n) |
| 471 | (hash:hash-string (symbol->string sym) n)) |
| 472 | |
| 473 | ;;; I am trying to be careful about overflow and underflow here. |
| 474 | --- 23,40 ---- |
| 475 | ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =, |
| 476 | ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?. |
| 477 | |
| 478 | ! |
| 479 | ! ;;; Declarations for CScheme |
| 480 | ! (declare (usual-integrations)) |
| 481 | ! (declare (integrate hash)) |
| 482 | ! |
| 483 | ! (define-integrable (hash:hash-char char n) |
| 484 | (modulo (char->integer char) n)) |
| 485 | |
| 486 | ! (define-integrable (hash:hash-char-ci char n) |
| 487 | (modulo (char->integer (char-downcase char)) n)) |
| 488 | |
| 489 | ! (define-integrable (hash:hash-symbol sym n) |
| 490 | (hash:hash-string (symbol->string sym) n)) |
| 491 | |
| 492 | ;;; I am trying to be careful about overflow and underflow here. |
| 493 | *************** |
| 494 | *** 173,179 **** |
| 495 | |
| 496 | (define hashq hashv) |
| 497 | |
| 498 | ! (define (predicate->hash pred) |
| 499 | (cond ((eq? pred eq?) hashq) |
| 500 | ((eq? pred eqv?) hashv) |
| 501 | ((eq? pred equal?) hash) |
| 502 | --- 178,184 ---- |
| 503 | |
| 504 | (define hashq hashv) |
| 505 | |
| 506 | ! (define-integrable (predicate->hash pred) |
| 507 | (cond ((eq? pred eq?) hashq) |
| 508 | ((eq? pred eqv?) hashv) |
| 509 | ((eq? pred equal?) hash) |
| 510 | diff -c slib/hashtab.scm nlib/hashtab.scm |
| 511 | *** slib/hashtab.scm Mon Oct 19 14:49:44 1992 |
| 512 | --- nlib/hashtab.scm Tue Feb 9 00:21:11 1993 |
| 513 | *************** |
| 514 | *** 36,47 **** |
| 515 | ;Returns a procedure of 2 arguments, hashtab and key, which modifies |
| 516 | ;hashtab so that the association whose key is key removed. |
| 517 | |
| 518 | (require 'hash) |
| 519 | (require 'alist) |
| 520 | |
| 521 | ! (define (make-hash-table k) (make-vector k '())) |
| 522 | |
| 523 | ! (define (predicate->hash-asso pred) |
| 524 | (let ((hashfun (predicate->hash pred)) |
| 525 | (asso (predicate->asso pred))) |
| 526 | (lambda (key hashtab) |
| 527 | --- 36,53 ---- |
| 528 | ;Returns a procedure of 2 arguments, hashtab and key, which modifies |
| 529 | ;hashtab so that the association whose key is key removed. |
| 530 | |
| 531 | + ;;; Declarations for CScheme |
| 532 | + (declare (usual-integrations)) |
| 533 | + |
| 534 | + (declare (integrate-external "hash")) |
| 535 | + (declare (integrate-external "alist")) |
| 536 | + |
| 537 | (require 'hash) |
| 538 | (require 'alist) |
| 539 | |
| 540 | ! (define-integrable (make-hash-table k) (make-vector k '())) |
| 541 | |
| 542 | ! (define-integrable (predicate->hash-asso pred) |
| 543 | (let ((hashfun (predicate->hash pred)) |
| 544 | (asso (predicate->asso pred))) |
| 545 | (lambda (key hashtab) |
| 546 | *************** |
| 547 | *** 48,54 **** |
| 548 | (asso key |
| 549 | (vector-ref hashtab (hashfun key (vector-length hashtab))))))) |
| 550 | |
| 551 | ! (define (hash-inquirer pred) |
| 552 | (let ((hashfun (predicate->hash pred)) |
| 553 | (ainq (alist-inquirer pred))) |
| 554 | (lambda (hashtab key) |
| 555 | --- 54,60 ---- |
| 556 | (asso key |
| 557 | (vector-ref hashtab (hashfun key (vector-length hashtab))))))) |
| 558 | |
| 559 | ! (define-integrable (hash-inquirer pred) |
| 560 | (let ((hashfun (predicate->hash pred)) |
| 561 | (ainq (alist-inquirer pred))) |
| 562 | (lambda (hashtab key) |
| 563 | *************** |
| 564 | *** 55,61 **** |
| 565 | (ainq (vector-ref hashtab (hashfun key (vector-length hashtab))) |
| 566 | key)))) |
| 567 | |
| 568 | ! (define (hash-associator pred) |
| 569 | (let ((hashfun (predicate->hash pred)) |
| 570 | (asso (alist-associator pred))) |
| 571 | (lambda (hashtab key val) |
| 572 | --- 61,67 ---- |
| 573 | (ainq (vector-ref hashtab (hashfun key (vector-length hashtab))) |
| 574 | key)))) |
| 575 | |
| 576 | ! (define-integrable (hash-associator pred) |
| 577 | (let ((hashfun (predicate->hash pred)) |
| 578 | (asso (alist-associator pred))) |
| 579 | (lambda (hashtab key val) |
| 580 | *************** |
| 581 | *** 64,70 **** |
| 582 | (asso (vector-ref hashtab num) key val))) |
| 583 | hashtab))) |
| 584 | |
| 585 | ! (define (hash-remover pred) |
| 586 | (let ((hashfun (predicate->hash pred)) |
| 587 | (arem (alist-remover pred))) |
| 588 | (lambda (hashtab key) |
| 589 | --- 70,76 ---- |
| 590 | (asso (vector-ref hashtab num) key val))) |
| 591 | hashtab))) |
| 592 | |
| 593 | ! (define-integrable (hash-remover pred) |
| 594 | (let ((hashfun (predicate->hash pred)) |
| 595 | (arem (alist-remover pred))) |
| 596 | (lambda (hashtab key) |
| 597 | diff -c slib/lineio.scm nlib/lineio.scm |
| 598 | *** slib/lineio.scm Sun Oct 25 01:40:38 1992 |
| 599 | --- nlib/lineio.scm Tue Feb 9 00:21:11 1993 |
| 600 | *************** |
| 601 | *** 28,33 **** |
| 602 | --- 28,36 ---- |
| 603 | ;unspecified value. Port may be ommited, in which case it defaults to |
| 604 | ;the value returned by current-input-port. |
| 605 | |
| 606 | + ;;; Declarations for CScheme |
| 607 | + (declare (usual-integrations)) |
| 608 | + |
| 609 | (define (read-line . arg) |
| 610 | (let* ((char (apply read-char arg))) |
| 611 | (if (eof-object? char) |
| 612 | *************** |
| 613 | *** 56,61 **** |
| 614 | (+ 1 i) #f)))) |
| 615 | (string-set! str i char))))) |
| 616 | |
| 617 | ! (define (write-line str . arg) |
| 618 | (apply display str arg) |
| 619 | (apply newline arg)) |
| 620 | --- 59,64 ---- |
| 621 | (+ 1 i) #f)))) |
| 622 | (string-set! str i char))))) |
| 623 | |
| 624 | ! (define-integrable (write-line str . arg) |
| 625 | (apply display str arg) |
| 626 | (apply newline arg)) |
| 627 | diff -c slib/logical.scm nlib/logical.scm |
| 628 | *** slib/logical.scm Mon Feb 1 22:22:04 1993 |
| 629 | --- nlib/logical.scm Tue Feb 9 00:21:11 1993 |
| 630 | *************** |
| 631 | *** 48,53 **** |
| 632 | --- 48,66 ---- |
| 633 | ; |
| 634 | ;;;;------------------------------------------------------------------ |
| 635 | |
| 636 | + ;;; Declarations for CScheme |
| 637 | + (declare (usual-integrations)) |
| 638 | + (declare (integrate logand ; Exported functions |
| 639 | + logor |
| 640 | + logxor |
| 641 | + lognot |
| 642 | + ash |
| 643 | + logcount |
| 644 | + integer-length |
| 645 | + bit-extract |
| 646 | + ipow-by-squaring |
| 647 | + integer-expt)) |
| 648 | + |
| 649 | (define logical:integer-expt |
| 650 | (if (provided? 'inexact) |
| 651 | expt |
| 652 | *************** |
| 653 | *** 61,67 **** |
| 654 | (quotient k 2) |
| 655 | (if (even? k) acc (proc acc x)) |
| 656 | proc)))) |
| 657 | - |
| 658 | (define (logical:logand n1 n2) |
| 659 | (cond ((= n1 n2) n1) |
| 660 | ((zero? n1) 0) |
| 661 | --- 74,79 ---- |
| 662 | *************** |
| 663 | *** 90,102 **** |
| 664 | (vector-ref (vector-ref logical:boole-xor (modulo n1 16)) |
| 665 | (modulo n2 16)))))) |
| 666 | |
| 667 | ! (define (logical:lognot n) (- -1 n)) |
| 668 | |
| 669 | ! (define (logical:bit-extract n start end) |
| 670 | (logical:logand (- (logical:integer-expt 2 (- end start)) 1) |
| 671 | (logical:ash n (- start)))) |
| 672 | |
| 673 | ! (define (logical:ash int cnt) |
| 674 | (if (negative? cnt) |
| 675 | (let ((n (logical:integer-expt 2 (- cnt)))) |
| 676 | (if (negative? int) |
| 677 | --- 102,114 ---- |
| 678 | (vector-ref (vector-ref logical:boole-xor (modulo n1 16)) |
| 679 | (modulo n2 16)))))) |
| 680 | |
| 681 | ! (define-integrable (logical:lognot n) (- -1 n)) |
| 682 | |
| 683 | ! (define-integrable (logical:bit-extract n start end) |
| 684 | (logical:logand (- (logical:integer-expt 2 (- end start)) 1) |
| 685 | (logical:ash n (- start)))) |
| 686 | |
| 687 | ! (define-integrable (logical:ash int cnt) |
| 688 | (if (negative? cnt) |
| 689 | (let ((n (logical:integer-expt 2 (- cnt)))) |
| 690 | (if (negative? int) |
| 691 | *************** |
| 692 | *** 104,110 **** |
| 693 | (quotient int n))) |
| 694 | (* (logical:integer-expt 2 cnt) int))) |
| 695 | |
| 696 | ! (define (logical:ash-4 x) |
| 697 | (if (negative? x) |
| 698 | (+ -1 (quotient (+ 1 x) 16)) |
| 699 | (quotient x 16))) |
| 700 | --- 116,122 ---- |
| 701 | (quotient int n))) |
| 702 | (* (logical:integer-expt 2 cnt) int))) |
| 703 | |
| 704 | ! (define-integrable (logical:ash-4 x) |
| 705 | (if (negative? x) |
| 706 | (+ -1 (quotient (+ 1 x) 16)) |
| 707 | (quotient x 16))) |
| 708 | diff -c slib/mitscheme.init nlib/mitscheme.init |
| 709 | *** slib/mitscheme.init Fri Jan 22 00:52:04 1993 |
| 710 | --- nlib/mitscheme.init Tue Feb 9 00:21:12 1993 |
| 711 | *************** |
| 712 | *** 48,55 **** |
| 713 | |
| 714 | ;;; FORCE-OUTPUT flushes any pending output on optional arg output port |
| 715 | ;;; use this definition if your system doesn't have such a procedure. |
| 716 | ! ;(define (force-output . arg) #t) |
| 717 | ! (define force-output flush-output) |
| 718 | |
| 719 | ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can |
| 720 | ;;; be returned by CHAR->INTEGER. It is defined by MITScheme. |
| 721 | --- 47,54 ---- |
| 722 | |
| 723 | ;;; FORCE-OUTPUT flushes any pending output on optional arg output port |
| 724 | ;;; use this definition if your system doesn't have such a procedure. |
| 725 | ! (define (force-output . arg) #t) |
| 726 | ! ;(define force-output flush-output) |
| 727 | |
| 728 | ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can |
| 729 | ;;; be returned by CHAR->INTEGER. It is defined by MITScheme. |
| 730 | diff -c slib/modular.scm nlib/modular.scm |
| 731 | *** slib/modular.scm Sun Feb 2 12:53:26 1992 |
| 732 | --- nlib/modular.scm Tue Feb 9 00:21:13 1993 |
| 733 | *************** |
| 734 | *** 36,41 **** |
| 735 | --- 36,48 ---- |
| 736 | ;Returns (k2 ^ k3) mod k1. |
| 737 | ; |
| 738 | ;;;;-------------------------------------------------------------- |
| 739 | + |
| 740 | + ;;; Declarations for CScheme |
| 741 | + (declare (usual-integrations)) |
| 742 | + |
| 743 | + (declare (integrate-external "logical")) |
| 744 | + (declare (integrate modular:negate extended-euclid)) |
| 745 | + |
| 746 | (require 'logical) |
| 747 | |
| 748 | ;;; from: |
| 749 | *************** |
| 750 | *** 51,57 **** |
| 751 | (caddr res) |
| 752 | (- (cadr res) (* (quotient a b) (caddr res))))))) |
| 753 | |
| 754 | ! (define (modular:invert m a) |
| 755 | (let ((d (modular:extended-euclid a m))) |
| 756 | (if (= 1 (car d)) |
| 757 | (modulo (cadr d) m) |
| 758 | --- 58,64 ---- |
| 759 | (caddr res) |
| 760 | (- (cadr res) (* (quotient a b) (caddr res))))))) |
| 761 | |
| 762 | ! (define-integrable (modular:invert m a) |
| 763 | (let ((d (modular:extended-euclid a m))) |
| 764 | (if (= 1 (car d)) |
| 765 | (modulo (cadr d) m) |
| 766 | *************** |
| 767 | *** 59,67 **** |
| 768 | |
| 769 | (define modular:negate -) |
| 770 | |
| 771 | ! (define (modular:+ m a b) (modulo (+ (- a m) b) m)) |
| 772 | |
| 773 | ! (define (modular:- m a b) (modulo (- a b) m)) |
| 774 | |
| 775 | ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package |
| 776 | ;;; with Splitting Facilities." ACM Transactions on Mathematical |
| 777 | --- 66,74 ---- |
| 778 | |
| 779 | (define modular:negate -) |
| 780 | |
| 781 | ! (define-integrable (modular:+ m a b) (modulo (+ (- a m) b) m)) |
| 782 | |
| 783 | ! (define-integrable (modular:- m a b) (modulo (- a b) m)) |
| 784 | |
| 785 | ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package |
| 786 | ;;; with Splitting Facilities." ACM Transactions on Mathematical |
| 787 | *************** |
| 788 | *** 98,104 **** |
| 789 | (modulo (+ (if (positive? p) (- p m) p) |
| 790 | (* a0 (modulo b q))) m))))) |
| 791 | |
| 792 | ! (define (modular:expt m a b) |
| 793 | (cond ((= a 1) 1) |
| 794 | ((= a (- m 1)) (if (odd? b) a 1)) |
| 795 | ((zero? a) 0) |
| 796 | --- 105,111 ---- |
| 797 | (modulo (+ (if (positive? p) (- p m) p) |
| 798 | (* a0 (modulo b q))) m))))) |
| 799 | |
| 800 | ! (define-integrable (modular:expt m a b) |
| 801 | (cond ((= a 1) 1) |
| 802 | ((= a (- m 1)) (if (odd? b) a 1)) |
| 803 | ((zero? a) 0) |
| 804 | diff -c slib/obj2str.scm nlib/obj2str.scm |
| 805 | *** slib/obj2str.scm Mon Oct 19 14:49:08 1992 |
| 806 | --- nlib/obj2str.scm Tue Feb 9 00:21:13 1993 |
| 807 | *************** |
| 808 | *** 2,13 **** |
| 809 | |
| 810 | (require 'generic-write) |
| 811 | |
| 812 | ; (object->string obj) returns the textual representation of 'obj' as a |
| 813 | ; string. |
| 814 | ; |
| 815 | ; Note: (write obj) = (display (object->string obj)) |
| 816 | |
| 817 | ! (define (object->string obj) |
| 818 | (let ((result '())) |
| 819 | (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t)) |
| 820 | (reverse-string-append result))) |
| 821 | --- 2,17 ---- |
| 822 | |
| 823 | (require 'generic-write) |
| 824 | |
| 825 | + ;;; Declarations for CScheme |
| 826 | + (declare (usual-integrations)) |
| 827 | + (declare (integrate-external "genwrite")) |
| 828 | + |
| 829 | ; (object->string obj) returns the textual representation of 'obj' as a |
| 830 | ; string. |
| 831 | ; |
| 832 | ; Note: (write obj) = (display (object->string obj)) |
| 833 | |
| 834 | ! (define-integrable (object->string obj) |
| 835 | (let ((result '())) |
| 836 | (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t)) |
| 837 | (reverse-string-append result))) |
| 838 | diff -c slib/pp2str.scm nlib/pp2str.scm |
| 839 | *** slib/pp2str.scm Mon Oct 19 14:49:08 1992 |
| 840 | --- nlib/pp2str.scm Tue Feb 9 00:21:13 1993 |
| 841 | *************** |
| 842 | *** 2,11 **** |
| 843 | |
| 844 | (require 'generic-write) |
| 845 | |
| 846 | ; (pretty-print-to-string obj) returns a string with the pretty-printed |
| 847 | ; textual representation of 'obj'. |
| 848 | |
| 849 | ! (define (pp:pretty-print-to-string obj) |
| 850 | (let ((result '())) |
| 851 | (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t)) |
| 852 | (reverse-string-append result))) |
| 853 | --- 2,16 ---- |
| 854 | |
| 855 | (require 'generic-write) |
| 856 | |
| 857 | + ;;; Declarations for CScheme |
| 858 | + (declare (usual-integrations)) |
| 859 | + (declare (integrate-external "genwrite")) |
| 860 | + (declare (integrate pretty-print-to-string)) |
| 861 | + |
| 862 | ; (pretty-print-to-string obj) returns a string with the pretty-printed |
| 863 | ; textual representation of 'obj'. |
| 864 | |
| 865 | ! (define-integrable (pp:pretty-print-to-string obj) |
| 866 | (let ((result '())) |
| 867 | (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t)) |
| 868 | (reverse-string-append result))) |
| 869 | diff -c slib/ppfile.scm nlib/ppfile.scm |
| 870 | *** slib/ppfile.scm Mon Oct 19 14:49:08 1992 |
| 871 | --- nlib/ppfile.scm Tue Feb 9 00:21:14 1993 |
| 872 | *************** |
| 873 | *** 10,15 **** |
| 874 | --- 10,19 ---- |
| 875 | ; |
| 876 | (require 'pretty-print) |
| 877 | |
| 878 | + ;;; Declarations for CScheme |
| 879 | + (declare (usual-integrations)) |
| 880 | + (declare (integrate-external "pp")) |
| 881 | + |
| 882 | (define (pprint-file ifile . optarg) |
| 883 | (let ((lst (call-with-input-file ifile |
| 884 | (lambda (iport) |
| 885 | diff -c slib/prime.scm nlib/prime.scm |
| 886 | *** slib/prime.scm Mon Feb 8 20:49:46 1993 |
| 887 | --- nlib/prime.scm Tue Feb 9 00:24:16 1993 |
| 888 | *************** |
| 889 | *** 24,29 **** |
| 890 | --- 24,39 ---- |
| 891 | ;(sort! (factor k) <) |
| 892 | |
| 893 | ;;;;-------------------------------------------------------------- |
| 894 | + ;;; Declarations for CScheme |
| 895 | + (declare (usual-integrations)) |
| 896 | + (declare (integrate-external "random")) |
| 897 | + (declare (integrate-external "modular")) |
| 898 | + (declare (integrate |
| 899 | + jacobi-symbol |
| 900 | + prime? |
| 901 | + factor)) |
| 902 | + |
| 903 | + |
| 904 | (require 'random) |
| 905 | (require 'modular) |
| 906 | |
| 907 | *************** |
| 908 | *** 56,62 **** |
| 909 | ;;; choosing prime:trials=30 should be enough |
| 910 | (define prime:trials 30) |
| 911 | ;;; prime:product is a product of small primes. |
| 912 | ! (define prime:product |
| 913 | (let ((p 210)) |
| 914 | (for-each (lambda (s) (set! p (or (string->number s) p))) |
| 915 | '("2310" "30030" "510510" "9699690" "223092870" |
| 916 | --- 66,72 ---- |
| 917 | ;;; choosing prime:trials=30 should be enough |
| 918 | (define prime:trials 30) |
| 919 | ;;; prime:product is a product of small primes. |
| 920 | ! (define-integrable prime:product |
| 921 | (let ((p 210)) |
| 922 | (for-each (lambda (s) (set! p (or (string->number s) p))) |
| 923 | '("2310" "30030" "510510" "9699690" "223092870" |
| 924 | *************** |
| 925 | *** 86,92 **** |
| 926 | ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even |
| 927 | |
| 928 | ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. |
| 929 | ! |
| 930 | ;It may be illuminating to consider the relation of the Lankinen function in |
| 931 | ;a `computational hierarchy' of other factoring functions.* Assumptions are |
| 932 | ;made herein on the basis of conventional digital (binary) computers. Also, |
| 933 | --- 96,102 ---- |
| 934 | ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even |
| 935 | |
| 936 | ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. |
| 937 | ! |
| 938 | ;It may be illuminating to consider the relation of the Lankinen function in |
| 939 | ;a `computational hierarchy' of other factoring functions.* Assumptions are |
| 940 | ;made herein on the basis of conventional digital (binary) computers. Also, |
| 941 | *************** |
| 942 | *** 94,100 **** |
| 943 | ;be factored is prime). However, all algorithms would probably perform to |
| 944 | ;the same constant multiple of the given orders for complete composite |
| 945 | ;factorizations. |
| 946 | ! |
| 947 | ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and |
| 948 | ; O(n*log2(n)) in space. |
| 949 | ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime |
| 950 | --- 104,110 ---- |
| 951 | ;be factored is prime). However, all algorithms would probably perform to |
| 952 | ;the same constant multiple of the given orders for complete composite |
| 953 | ;factorizations. |
| 954 | ! |
| 955 | ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and |
| 956 | ; O(n*log2(n)) in space. |
| 957 | ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime |
| 958 | diff -c slib/priorque.scm nlib/priorque.scm |
| 959 | *** slib/priorque.scm Mon Oct 19 14:49:42 1992 |
| 960 | --- nlib/priorque.scm Tue Feb 9 00:21:15 1993 |
| 961 | *************** |
| 962 | *** 22,41 **** |
| 963 | ;;; 1989 MIT Press. |
| 964 | |
| 965 | (require 'record) |
| 966 | (define heap-rtd (make-record-type "heap" '(array size heap<?))) |
| 967 | ! (define make-heap |
| 968 | (let ((cstr (record-constructor heap-rtd))) |
| 969 | (lambda (pred<?) |
| 970 | (cstr (make-vector 4) 0 pred<?)))) |
| 971 | ! (define heap-ref |
| 972 | (let ((ra (record-accessor heap-rtd 'array))) |
| 973 | (lambda (a i) |
| 974 | (vector-ref (ra a) (+ -1 i))))) |
| 975 | ! (define heap-set! |
| 976 | (let ((ra (record-accessor heap-rtd 'array))) |
| 977 | (lambda (a i v) |
| 978 | (vector-set! (ra a) (+ -1 i) v)))) |
| 979 | ! (define heap-exchange |
| 980 | (let ((aa (record-accessor heap-rtd 'array))) |
| 981 | (lambda (a i j) |
| 982 | (set! i (+ -1 i)) |
| 983 | --- 22,53 ---- |
| 984 | ;;; 1989 MIT Press. |
| 985 | |
| 986 | (require 'record) |
| 987 | + |
| 988 | + ;;; Declarations for CScheme |
| 989 | + (declare (usual-integrations)) |
| 990 | + |
| 991 | + (declare (integrate |
| 992 | + heap-size |
| 993 | + heap<?)) |
| 994 | + |
| 995 | (define heap-rtd (make-record-type "heap" '(array size heap<?))) |
| 996 | ! |
| 997 | ! (define-integrable make-heap |
| 998 | (let ((cstr (record-constructor heap-rtd))) |
| 999 | (lambda (pred<?) |
| 1000 | (cstr (make-vector 4) 0 pred<?)))) |
| 1001 | ! |
| 1002 | ! (define-integrable heap-ref |
| 1003 | (let ((ra (record-accessor heap-rtd 'array))) |
| 1004 | (lambda (a i) |
| 1005 | (vector-ref (ra a) (+ -1 i))))) |
| 1006 | ! |
| 1007 | ! (define-integrable heap-set! |
| 1008 | (let ((ra (record-accessor heap-rtd 'array))) |
| 1009 | (lambda (a i v) |
| 1010 | (vector-set! (ra a) (+ -1 i) v)))) |
| 1011 | ! |
| 1012 | ! (define-integrable heap-exchange |
| 1013 | (let ((aa (record-accessor heap-rtd 'array))) |
| 1014 | (lambda (a i j) |
| 1015 | (set! i (+ -1 i)) |
| 1016 | *************** |
| 1017 | *** 44,51 **** |
| 1018 | --- 56,66 ---- |
| 1019 | (tmp (vector-ref ra i))) |
| 1020 | (vector-set! ra i (vector-ref ra j)) |
| 1021 | (vector-set! ra j tmp))))) |
| 1022 | + |
| 1023 | (define heap-size (record-accessor heap-rtd 'size)) |
| 1024 | + |
| 1025 | (define heap<? (record-accessor heap-rtd 'heap<?)) |
| 1026 | + |
| 1027 | (define heap-set-size |
| 1028 | (let ((aa (record-accessor heap-rtd 'array)) |
| 1029 | (am (record-modifier heap-rtd 'array)) |
| 1030 | *************** |
| 1031 | *** 59,68 **** |
| 1032 | (vector-set! nra i (vector-ref ra i))))) |
| 1033 | (sm a s))))) |
| 1034 | |
| 1035 | ! (define (heap-parent i) (quotient i 2)) |
| 1036 | ! (define (heap-left i) (* 2 i)) |
| 1037 | ! (define (heap-right i) (+ 1 (* 2 i))) |
| 1038 | |
| 1039 | (define (heapify a i) |
| 1040 | (define l (heap-left i)) |
| 1041 | (define r (heap-right i)) |
| 1042 | --- 74,85 ---- |
| 1043 | (vector-set! nra i (vector-ref ra i))))) |
| 1044 | (sm a s))))) |
| 1045 | |
| 1046 | ! (define-integrable (heap-parent i) (quotient i 2)) |
| 1047 | |
| 1048 | + (define-integrable (heap-left i) (* 2 i)) |
| 1049 | + |
| 1050 | + (define-integrable (heap-right i) (+ 1 (* 2 i))) |
| 1051 | + |
| 1052 | (define (heapify a i) |
| 1053 | (define l (heap-left i)) |
| 1054 | (define r (heap-right i)) |
| 1055 | *************** |
| 1056 | *** 99,104 **** |
| 1057 | --- 116,122 ---- |
| 1058 | max)) |
| 1059 | |
| 1060 | (define heap #f) |
| 1061 | + |
| 1062 | (define (heap-test) |
| 1063 | (set! heap (make-heap char>?)) |
| 1064 | (heap-insert! heap #\A) |
| 1065 | diff -c slib/process.scm nlib/process.scm |
| 1066 | *** slib/process.scm Wed Nov 4 12:26:50 1992 |
| 1067 | --- nlib/process.scm Tue Feb 9 00:21:15 1993 |
| 1068 | *************** |
| 1069 | *** 21,30 **** |
| 1070 | ; |
| 1071 | ;;;;---------------------------------------------------------------------- |
| 1072 | |
| 1073 | (require 'full-continuation) |
| 1074 | (require 'queue) |
| 1075 | |
| 1076 | ! (define (add-process! thunk1) |
| 1077 | (cond ((procedure? thunk1) |
| 1078 | (defer-ints) |
| 1079 | (enqueue! process:queue thunk1) |
| 1080 | --- 21,33 ---- |
| 1081 | ; |
| 1082 | ;;;;---------------------------------------------------------------------- |
| 1083 | |
| 1084 | + ;;; Declarations for CScheme |
| 1085 | + (declare (usual-integrations)) |
| 1086 | + |
| 1087 | (require 'full-continuation) |
| 1088 | (require 'queue) |
| 1089 | |
| 1090 | ! (define-integrable (add-process! thunk1) |
| 1091 | (cond ((procedure? thunk1) |
| 1092 | (defer-ints) |
| 1093 | (enqueue! process:queue thunk1) |
| 1094 | *************** |
| 1095 | *** 55,63 **** |
| 1096 | (define ints-disabled #f) |
| 1097 | (define alarm-deferred #f) |
| 1098 | |
| 1099 | ! (define (defer-ints) (set! ints-disabled #t)) |
| 1100 | |
| 1101 | ! (define (allow-ints) |
| 1102 | (set! ints-disabled #f) |
| 1103 | (cond (alarm-deferred |
| 1104 | (set! alarm-deferred #f) |
| 1105 | --- 58,66 ---- |
| 1106 | (define ints-disabled #f) |
| 1107 | (define alarm-deferred #f) |
| 1108 | |
| 1109 | ! (define-integrable (defer-ints) (set! ints-disabled #t)) |
| 1110 | |
| 1111 | ! (define-integrable (allow-ints) |
| 1112 | (set! ints-disabled #f) |
| 1113 | (cond (alarm-deferred |
| 1114 | (set! alarm-deferred #f) |
| 1115 | *************** |
| 1116 | *** 66,72 **** |
| 1117 | ;;; Make THE process queue. |
| 1118 | (define process:queue (make-queue)) |
| 1119 | |
| 1120 | ! (define (alarm-interrupt) |
| 1121 | (alarm 1) |
| 1122 | (if ints-disabled (set! alarm-deferred #t) |
| 1123 | (process:schedule!))) |
| 1124 | --- 69,75 ---- |
| 1125 | ;;; Make THE process queue. |
| 1126 | (define process:queue (make-queue)) |
| 1127 | |
| 1128 | ! (define-integrable (alarm-interrupt) |
| 1129 | (alarm 1) |
| 1130 | (if ints-disabled (set! alarm-deferred #t) |
| 1131 | (process:schedule!))) |
| 1132 | diff -c slib/randinex.scm nlib/randinex.scm |
| 1133 | *** slib/randinex.scm Wed Nov 18 22:59:20 1992 |
| 1134 | --- nlib/randinex.scm Tue Feb 9 00:21:16 1993 |
| 1135 | *************** |
| 1136 | *** 47,52 **** |
| 1137 | --- 47,59 ---- |
| 1138 | ;For an exponential distribution with mean U use (* U (random:exp)). |
| 1139 | ;;;;----------------------------------------------------------------- |
| 1140 | |
| 1141 | + |
| 1142 | + ;;; Declarations for CScheme |
| 1143 | + (declare (usual-integrations)) |
| 1144 | + (declare (integrate-external "random")) |
| 1145 | + (declare (integrate |
| 1146 | + random:float-radix)) |
| 1147 | + |
| 1148 | (define random:float-radix |
| 1149 | (+ 1 (exact->inexact random:MASK))) |
| 1150 | |
| 1151 | *************** |
| 1152 | *** 56,61 **** |
| 1153 | --- 63,69 ---- |
| 1154 | (if (= 1.0 (+ 1 x)) |
| 1155 | l |
| 1156 | (random:size-float (+ l 1) (/ x random:float-radix)))) |
| 1157 | + |
| 1158 | (define random:chunks/float (random:size-float 1 1.0)) |
| 1159 | |
| 1160 | (define (random:uniform-chunk n state) |
| 1161 | *************** |
| 1162 | *** 67,73 **** |
| 1163 | random:float-radix))) |
| 1164 | |
| 1165 | ;;; Generate an inexact real between 0 and 1. |
| 1166 | ! (define (random:uniform state) |
| 1167 | (random:uniform-chunk random:chunks/float state)) |
| 1168 | |
| 1169 | ;;; If x and y are independent standard normal variables, then with |
| 1170 | --- 75,81 ---- |
| 1171 | random:float-radix))) |
| 1172 | |
| 1173 | ;;; Generate an inexact real between 0 and 1. |
| 1174 | ! (define-integrable (random:uniform state) |
| 1175 | (random:uniform-chunk random:chunks/float state)) |
| 1176 | |
| 1177 | ;;; If x and y are independent standard normal variables, then with |
| 1178 | *************** |
| 1179 | *** 89,95 **** |
| 1180 | (do! n (* r (cos t))) |
| 1181 | (if (positive? n) (do! (- n 1) (* r (sin t))))))))) |
| 1182 | |
| 1183 | ! (define random:normal |
| 1184 | (let ((vect (make-vector 1))) |
| 1185 | (lambda args |
| 1186 | (apply random:normal-vector! vect args) |
| 1187 | --- 97,103 ---- |
| 1188 | (do! n (* r (cos t))) |
| 1189 | (if (positive? n) (do! (- n 1) (* r (sin t))))))))) |
| 1190 | |
| 1191 | ! (define-integrable random:normal |
| 1192 | (let ((vect (make-vector 1))) |
| 1193 | (lambda args |
| 1194 | (apply random:normal-vector! vect args) |
| 1195 | *************** |
| 1196 | *** 98,104 **** |
| 1197 | ;;; For the uniform distibution on the hollow sphere, pick a normal |
| 1198 | ;;; family and scale. |
| 1199 | |
| 1200 | ! (define (random:hollow-sphere! vect . args) |
| 1201 | (let ((ms (sqrt (apply random:normal-vector! vect args)))) |
| 1202 | (do ((n (- (vector-length vect) 1) (- n 1))) |
| 1203 | ((negative? n)) |
| 1204 | --- 106,112 ---- |
| 1205 | ;;; For the uniform distibution on the hollow sphere, pick a normal |
| 1206 | ;;; family and scale. |
| 1207 | |
| 1208 | ! (define-integrable (random:hollow-sphere! vect . args) |
| 1209 | (let ((ms (sqrt (apply random:normal-vector! vect args)))) |
| 1210 | (do ((n (- (vector-length vect) 1) (- n 1))) |
| 1211 | ((negative? n)) |
| 1212 | *************** |
| 1213 | *** 117,123 **** |
| 1214 | ((negative? n)) |
| 1215 | (vector-set! vect n (* r (vector-ref vect n)))))) |
| 1216 | |
| 1217 | ! (define (random:exp . args) |
| 1218 | (let ((state (if (null? args) *random-state* (car args)))) |
| 1219 | (- (log (random:uniform state))))) |
| 1220 | |
| 1221 | --- 125,131 ---- |
| 1222 | ((negative? n)) |
| 1223 | (vector-set! vect n (* r (vector-ref vect n)))))) |
| 1224 | |
| 1225 | ! (define-integrable (random:exp . args) |
| 1226 | (let ((state (if (null? args) *random-state* (car args)))) |
| 1227 | (- (log (random:uniform state))))) |
| 1228 | |
| 1229 | diff -c slib/random.scm nlib/random.scm |
| 1230 | *** slib/random.scm Tue Feb 2 00:02:58 1993 |
| 1231 | --- nlib/random.scm Tue Feb 9 00:21:18 1993 |
| 1232 | *************** |
| 1233 | *** 35,40 **** |
| 1234 | --- 35,50 ---- |
| 1235 | ;procedures for generating inexact distributions. |
| 1236 | ;;;;------------------------------------------------------------------ |
| 1237 | |
| 1238 | + ;;; Declarations for CScheme |
| 1239 | + (declare (usual-integrations)) |
| 1240 | + (declare (integrate-external "logical")) |
| 1241 | + (declare (integrateb |
| 1242 | + random:tap-1 |
| 1243 | + random:size |
| 1244 | + random:chunk-size |
| 1245 | + random:MASK |
| 1246 | + random)) |
| 1247 | + |
| 1248 | (require 'logical) |
| 1249 | |
| 1250 | (define random:tap 24) |
| 1251 | *************** |
| 1252 | *** 45,50 **** |
| 1253 | --- 55,61 ---- |
| 1254 | (if (and (exact? trial) (>= most-positive-fixnum trial)) |
| 1255 | l |
| 1256 | (random:size-int (- l 1))))) |
| 1257 | + |
| 1258 | (define random:chunk-size (* 4 (random:size-int 8))) |
| 1259 | |
| 1260 | (define random:MASK |
| 1261 | *************** |
| 1262 | *** 107,113 **** |
| 1263 | ;;;random:uniform is in randinex.scm. It is needed only if inexact is |
| 1264 | ;;;supported. |
| 1265 | |
| 1266 | ! (define (random:make-random-state . args) |
| 1267 | (let ((state (if (null? args) *random-state* (car args)))) |
| 1268 | (list->vector (vector->list state)))) |
| 1269 | |
| 1270 | --- 118,124 ---- |
| 1271 | ;;;random:uniform is in randinex.scm. It is needed only if inexact is |
| 1272 | ;;;supported. |
| 1273 | |
| 1274 | ! (define-integrable (random:make-random-state . args) |
| 1275 | (let ((state (if (null? args) *random-state* (car args)))) |
| 1276 | (list->vector (vector->list state)))) |
| 1277 | |
| 1278 | diff -c slib/rbtree.scm nlib/rbtree.scm |
| 1279 | *** slib/rbtree.scm Sat Jan 9 13:40:56 1993 |
| 1280 | --- nlib/rbtree.scm Tue Feb 9 00:21:18 1993 |
| 1281 | *************** |
| 1282 | *** 5,11 **** |
| 1283 | --- 5,24 ---- |
| 1284 | ;;;; PGS, 6 Jul 1990 |
| 1285 | ;;; jaffer@ai.mit.edu Ported to SLIB, 1/6/93 |
| 1286 | |
| 1287 | + |
| 1288 | + ;;; Declarations for CScheme |
| 1289 | + (declare (usual-integrations)) |
| 1290 | + (declare (integrate |
| 1291 | + rb-tree-root |
| 1292 | + set-rb-tree-root! |
| 1293 | + rb-tree-left-rotation-field-maintainer |
| 1294 | + rb-tree-right-rotation-field-maintainer |
| 1295 | + rb-tree-insertion-field-maintainer |
| 1296 | + rb-tree-deletion-field-maintainer |
| 1297 | + rb-tree-prior?)) |
| 1298 | + |
| 1299 | (require 'record) |
| 1300 | + |
| 1301 | (define rb-tree |
| 1302 | (make-record-type |
| 1303 | "rb-tree" |
| 1304 | *************** |
| 1305 | *** 227,233 **** |
| 1306 | y) |
| 1307 | (set! x y) |
| 1308 | (set! y (rb-node-parent y))))) |
| 1309 | - |
| 1310 | |
| 1311 | ;;;; Deletion. We do not entirely follow Cormen, Leiserson and Rivest's lead |
| 1312 | ;;;; here, because their use of sentinels is in rather obscenely poor taste. |
| 1313 | --- 240,245 ---- |
| 1314 | diff -c slib/sort.scm nlib/sort.scm |
| 1315 | *** slib/sort.scm Wed Nov 6 00:50:38 1991 |
| 1316 | --- nlib/sort.scm Tue Feb 9 00:22:03 1993 |
| 1317 | *************** |
| 1318 | *** 118,123 **** |
| 1319 | --- 118,125 ---- |
| 1320 | ; in Scheme. |
| 1321 | ;;; -------------------------------------------------------------------- |
| 1322 | |
| 1323 | + ;;; Declarations for CScheme |
| 1324 | + (declare (usual-integrations)) ; Honestly, nothing defined here clashes! |
| 1325 | |
| 1326 | ;;; (sorted? sequence less?) |
| 1327 | ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) |
| 1328 | diff -c slib/printf.scm nlib/printf.scm |
| 1329 | *** slib/printf.scm Mon Oct 19 14:48:58 1992 |
| 1330 | --- nlib/printf.scm Tue Feb 9 00:22:03 1993 |
| 1331 | *************** |
| 1332 | *** 3,8 **** |
| 1333 | --- 3,19 ---- |
| 1334 | |
| 1335 | ;;; Floating point is not handled yet. It should not be hard to do. |
| 1336 | |
| 1337 | + ;;; Declarations for CScheme |
| 1338 | + (declare (usual-integrations)) |
| 1339 | + |
| 1340 | + (declare (integrate |
| 1341 | + printf |
| 1342 | + fprintf |
| 1343 | + sprintf |
| 1344 | + stdin |
| 1345 | + stdout |
| 1346 | + stderr)) |
| 1347 | + |
| 1348 | (define (stdio:iprintf out format . args) |
| 1349 | (let loop ((pos 0) (args args)) |
| 1350 | (if (< pos (string-length format)) |
| 1351 | *************** |
| 1352 | *** 96,105 **** |
| 1353 | (else (out (string-ref format pos)) |
| 1354 | (loop (+ pos 1) args)))))) |
| 1355 | |
| 1356 | ! (define (stdio:printf format . args) |
| 1357 | (apply stdio:iprintf display format args)) |
| 1358 | |
| 1359 | ! (define (stdio:fprintf port format . args) |
| 1360 | (if (equal? port (current-output-port)) |
| 1361 | (apply stdio:iprintf display format args) |
| 1362 | (apply stdio:iprintf (lambda (x) (display x port)) format args))) |
| 1363 | --- 107,116 ---- |
| 1364 | (else (out (string-ref format pos)) |
| 1365 | (loop (+ pos 1) args)))))) |
| 1366 | |
| 1367 | ! (define-integrable (stdio:printf format . args) |
| 1368 | (apply stdio:iprintf display format args)) |
| 1369 | |
| 1370 | ! (define-integrable (stdio:fprintf port format . args) |
| 1371 | (if (equal? port (current-output-port)) |
| 1372 | (apply stdio:iprintf display format args) |
| 1373 | (apply stdio:iprintf (lambda (x) (display x port)) format args))) |
| 1374 | diff -c slib/strcase.scm nlib/strcase.scm |
| 1375 | *** slib/strcase.scm Wed Nov 18 14:15:18 1992 |
| 1376 | --- nlib/strcase.scm Tue Feb 9 00:22:03 1993 |
| 1377 | *************** |
| 1378 | *** 8,27 **** |
| 1379 | ;string-upcase!, string-downcase!, string-capitalize! |
| 1380 | ; are destructive versions. |
| 1381 | |
| 1382 | ! (define (string-upcase! str) |
| 1383 | (do ((i (- (string-length str) 1) (- i 1))) |
| 1384 | ((< i 0) str) |
| 1385 | (string-set! str i (char-upcase (string-ref str i))))) |
| 1386 | |
| 1387 | ! (define (string-upcase str) |
| 1388 | (string-upcase! (string-copy str))) |
| 1389 | |
| 1390 | ! (define (string-downcase! str) |
| 1391 | (do ((i (- (string-length str) 1) (- i 1))) |
| 1392 | ((< i 0) str) |
| 1393 | (string-set! str i (char-downcase (string-ref str i))))) |
| 1394 | |
| 1395 | ! (define (string-downcase str) |
| 1396 | (string-downcase! (string-copy str))) |
| 1397 | |
| 1398 | (define (string-capitalize! str) ; "hello" -> "Hello" |
| 1399 | --- 8,30 ---- |
| 1400 | ;string-upcase!, string-downcase!, string-capitalize! |
| 1401 | ; are destructive versions. |
| 1402 | |
| 1403 | ! ;;; Declarations for CScheme |
| 1404 | ! (declare (usual-integrations)) |
| 1405 | ! |
| 1406 | ! (define-integrable (string-upcase! str) |
| 1407 | (do ((i (- (string-length str) 1) (- i 1))) |
| 1408 | ((< i 0) str) |
| 1409 | (string-set! str i (char-upcase (string-ref str i))))) |
| 1410 | |
| 1411 | ! (define-integrable (string-upcase str) |
| 1412 | (string-upcase! (string-copy str))) |
| 1413 | |
| 1414 | ! (define-integrable (string-downcase! str) |
| 1415 | (do ((i (- (string-length str) 1) (- i 1))) |
| 1416 | ((< i 0) str) |
| 1417 | (string-set! str i (char-downcase (string-ref str i))))) |
| 1418 | |
| 1419 | ! (define-integrable (string-downcase str) |
| 1420 | (string-downcase! (string-copy str))) |
| 1421 | |
| 1422 | (define (string-capitalize! str) ; "hello" -> "Hello" |
| 1423 | *************** |
| 1424 | *** 38,42 **** |
| 1425 | (string-set! str i (char-upcase c)))) |
| 1426 | (set! non-first-alpha #f)))))) |
| 1427 | |
| 1428 | ! (define (string-capitalize str) |
| 1429 | (string-capitalize! (string-copy str))) |
| 1430 | --- 41,45 ---- |
| 1431 | (string-set! str i (char-upcase c)))) |
| 1432 | (set! non-first-alpha #f)))))) |
| 1433 | |
| 1434 | ! (define-integrable (string-capitalize str) |
| 1435 | (string-capitalize! (string-copy str))) |
| 1436 | diff -c slib/synchk.scm nlib/synchk.scm |
| 1437 | *** slib/synchk.scm Mon Jan 27 09:28:48 1992 |
| 1438 | --- nlib/synchk.scm Tue Feb 9 00:22:03 1993 |
| 1439 | *************** |
| 1440 | *** 35,45 **** |
| 1441 | ;;; written by Alan Bawden |
| 1442 | ;;; modified by Chris Hanson |
| 1443 | |
| 1444 | ! (define (syntax-check pattern form) |
| 1445 | (if (not (syntax-match? (cdr pattern) (cdr form))) |
| 1446 | (syntax-error "ill-formed special form" form))) |
| 1447 | |
| 1448 | ! (define (ill-formed-syntax form) |
| 1449 | (syntax-error "ill-formed special form" form)) |
| 1450 | |
| 1451 | (define (syntax-match? pattern object) |
| 1452 | --- 35,48 ---- |
| 1453 | ;;; written by Alan Bawden |
| 1454 | ;;; modified by Chris Hanson |
| 1455 | |
| 1456 | ! ;;; Declarations for CScheme |
| 1457 | ! (declare (usual-integrations)) |
| 1458 | ! |
| 1459 | ! (define-integrable (syntax-check pattern form) |
| 1460 | (if (not (syntax-match? (cdr pattern) (cdr form))) |
| 1461 | (syntax-error "ill-formed special form" form))) |
| 1462 | |
| 1463 | ! (define-integrable (ill-formed-syntax form) |
| 1464 | (syntax-error "ill-formed special form" form)) |
| 1465 | |
| 1466 | (define (syntax-match? pattern object) |