Commit | Line | Data |
---|---|---|
9ddacf86 KN |
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) |