| 1 | ;;; installed-scm-file |
| 2 | |
| 3 | ;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. |
| 4 | ;;;; |
| 5 | ;;;; This program is free software; you can redistribute it and/or modify |
| 6 | ;;;; it under the terms of the GNU General Public License as published by |
| 7 | ;;;; the Free Software Foundation; either version 2, or (at your option) |
| 8 | ;;;; any later version. |
| 9 | ;;;; |
| 10 | ;;;; This program is distributed in the hope that it will be useful, |
| 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 13 | ;;;; GNU General Public License for more details. |
| 14 | ;;;; |
| 15 | ;;;; You should have received a copy of the GNU General Public License |
| 16 | ;;;; along with this software; see the file COPYING. If not, write to |
| 17 | ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
| 18 | ;;;; |
| 19 | \f |
| 20 | |
| 21 | ;;; This file is the first thing loaded into Guile. It adds many mundane |
| 22 | ;;; definitions and a few that are interesting. |
| 23 | ;;; |
| 24 | ;;; The module system (hence the hierarchical namespace) are defined in this |
| 25 | ;;; file. |
| 26 | ;;; |
| 27 | |
| 28 | \f |
| 29 | ;;; During Guile development, we want to use debugging evaluator and record |
| 30 | ;;; positions of source expressions in boot-9.scm by default. |
| 31 | |
| 32 | (debug-options-interface (cons 'debug (debug-options-interface))) |
| 33 | (read-options-interface (cons 'positions (read-options-interface))) |
| 34 | |
| 35 | \f |
| 36 | ;;; {Features} |
| 37 | ;; |
| 38 | |
| 39 | (define (provide sym) |
| 40 | (if (not (memq sym *features*)) |
| 41 | (set! *features* (cons sym *features*)))) |
| 42 | |
| 43 | \f |
| 44 | ;;; {R4RS compliance} |
| 45 | |
| 46 | (primitive-load-path "ice-9/r4rs.scm") |
| 47 | |
| 48 | \f |
| 49 | ;;; {Simple Debugging Tools} |
| 50 | ;; |
| 51 | |
| 52 | |
| 53 | ;; peek takes any number of arguments, writes them to the |
| 54 | ;; current ouput port, and returns the last argument. |
| 55 | ;; It is handy to wrap around an expression to look at |
| 56 | ;; a value each time is evaluated, e.g.: |
| 57 | ;; |
| 58 | ;; (+ 10 (troublesome-fn)) |
| 59 | ;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn))) |
| 60 | ;; |
| 61 | |
| 62 | (define (peek . stuff) |
| 63 | (newline) |
| 64 | (display ";;; ") |
| 65 | (write stuff) |
| 66 | (newline) |
| 67 | (car (last-pair stuff))) |
| 68 | |
| 69 | (define pk peek) |
| 70 | |
| 71 | (define (warn . stuff) |
| 72 | (with-output-to-port (current-error-port) |
| 73 | (lambda () |
| 74 | (newline) |
| 75 | (display ";;; WARNING ") |
| 76 | (display stuff) |
| 77 | (newline) |
| 78 | (car (last-pair stuff))))) |
| 79 | |
| 80 | \f |
| 81 | ;;; {apply and call-with-current-continuation} |
| 82 | ;;; |
| 83 | ;;; These turn syntax, @apply and @call-with-current-continuation, |
| 84 | ;;; into procedures. |
| 85 | ;;; |
| 86 | |
| 87 | (set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args)))) |
| 88 | (define (call-with-current-continuation proc) |
| 89 | (@call-with-current-continuation proc)) |
| 90 | |
| 91 | |
| 92 | \f |
| 93 | ;;; {Trivial Functions} |
| 94 | ;;; |
| 95 | |
| 96 | (define (id x) x) |
| 97 | (define (1+ n) (+ n 1)) |
| 98 | (define (-1+ n) (+ n -1)) |
| 99 | (define 1- -1+) |
| 100 | (define return-it noop) |
| 101 | (define (and=> value thunk) (and value (thunk value))) |
| 102 | (define (make-hash-table k) (make-vector k '())) |
| 103 | |
| 104 | ;;; apply-to-args is functionally redunant with apply and, worse, |
| 105 | ;;; is less general than apply since it only takes two arguments. |
| 106 | ;;; |
| 107 | ;;; On the other hand, apply-to-args is a syntacticly convenient way to |
| 108 | ;;; perform binding in many circumstances when the "let" family of |
| 109 | ;;; of forms don't cut it. E.g.: |
| 110 | ;;; |
| 111 | ;;; (apply-to-args (return-3d-mouse-coords) |
| 112 | ;;; (lambda (x y z) |
| 113 | ;;; ...)) |
| 114 | ;;; |
| 115 | |
| 116 | (define (apply-to-args args fn) (apply fn args)) |
| 117 | |
| 118 | \f |
| 119 | ;;; {Integer Math} |
| 120 | ;;; |
| 121 | |
| 122 | (define (ipow-by-squaring x k acc proc) |
| 123 | (cond ((zero? k) acc) |
| 124 | ((= 1 k) (proc acc x)) |
| 125 | (else (logical:ipow-by-squaring (proc x x) |
| 126 | (quotient k 2) |
| 127 | (if (even? k) acc (proc acc x)) |
| 128 | proc)))) |
| 129 | |
| 130 | (define string-character-length string-length) |
| 131 | |
| 132 | |
| 133 | |
| 134 | ;; A convenience function for combining flag bits. Like logior, but |
| 135 | ;; handles the cases of 0 and 1 arguments. |
| 136 | ;; |
| 137 | (define (flags . args) |
| 138 | (cond |
| 139 | ((null? args) 0) |
| 140 | ((null? (cdr args)) (car args)) |
| 141 | (else (apply logior args)))) |
| 142 | |
| 143 | \f |
| 144 | ;;; {Symbol Properties} |
| 145 | ;;; |
| 146 | |
| 147 | (define (symbol-property sym prop) |
| 148 | (let ((pair (assoc prop (symbol-pref sym)))) |
| 149 | (and pair (cdr pair)))) |
| 150 | |
| 151 | (define (set-symbol-property! sym prop val) |
| 152 | (let ((pair (assoc prop (symbol-pref sym)))) |
| 153 | (if pair |
| 154 | (set-cdr! pair val) |
| 155 | (symbol-pset! sym (acons prop val (symbol-pref sym)))))) |
| 156 | |
| 157 | (define (symbol-property-remove! sym prop) |
| 158 | (let ((pair (assoc prop (symbol-pref sym)))) |
| 159 | (if pair |
| 160 | (symbol-pset! sym (delq! pair (symbol-pref sym)))))) |
| 161 | |
| 162 | \f |
| 163 | ;;; {Arrays} |
| 164 | ;;; |
| 165 | |
| 166 | (begin |
| 167 | (define uniform-vector? array?) |
| 168 | (define make-uniform-vector dimensions->uniform-array) |
| 169 | ; (define uniform-vector-ref array-ref) |
| 170 | (define (uniform-vector-set! u i o) |
| 171 | (uniform-vector-set1! u o i)) |
| 172 | (define uniform-vector-fill! array-fill!) |
| 173 | (define uniform-vector-read! uniform-array-read!) |
| 174 | (define uniform-vector-write uniform-array-write) |
| 175 | |
| 176 | (define (make-array fill . args) |
| 177 | (dimensions->uniform-array args () fill)) |
| 178 | (define (make-uniform-array prot . args) |
| 179 | (dimensions->uniform-array args prot)) |
| 180 | (define (list->array ndim lst) |
| 181 | (list->uniform-array ndim '() lst)) |
| 182 | (define (list->uniform-vector prot lst) |
| 183 | (list->uniform-array 1 prot lst)) |
| 184 | (define (array-shape a) |
| 185 | (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) |
| 186 | (array-dimensions a)))) |
| 187 | |
| 188 | \f |
| 189 | ;;; {Keywords} |
| 190 | ;;; |
| 191 | |
| 192 | (define (symbol->keyword symbol) |
| 193 | (make-keyword-from-dash-symbol (symbol-append '- symbol))) |
| 194 | |
| 195 | (define (keyword->symbol kw) |
| 196 | (let ((sym (keyword-dash-symbol kw))) |
| 197 | (string->symbol (substring sym 1 (length sym))))) |
| 198 | |
| 199 | (define (kw-arg-ref args kw) |
| 200 | (let ((rem (member kw args))) |
| 201 | (and rem (pair? (cdr rem)) (cadr rem)))) |
| 202 | |
| 203 | \f |
| 204 | ;;; {Print} |
| 205 | ;;; MDJ 960919 <djurfeldt@nada.kth.se>: This code will probably be |
| 206 | ;;; removed before the first release of Guile. Later releases may |
| 207 | ;;; contain more fancy printing code. |
| 208 | |
| 209 | (define (print obj . args) |
| 210 | (let ((default-args (list (current-output-port) 0 0 default-print-style #f))) |
| 211 | (apply-to-args (append args (list-cdr-ref default-args (length args))) |
| 212 | (lambda (port depth length style table) |
| 213 | (cond |
| 214 | ((and table (print-table-ref table obj)) |
| 215 | ((print-style-tag-hook style 'eq-val) |
| 216 | obj port depth length style table)) |
| 217 | (else |
| 218 | (and table (print-table-add! table obj)) |
| 219 | (cond |
| 220 | ((print-style-max-depth? style depth) |
| 221 | ((print-style-excess-depth-hook style))) |
| 222 | ((print-style-max-length? style length) |
| 223 | ((print-style-excess-length-hook style))) |
| 224 | (else |
| 225 | ((print-style-hook style obj) |
| 226 | obj port depth length style table))))))))) |
| 227 | |
| 228 | (define (make-print-style) (make-vector 59 '())) |
| 229 | |
| 230 | (define (extend-print-style! style utag printer) |
| 231 | (hashq-set! style utag printer)) |
| 232 | |
| 233 | (define (print-style-hook style obj) |
| 234 | (let ((type-tag (tag obj))) |
| 235 | (or (hashq-ref style type-tag) |
| 236 | (hashq-ref style (logand type-tag 255)) |
| 237 | print-obj))) |
| 238 | |
| 239 | (define (print-style-tag-hook style type-tag) |
| 240 | (or (hashq-ref style type-tag) |
| 241 | print-obj)) |
| 242 | |
| 243 | (define (print-style-max-depth? style d) #f) |
| 244 | (define (print-style-max-length? style l) #f) |
| 245 | (define (print-style-excess-length-hook style) |
| 246 | (hashq-ref style 'excess-length-hook)) |
| 247 | (define (print-style-excess-depth-hook style) |
| 248 | (hashq-ref style 'excess-depth-hook)) |
| 249 | |
| 250 | (define (make-print-table) (make-vector 59 '())) |
| 251 | (define (print-table-ref table obj) (hashq-ref table obj)) |
| 252 | (define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref))) |
| 253 | |
| 254 | (define (print-obj obj port depth length style table) (write obj port)) |
| 255 | |
| 256 | (define (print-pair pair port depth length style table) |
| 257 | (if (= 0 length) |
| 258 | (display #\( port)) |
| 259 | |
| 260 | (print (car pair) port (+ 1 depth) 0 style table) |
| 261 | |
| 262 | (cond |
| 263 | ((and (pair? (cdr pair)) |
| 264 | (or (not table) |
| 265 | (not (print-table-ref table (cdr pair))))) |
| 266 | |
| 267 | (display #\space port) |
| 268 | (print (cdr pair) port depth (+ 1 length) style table)) |
| 269 | |
| 270 | ((null? (cdr pair)) (display #\) port)) |
| 271 | |
| 272 | (else (display " . " port) |
| 273 | (print (cdr pair) port (+ 1 depth) 0 |
| 274 | style table) |
| 275 | (display #\) port)))) |
| 276 | |
| 277 | (define (print-vector obj port depth length style table) |
| 278 | (if (= 0 length) |
| 279 | (cond |
| 280 | ((weak-key-hash-table? obj) (display "#wh(" port)) |
| 281 | ((weak-value-hash-table? obj) (display "#whv(" port)) |
| 282 | ((doubly-weak-hash-table? obj) (display "#whd(" port)) |
| 283 | (else (display "#(" port)))) |
| 284 | |
| 285 | (if (< length (vector-length obj)) |
| 286 | (print (vector-ref obj length) port (+ 1 depth) 0 style table)) |
| 287 | |
| 288 | (cond |
| 289 | ((>= (+ 1 length) (vector-length obj)) (display #\) port)) |
| 290 | (else (display #\space port) |
| 291 | (print obj port depth |
| 292 | (+ 1 length) |
| 293 | style table)))) |
| 294 | |
| 295 | (define default-print-style (make-print-style)) |
| 296 | |
| 297 | (extend-print-style! default-print-style utag_vector print-vector) |
| 298 | (extend-print-style! default-print-style utag_wvect print-vector) |
| 299 | (extend-print-style! default-print-style utag_pair print-pair) |
| 300 | (extend-print-style! default-print-style 'eq-val |
| 301 | (lambda (obj port depth length style table) |
| 302 | (if (symbol? obj) |
| 303 | (display obj) |
| 304 | (begin |
| 305 | (display "##" port) |
| 306 | (display (print-table-ref table obj)))))) |
| 307 | |
| 308 | \f |
| 309 | ;;; {Records} |
| 310 | ;;; |
| 311 | |
| 312 | (define record-type-vtable (make-vtable-vtable "prpr" 0)) |
| 313 | |
| 314 | (define (record-type? obj) |
| 315 | (and (struct? obj) (eq? record-type-vtable (struct-vtable obj)))) |
| 316 | |
| 317 | (define (make-record-type type-name fields . opt) |
| 318 | (let ((printer-fn (and (pair? opt) (car opt)))) |
| 319 | (let ((struct (make-struct record-type-vtable 0 |
| 320 | (make-struct-layout |
| 321 | (apply symbol-append |
| 322 | (map (lambda (f) "pw") fields))) |
| 323 | type-name |
| 324 | (copy-tree fields)))) |
| 325 | ;; !!! leaks printer functions |
| 326 | ;; MDJ 960919 <djurfeldt@nada.kth.se>: *fixme* need to make it |
| 327 | ;; possible to print records nicely. |
| 328 | ;(if printer-fn |
| 329 | ; (extend-print-style! default-print-style |
| 330 | ; (logior utag_struct_base (ash (struct-vtable-tag struct) 8)) |
| 331 | ; printer-fn)) |
| 332 | struct))) |
| 333 | |
| 334 | (define (record-type-name obj) |
| 335 | (if (record-type? obj) |
| 336 | (struct-ref obj struct-vtable-offset) |
| 337 | (error 'not-a-record-type obj))) |
| 338 | |
| 339 | (define (record-type-fields obj) |
| 340 | (if (record-type? obj) |
| 341 | (struct-ref obj (+ 1 struct-vtable-offset)) |
| 342 | (error 'not-a-record-type obj))) |
| 343 | |
| 344 | (define (record-constructor rtd . opt) |
| 345 | (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd)))) |
| 346 | (eval `(lambda ,field-names |
| 347 | (make-struct ',rtd 0 ,@(map (lambda (f) |
| 348 | (if (memq f field-names) |
| 349 | f |
| 350 | #f)) |
| 351 | (record-type-fields rtd))))))) |
| 352 | |
| 353 | (define (record-predicate rtd) |
| 354 | (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) |
| 355 | |
| 356 | (define (record-accessor rtd field-name) |
| 357 | (let* ((pos (list-index (record-type-fields rtd) field-name))) |
| 358 | (if (not pos) |
| 359 | (error 'no-such-field field-name)) |
| 360 | (eval `(lambda (obj) |
| 361 | (and (eq? ',rtd (record-type-descriptor obj)) |
| 362 | (struct-ref obj ,pos)))))) |
| 363 | |
| 364 | (define (record-modifier rtd field-name) |
| 365 | (let* ((pos (list-index (record-type-fields rtd) field-name))) |
| 366 | (if (not pos) |
| 367 | (error 'no-such-field field-name)) |
| 368 | (eval `(lambda (obj val) |
| 369 | (and (eq? ',rtd (record-type-descriptor obj)) |
| 370 | (struct-set! obj ,pos val)))))) |
| 371 | |
| 372 | |
| 373 | (define (record? obj) |
| 374 | (and (struct? obj) (record-type? (struct-vtable obj)))) |
| 375 | |
| 376 | (define (record-type-descriptor obj) |
| 377 | (if (struct? obj) |
| 378 | (struct-vtable obj) |
| 379 | (error 'not-a-record obj))) |
| 380 | |
| 381 | (provide 'record) |
| 382 | |
| 383 | \f |
| 384 | ;;; {Booleans} |
| 385 | ;;; |
| 386 | |
| 387 | (define (->bool x) (not (not x))) |
| 388 | |
| 389 | \f |
| 390 | ;;; {Symbols} |
| 391 | ;;; |
| 392 | |
| 393 | (define (symbol-append . args) |
| 394 | (string->symbol (apply string-append args))) |
| 395 | |
| 396 | (define (list->symbol . args) |
| 397 | (string->symbol (apply list->string args))) |
| 398 | |
| 399 | (define (symbol . args) |
| 400 | (string->symbol (apply string args))) |
| 401 | |
| 402 | (define (obarray-symbol-append ob . args) |
| 403 | (string->obarray-symbol (apply string-append ob args))) |
| 404 | |
| 405 | (define obarray-gensym |
| 406 | (let ((n -1)) |
| 407 | (lambda (obarray . opt) |
| 408 | (if (null? opt) |
| 409 | (set! opt '(%%gensym))) |
| 410 | (let loop ((proposed-name (apply string-append opt))) |
| 411 | (if (string->obarray-symbol obarray proposed-name #t) |
| 412 | (loop (apply string-append (append opt (begin (set! n (1+ n)) (list (number->string n)))))) |
| 413 | (string->obarray-symbol obarray proposed-name)))))) |
| 414 | |
| 415 | (define (gensym . args) (apply obarray-gensym #f args)) |
| 416 | |
| 417 | \f |
| 418 | ;;; {Lists} |
| 419 | ;;; |
| 420 | |
| 421 | (define (list-index l k) |
| 422 | (let loop ((n 0) |
| 423 | (l l)) |
| 424 | (and (not (null? l)) |
| 425 | (if (eq? (car l) k) |
| 426 | n |
| 427 | (loop (+ n 1) (cdr l)))))) |
| 428 | |
| 429 | (define (make-list n init) |
| 430 | (let loop ((answer '()) |
| 431 | (n n)) |
| 432 | (if (<= n 0) |
| 433 | answer |
| 434 | (loop (cons init answer) (- n 1))))) |
| 435 | |
| 436 | |
| 437 | \f |
| 438 | ;;; {and-map, or-map, and map-in-order} |
| 439 | ;;; |
| 440 | ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) |
| 441 | ;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) |
| 442 | ;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst. |
| 443 | ;;; |
| 444 | |
| 445 | ;; and-map f l |
| 446 | ;; |
| 447 | ;; Apply f to successive elements of l until exhaustion or f returns #f. |
| 448 | ;; If returning early, return #f. Otherwise, return the last value returned |
| 449 | ;; by f. If f has never been called because l is empty, return #t. |
| 450 | ;; |
| 451 | (define (and-map f lst) |
| 452 | (let loop ((result #t) |
| 453 | (l lst)) |
| 454 | (and result |
| 455 | (or (and (null? l) |
| 456 | result) |
| 457 | (loop (f (car l)) (cdr l)))))) |
| 458 | |
| 459 | ;; or-map f l |
| 460 | ;; |
| 461 | ;; Apply f to successive elements of l until exhaustion or while f returns #f. |
| 462 | ;; If returning early, return the return value of f. |
| 463 | ;; |
| 464 | (define (or-map f lst) |
| 465 | (let loop ((result #f) |
| 466 | (l lst)) |
| 467 | (or result |
| 468 | (and (not (null? l)) |
| 469 | (loop (f (car l)) (cdr l)))))) |
| 470 | |
| 471 | ;; map-in-order |
| 472 | ;; |
| 473 | ;; Like map, but guaranteed to process the list in order. |
| 474 | ;; |
| 475 | (define (map-in-order fn l) |
| 476 | (if (null? l) |
| 477 | '() |
| 478 | (cons (fn (car l)) |
| 479 | (map-in-order fn (cdr l))))) |
| 480 | |
| 481 | \f |
| 482 | ;;; {Files} |
| 483 | ;;; !!!! these should be implemented using Tcl commands, not fports. |
| 484 | ;;; |
| 485 | |
| 486 | (define (feature? feature) |
| 487 | (and (memq feature *features*) #t)) |
| 488 | |
| 489 | ;; Using the vector returned by stat directly is probably not a good |
| 490 | ;; idea (it could just as well be a record). Hence some accessors. |
| 491 | (define (stat:dev f) (vector-ref f 0)) |
| 492 | (define (stat:ino f) (vector-ref f 1)) |
| 493 | (define (stat:mode f) (vector-ref f 2)) |
| 494 | (define (stat:nlink f) (vector-ref f 3)) |
| 495 | (define (stat:uid f) (vector-ref f 4)) |
| 496 | (define (stat:gid f) (vector-ref f 5)) |
| 497 | (define (stat:rdev f) (vector-ref f 6)) |
| 498 | (define (stat:size f) (vector-ref f 7)) |
| 499 | (define (stat:atime f) (vector-ref f 8)) |
| 500 | (define (stat:mtime f) (vector-ref f 9)) |
| 501 | (define (stat:ctime f) (vector-ref f 10)) |
| 502 | (define (stat:blksize f) (vector-ref f 11)) |
| 503 | (define (stat:blocks f) (vector-ref f 12)) |
| 504 | |
| 505 | ;; derived from stat mode. |
| 506 | (define (stat:type f) (vector-ref f 13)) |
| 507 | (define (stat:perms f) (vector-ref f 14)) |
| 508 | |
| 509 | (define file-exists? |
| 510 | (if (feature? 'posix) |
| 511 | (lambda (str) |
| 512 | (access? str F_OK)) |
| 513 | (lambda (str) |
| 514 | (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ)) |
| 515 | (lambda args #f)))) |
| 516 | (if port (begin (close-port port) #t) |
| 517 | #f))))) |
| 518 | |
| 519 | (define file-is-directory? |
| 520 | (if (feature? 'i/o-extensions) |
| 521 | (lambda (str) |
| 522 | (eq? (stat:type (stat str)) 'directory)) |
| 523 | (lambda (str) |
| 524 | (display str) |
| 525 | (newline) |
| 526 | (let ((port (catch 'system-error |
| 527 | (lambda () (open-file (string-append str "/.") |
| 528 | OPEN_READ)) |
| 529 | (lambda args #f)))) |
| 530 | (if port (begin (close-port port) #t) |
| 531 | #f))))) |
| 532 | |
| 533 | (define (has-suffix? str suffix) |
| 534 | (let ((sufl (string-length suffix)) |
| 535 | (sl (string-length str))) |
| 536 | (and (> sl sufl) |
| 537 | (string=? (substring str (- sl sufl) sl) suffix)))) |
| 538 | |
| 539 | \f |
| 540 | ;;; {Error Handling} |
| 541 | ;;; |
| 542 | |
| 543 | (define (error . args) |
| 544 | (save-stack) |
| 545 | (if (null? args) |
| 546 | (scm-error 'misc-error #f "?" #f #f) |
| 547 | (let loop ((msg "%s") |
| 548 | (rest (cdr args))) |
| 549 | (if (not (null? rest)) |
| 550 | (loop (string-append msg " %S") |
| 551 | (cdr rest)) |
| 552 | (scm-error 'misc-error #f msg args #f))))) |
| 553 | |
| 554 | (define (scm-error key subr message args rest) |
| 555 | (throw key subr message args rest)) |
| 556 | |
| 557 | ;; bad-throw is the hook that is called upon a throw to a an unhandled |
| 558 | ;; key (unless the throw has four arguments, in which case |
| 559 | ;; it's usually interpreted as an error throw.) |
| 560 | ;; If the key has a default handler (a throw-handler-default property), |
| 561 | ;; it is applied to the throw. |
| 562 | ;; |
| 563 | (define (bad-throw key . args) |
| 564 | (let ((default (symbol-property key 'throw-handler-default))) |
| 565 | (or (and default (apply default key args)) |
| 566 | (apply error "unhandled-exception:" key args)))) |
| 567 | |
| 568 | ;; mostly obsolete. |
| 569 | ;; A number of internally defined error types were represented |
| 570 | ;; as integers. Here is the mapping to symbolic names |
| 571 | ;; and error messages. |
| 572 | ;; |
| 573 | ;(define %%system-errors |
| 574 | ; '((-1 UNKNOWN "Unknown error") |
| 575 | ; (0 ARGn "Wrong type argument to ") |
| 576 | ; (1 ARG1 "Wrong type argument in position 1 to ") |
| 577 | ; (2 ARG2 "Wrong type argument in position 2 to ") |
| 578 | ; (3 ARG3 "Wrong type argument in position 3 to ") |
| 579 | ; (4 ARG4 "Wrong type argument in position 4 to ") |
| 580 | ; (5 ARG5 "Wrong type argument in position 5 to ") |
| 581 | ; (6 ARG5 "Wrong type argument in position 5 to ") |
| 582 | ; (7 ARG5 "Wrong type argument in position 5 to ") |
| 583 | ; (8 WNA "Wrong number of arguments to ") |
| 584 | ; (9 OVFLOW "Numerical overflow to ") |
| 585 | ; (10 OUTOFRANGE "Argument out of range to ") |
| 586 | ; (11 NALLOC "Could not allocate to ") |
| 587 | ; (12 STACK_OVFLOW "Stack overflow") |
| 588 | ; (13 EXIT "Exit (internal error?).") |
| 589 | ; (14 HUP_SIGNAL "hang-up") |
| 590 | ; (15 INT_SIGNAL "user interrupt") |
| 591 | ; (16 FPE_SIGNAL "arithmetic error") |
| 592 | ; (17 BUS_SIGNAL "bus error") |
| 593 | ; (18 SEGV_SIGNAL "segmentation violation") |
| 594 | ; (19 ALRM_SIGNAL "alarm") |
| 595 | ; (20 GC_SIGNAL "gc") |
| 596 | ; (21 TICK_SIGNAL "tick"))) |
| 597 | |
| 598 | |
| 599 | (define (timer-thunk) #t) |
| 600 | (define (gc-thunk) #t) |
| 601 | (define (alarm-thunk) #t) |
| 602 | |
| 603 | (define (signal-handler n) |
| 604 | (let* ( |
| 605 | ;; these numbers are set in libguile, not the same as those |
| 606 | ;; interned in posix.c for SIGSEGV etc. |
| 607 | ;; |
| 608 | (signal-messages `((14 . "hang-up") |
| 609 | (15 . "user interrupt") |
| 610 | (16 . "arithmetic error") |
| 611 | (17 . "bus error") |
| 612 | (18 . "segmentation violation")))) |
| 613 | (cond |
| 614 | ((= n 21) (unmask-signals) (timer-thunk)) |
| 615 | ((= n 20) (unmask-signals) (gc-thunk)) |
| 616 | ((= n 19) (unmask-signals) (alarm-thunk)) |
| 617 | (else (set! the-last-stack |
| 618 | (make-stack #t |
| 619 | (list-ref (list %hup-thunk |
| 620 | %int-thunk |
| 621 | %fpe-thunk |
| 622 | %bus-thunk |
| 623 | %segv-thunk) |
| 624 | (- n 14)) |
| 625 | 1)) |
| 626 | (set! stack-saved? #t) |
| 627 | (if (not (and (memq 'debug (debug-options-interface)) |
| 628 | (eq? (stack-id the-last-stack) 'repl-stack))) |
| 629 | (set! the-last-stack #f)) |
| 630 | (unmask-signals) |
| 631 | (let ((sig-pair (assoc n signal-messages))) |
| 632 | (scm-error 'error-signal #f |
| 633 | (cdr (or sig-pair |
| 634 | (cons n "Unknown signal: %s"))) |
| 635 | (if sig-pair |
| 636 | #f |
| 637 | (list n)) |
| 638 | (list n))))))) |
| 639 | |
| 640 | \f |
| 641 | ;;; {Non-polymorphic versions of POSIX functions} |
| 642 | |
| 643 | (define (getgrnam name) (getgr name)) |
| 644 | (define (getgrgid id) (getgr id)) |
| 645 | (define (gethostbyaddr addr) (gethost addr)) |
| 646 | (define (gethostbyname name) (gethost name)) |
| 647 | (define (getnetbyaddr addr) (getnet addr)) |
| 648 | (define (getnetbyname name) (getnet name)) |
| 649 | (define (getprotobyname name) (getproto name)) |
| 650 | (define (getprotobynumber addr) (getproto addr)) |
| 651 | (define (getpwnam name) (getpw name)) |
| 652 | (define (getpwuid uid) (getpw uid)) |
| 653 | (define (getservbyname name proto) (%getserv name proto)) |
| 654 | (define (getservbyport port proto) (%getserv port proto)) |
| 655 | (define (endgrent) (setgr)) |
| 656 | (define (endhostent) (sethost)) |
| 657 | (define (endnetent) (setnet)) |
| 658 | (define (endprotoent) (setproto)) |
| 659 | (define (endpwent) (setpw)) |
| 660 | (define (endservent) (setserv)) |
| 661 | (define (file-position . args) (apply ftell args)) |
| 662 | (define (file-set-position . args) (apply fseek args)) |
| 663 | (define (getgrent) (getgr)) |
| 664 | (define (gethostent) (gethost)) |
| 665 | (define (getnetent) (getnet)) |
| 666 | (define (getprotoent) (getproto)) |
| 667 | (define (getpwent) (getpw)) |
| 668 | (define (getservent) (getserv)) |
| 669 | (define (reopen-file . args) (apply freopen args)) |
| 670 | (define (setgrent arg) (setgr arg)) |
| 671 | (define (sethostent arg) (sethost arg)) |
| 672 | (define (setnetent arg) (setnet arg)) |
| 673 | (define (setprotoent arg) (setproto arg)) |
| 674 | (define (setpwent arg) (setpw arg)) |
| 675 | (define (setservent arg) (setserv arg)) |
| 676 | |
| 677 | (define (move->fdes port fd) |
| 678 | (primitive-move->fdes port fd) |
| 679 | (set-port-revealed! port 1) |
| 680 | port) |
| 681 | |
| 682 | (define (release-port-handle port) |
| 683 | (let ((revealed (port-revealed port))) |
| 684 | (if (> revealed 0) |
| 685 | (set-port-revealed! port (- revealed 1))))) |
| 686 | |
| 687 | \f |
| 688 | ;;; {Load Paths} |
| 689 | ;;; |
| 690 | |
| 691 | ;;; Here for backward compatability |
| 692 | ;; |
| 693 | (define scheme-file-suffix (lambda () ".scm")) |
| 694 | |
| 695 | (define (in-vicinity vicinity file) |
| 696 | (let ((tail (let ((len (string-length vicinity))) |
| 697 | (if (zero? len) #f |
| 698 | (string-ref vicinity (- len 1)))))) |
| 699 | (string-append vicinity |
| 700 | (if (eq? tail #\/) "" "/") |
| 701 | file))) |
| 702 | |
| 703 | \f |
| 704 | ;;; {Loading by paths} |
| 705 | |
| 706 | ;;; Load a Scheme source file named NAME, searching for it in the |
| 707 | ;;; directories listed in %load-path, and applying each of the file |
| 708 | ;;; name extensions listed in %load-extensions. |
| 709 | (define (load-from-path name) |
| 710 | (start-stack 'load-stack |
| 711 | (primitive-load-path name #t read-sharp))) |
| 712 | |
| 713 | |
| 714 | \f |
| 715 | ;;; {Transcendental Functions} |
| 716 | ;;; |
| 717 | ;;; Derived from "Transcen.scm", Complex trancendental functions for SCM. |
| 718 | ;;; Copyright (C) 1992, 1993 Jerry D. Hedden. |
| 719 | ;;; See the file `COPYING' for terms applying to this program. |
| 720 | ;;; |
| 721 | |
| 722 | (define (exp z) |
| 723 | (if (real? z) ($exp z) |
| 724 | (make-polar ($exp (real-part z)) (imag-part z)))) |
| 725 | |
| 726 | (define (log z) |
| 727 | (if (and (real? z) (>= z 0)) |
| 728 | ($log z) |
| 729 | (make-rectangular ($log (magnitude z)) (angle z)))) |
| 730 | |
| 731 | (define (sqrt z) |
| 732 | (if (real? z) |
| 733 | (if (negative? z) (make-rectangular 0 ($sqrt (- z))) |
| 734 | ($sqrt z)) |
| 735 | (make-polar ($sqrt (magnitude z)) (/ (angle z) 2)))) |
| 736 | |
| 737 | (define expt |
| 738 | (let ((integer-expt integer-expt)) |
| 739 | (lambda (z1 z2) |
| 740 | (cond ((exact? z2) |
| 741 | (integer-expt z1 z2)) |
| 742 | ((and (real? z2) (real? z1) (>= z1 0)) |
| 743 | ($expt z1 z2)) |
| 744 | (else |
| 745 | (exp (* z2 (log z1)))))))) |
| 746 | |
| 747 | (define (sinh z) |
| 748 | (if (real? z) ($sinh z) |
| 749 | (let ((x (real-part z)) (y (imag-part z))) |
| 750 | (make-rectangular (* ($sinh x) ($cos y)) |
| 751 | (* ($cosh x) ($sin y)))))) |
| 752 | (define (cosh z) |
| 753 | (if (real? z) ($cosh z) |
| 754 | (let ((x (real-part z)) (y (imag-part z))) |
| 755 | (make-rectangular (* ($cosh x) ($cos y)) |
| 756 | (* ($sinh x) ($sin y)))))) |
| 757 | (define (tanh z) |
| 758 | (if (real? z) ($tanh z) |
| 759 | (let* ((x (* 2 (real-part z))) |
| 760 | (y (* 2 (imag-part z))) |
| 761 | (w (+ ($cosh x) ($cos y)))) |
| 762 | (make-rectangular (/ ($sinh x) w) (/ ($sin y) w))))) |
| 763 | |
| 764 | (define (asinh z) |
| 765 | (if (real? z) ($asinh z) |
| 766 | (log (+ z (sqrt (+ (* z z) 1)))))) |
| 767 | |
| 768 | (define (acosh z) |
| 769 | (if (and (real? z) (>= z 1)) |
| 770 | ($acosh z) |
| 771 | (log (+ z (sqrt (- (* z z) 1)))))) |
| 772 | |
| 773 | (define (atanh z) |
| 774 | (if (and (real? z) (> z -1) (< z 1)) |
| 775 | ($atanh z) |
| 776 | (/ (log (/ (+ 1 z) (- 1 z))) 2))) |
| 777 | |
| 778 | (define (sin z) |
| 779 | (if (real? z) ($sin z) |
| 780 | (let ((x (real-part z)) (y (imag-part z))) |
| 781 | (make-rectangular (* ($sin x) ($cosh y)) |
| 782 | (* ($cos x) ($sinh y)))))) |
| 783 | (define (cos z) |
| 784 | (if (real? z) ($cos z) |
| 785 | (let ((x (real-part z)) (y (imag-part z))) |
| 786 | (make-rectangular (* ($cos x) ($cosh y)) |
| 787 | (- (* ($sin x) ($sinh y))))))) |
| 788 | (define (tan z) |
| 789 | (if (real? z) ($tan z) |
| 790 | (let* ((x (* 2 (real-part z))) |
| 791 | (y (* 2 (imag-part z))) |
| 792 | (w (+ ($cos x) ($cosh y)))) |
| 793 | (make-rectangular (/ ($sin x) w) (/ ($sinh y) w))))) |
| 794 | |
| 795 | (define (asin z) |
| 796 | (if (and (real? z) (>= z -1) (<= z 1)) |
| 797 | ($asin z) |
| 798 | (* -i (asinh (* +i z))))) |
| 799 | |
| 800 | (define (acos z) |
| 801 | (if (and (real? z) (>= z -1) (<= z 1)) |
| 802 | ($acos z) |
| 803 | (+ (/ (angle -1) 2) (* +i (asinh (* +i z)))))) |
| 804 | |
| 805 | (define (atan z . y) |
| 806 | (if (null? y) |
| 807 | (if (real? z) ($atan z) |
| 808 | (/ (log (/ (- +i z) (+ +i z))) +2i)) |
| 809 | ($atan2 z (car y)))) |
| 810 | |
| 811 | (set! abs magnitude) |
| 812 | |
| 813 | \f |
| 814 | ;;; {User Settable Hooks} |
| 815 | ;;; |
| 816 | ;;; Parts of the C code check the bindings of these variables. |
| 817 | ;;; |
| 818 | |
| 819 | (define ticks-interrupt #f) |
| 820 | (define user-interrupt #f) |
| 821 | (define alarm-interrupt #f) |
| 822 | (define out-of-storage #f) |
| 823 | (define could-not-open #f) |
| 824 | (define end-of-program #f) |
| 825 | (define hang-up #f) |
| 826 | (define arithmetic-error #f) |
| 827 | (define read-sharp #f) |
| 828 | |
| 829 | \f |
| 830 | |
| 831 | ;;; {Reader Extensions} |
| 832 | ;;; |
| 833 | |
| 834 | ;;; Reader code for various "#c" forms. |
| 835 | ;;; |
| 836 | |
| 837 | (define (parse-path-symbol s) |
| 838 | (define (separate-fields-discarding-char ch str ret) |
| 839 | (let loop ((fields '()) |
| 840 | (str str)) |
| 841 | (cond |
| 842 | ((string-rindex str ch) |
| 843 | => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields) |
| 844 | (make-shared-substring str 0 pos)))) |
| 845 | (else (ret (cons str fields)))))) |
| 846 | (separate-fields-discarding-char #\/ |
| 847 | s |
| 848 | (lambda (fields) |
| 849 | (map string->symbol fields)))) |
| 850 | |
| 851 | |
| 852 | (define (%read-sharp c port) |
| 853 | (define (barf) |
| 854 | (error "unknown # object" c)) |
| 855 | |
| 856 | (case c |
| 857 | ((#\/) (let ((look (peek-char port))) |
| 858 | (if (or (eof-object? look) |
| 859 | (and (char? look) |
| 860 | (or (char-whitespace? look) |
| 861 | (string-index ")" look)))) |
| 862 | '() |
| 863 | (parse-path-symbol (read port #t read-sharp))))) |
| 864 | ((#\') (read port #t read-sharp)) |
| 865 | ((#\.) (eval (read port #t read-sharp))) |
| 866 | ((#\b) (read:uniform-vector #t port)) |
| 867 | ((#\a) (read:uniform-vector #\a port)) |
| 868 | ((#\u) (read:uniform-vector 1 port)) |
| 869 | ((#\e) (read:uniform-vector -1 port)) |
| 870 | ((#\s) (read:uniform-vector 1.0 port)) |
| 871 | ((#\i) (read:uniform-vector 1/3 port)) |
| 872 | ((#\c) (read:uniform-vector 0+i port)) |
| 873 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) |
| 874 | (read:array c port)) |
| 875 | (else (barf)))) |
| 876 | |
| 877 | (define (read:array digit port) |
| 878 | (define chr0 (char->integer #\0)) |
| 879 | (let ((rank (let readnum ((val (- (char->integer digit) chr0))) |
| 880 | (if (char-numeric? (peek-char port)) |
| 881 | (readnum (+ (* 10 val) |
| 882 | (- (char->integer (read-char port)) chr0))) |
| 883 | val))) |
| 884 | (prot (if (eq? #\( (peek-char port)) |
| 885 | '() |
| 886 | (let ((c (read-char port))) |
| 887 | (case c ((#\b) #t) |
| 888 | ((#\a) #\a) |
| 889 | ((#\u) 1) |
| 890 | ((#\e) -1) |
| 891 | ((#\s) 1.0) |
| 892 | ((#\i) 1/3) |
| 893 | ((#\c) 0+i) |
| 894 | (else (error "read:array unknown option " c))))))) |
| 895 | (if (eq? (peek-char port) #\() |
| 896 | (list->uniform-array rank prot (read port #t read-sharp)) |
| 897 | (error "read:array list not found")))) |
| 898 | |
| 899 | (define (read:uniform-vector proto port) |
| 900 | (if (eq? #\( (peek-char port)) |
| 901 | (list->uniform-array 1 proto (read port #t read-sharp)) |
| 902 | (error "read:uniform-vector list not found"))) |
| 903 | |
| 904 | |
| 905 | (define read-sharp (lambda a (apply %read-sharp a))) |
| 906 | |
| 907 | |
| 908 | \f |
| 909 | ;;; {Dynamic Roots} |
| 910 | ;;; |
| 911 | |
| 912 | ; mystery integers passed dynamic root error handlers |
| 913 | (define repl-quit -1) |
| 914 | (define repl-abort -2) |
| 915 | |
| 916 | |
| 917 | \f |
| 918 | ;;; {Command Line Options} |
| 919 | ;;; |
| 920 | |
| 921 | (define (get-option argv kw-opts kw-args return) |
| 922 | (cond |
| 923 | ((null? argv) |
| 924 | (return #f #f argv)) |
| 925 | |
| 926 | ((or (not (eq? #\- (string-ref (car argv) 0))) |
| 927 | (eq? (string-length (car argv)) 1)) |
| 928 | (return 'normal-arg (car argv) (cdr argv))) |
| 929 | |
| 930 | ((eq? #\- (string-ref (car argv) 1)) |
| 931 | (let* ((kw-arg-pos (or (string-index (car argv) #\=) |
| 932 | (string-length (car argv)))) |
| 933 | (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos))) |
| 934 | (kw-opt? (member kw kw-opts)) |
| 935 | (kw-arg? (member kw kw-args)) |
| 936 | (arg (or (and (not (eq? kw-arg-pos (string-length (car argv)))) |
| 937 | (substring (car argv) |
| 938 | (+ kw-arg-pos 1) |
| 939 | (string-length (car argv)))) |
| 940 | (and kw-arg? |
| 941 | (begin (set! argv (cdr argv)) (car argv)))))) |
| 942 | (if (or kw-opt? kw-arg?) |
| 943 | (return kw arg (cdr argv)) |
| 944 | (return 'usage-error kw (cdr argv))))) |
| 945 | |
| 946 | (else |
| 947 | (let* ((char (substring (car argv) 1 2)) |
| 948 | (kw (symbol->keyword char))) |
| 949 | (cond |
| 950 | |
| 951 | ((member kw kw-opts) |
| 952 | (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) |
| 953 | (new-argv (if (= 0 (string-length rest-car)) |
| 954 | (cdr argv) |
| 955 | (cons (string-append "-" rest-car) (cdr argv))))) |
| 956 | (return kw #f new-argv))) |
| 957 | |
| 958 | ((member kw kw-args) |
| 959 | (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) |
| 960 | (arg (if (= 0 (string-length rest-car)) |
| 961 | (cadr argv) |
| 962 | rest-car)) |
| 963 | (new-argv (if (= 0 (string-length rest-car)) |
| 964 | (cddr argv) |
| 965 | (cdr argv)))) |
| 966 | (return kw arg new-argv))) |
| 967 | |
| 968 | (else (return 'usage-error kw argv))))))) |
| 969 | |
| 970 | (define (for-next-option proc argv kw-opts kw-args) |
| 971 | (let loop ((argv argv)) |
| 972 | (get-option argv kw-opts kw-args |
| 973 | (lambda (opt opt-arg argv) |
| 974 | (and opt (proc opt opt-arg argv loop)))))) |
| 975 | |
| 976 | (define (display-usage-report kw-desc) |
| 977 | (for-each |
| 978 | (lambda (kw) |
| 979 | (or (eq? (car kw) #t) |
| 980 | (eq? (car kw) 'else) |
| 981 | (let* ((opt-desc kw) |
| 982 | (help (cadr opt-desc)) |
| 983 | (opts (car opt-desc)) |
| 984 | (opts-proper (if (string? (car opts)) (cdr opts) opts)) |
| 985 | (arg-name (if (string? (car opts)) |
| 986 | (string-append "<" (car opts) ">") |
| 987 | "")) |
| 988 | (left-part (string-append |
| 989 | (with-output-to-string |
| 990 | (lambda () |
| 991 | (map (lambda (x) (display (keyword-symbol x)) (display " ")) |
| 992 | opts-proper))) |
| 993 | arg-name)) |
| 994 | (middle-part (if (and (< (length left-part) 30) |
| 995 | (< (length help) 40)) |
| 996 | (make-string (- 30 (length left-part)) #\ ) |
| 997 | "\n\t"))) |
| 998 | (display left-part) |
| 999 | (display middle-part) |
| 1000 | (display help) |
| 1001 | (newline)))) |
| 1002 | kw-desc)) |
| 1003 | |
| 1004 | |
| 1005 | |
| 1006 | (define (delq-all! obj l) |
| 1007 | (let ((answer (cons '() l))) |
| 1008 | (let loop ((pos answer)) |
| 1009 | (cond |
| 1010 | ((null? (cdr pos)) (cdr answer)) |
| 1011 | ((eq? (cadr pos) obj) (set-cdr! pos (cddr pos)) |
| 1012 | (loop pos)) |
| 1013 | (else (loop (cdr pos))))))) |
| 1014 | |
| 1015 | (define (transform-usage-lambda cases) |
| 1016 | (let* ((raw-usage (delq! 'else (map car cases))) |
| 1017 | (usage-sans-specials (map (lambda (x) |
| 1018 | (or (and (not (list? x)) x) |
| 1019 | (and (symbol? (car x)) #t) |
| 1020 | (and (boolean? (car x)) #t) |
| 1021 | x)) |
| 1022 | raw-usage)) |
| 1023 | (usage-desc (delq-all! #t usage-sans-specials)) |
| 1024 | (kw-desc (map car usage-desc)) |
| 1025 | (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc))) |
| 1026 | (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc))) |
| 1027 | (transmogrified-cases (map (lambda (case) |
| 1028 | (cons (let ((opts (car case))) |
| 1029 | (if (or (boolean? opts) (eq? 'else opts)) |
| 1030 | opts |
| 1031 | (cond |
| 1032 | ((symbol? (car opts)) opts) |
| 1033 | ((boolean? (car opts)) opts) |
| 1034 | ((string? (caar opts)) (cdar opts)) |
| 1035 | (else (car opts))))) |
| 1036 | (cdr case))) |
| 1037 | cases))) |
| 1038 | `(let ((%display-usage (lambda () (display-usage-report ',usage-desc)))) |
| 1039 | (lambda (%argv) |
| 1040 | (let %next-arg ((%argv %argv)) |
| 1041 | (get-option %argv |
| 1042 | ',kw-opts |
| 1043 | ',kw-args |
| 1044 | (lambda (%opt %arg %new-argv) |
| 1045 | (case %opt |
| 1046 | ,@ transmogrified-cases)))))))) |
| 1047 | |
| 1048 | |
| 1049 | \f |
| 1050 | |
| 1051 | ;;; {Low Level Modules} |
| 1052 | ;;; |
| 1053 | ;;; These are the low level data structures for modules. |
| 1054 | ;;; |
| 1055 | ;;; !!! warning: The interface to lazy binder procedures is going |
| 1056 | ;;; to be changed in an incompatible way to permit all the basic |
| 1057 | ;;; module ops to be virtualized. |
| 1058 | ;;; |
| 1059 | ;;; (make-module size use-list lazy-binding-proc) => module |
| 1060 | ;;; module-{obarray,uses,binder}[|-set!] |
| 1061 | ;;; (module? obj) => [#t|#f] |
| 1062 | ;;; (module-locally-bound? module symbol) => [#t|#f] |
| 1063 | ;;; (module-bound? module symbol) => [#t|#f] |
| 1064 | ;;; (module-symbol-locally-interned? module symbol) => [#t|#f] |
| 1065 | ;;; (module-symbol-interned? module symbol) => [#t|#f] |
| 1066 | ;;; (module-local-variable module symbol) => [#<variable ...> | #f] |
| 1067 | ;;; (module-variable module symbol) => [#<variable ...> | #f] |
| 1068 | ;;; (module-symbol-binding module symbol opt-value) |
| 1069 | ;;; => [ <obj> | opt-value | an error occurs ] |
| 1070 | ;;; (module-make-local-var! module symbol) => #<variable...> |
| 1071 | ;;; (module-add! module symbol var) => unspecified |
| 1072 | ;;; (module-remove! module symbol) => unspecified |
| 1073 | ;;; (module-for-each proc module) => unspecified |
| 1074 | ;;; (make-scm-module) => module ; a lazy copy of the symhash module |
| 1075 | ;;; (set-current-module module) => unspecified |
| 1076 | ;;; (current-module) => #<module...> |
| 1077 | ;;; |
| 1078 | ;;; |
| 1079 | |
| 1080 | \f |
| 1081 | ;;; {Printing Modules} |
| 1082 | ;; This is how modules are printed. You can re-define it. |
| 1083 | ;; |
| 1084 | (define (%print-module mod port depth length style table) |
| 1085 | (display "#<" port) |
| 1086 | (display (or (module-kind mod) "module") port) |
| 1087 | (let ((name (module-name mod))) |
| 1088 | (if name |
| 1089 | (begin |
| 1090 | (display " " port) |
| 1091 | (display name port)))) |
| 1092 | (display " " port) |
| 1093 | (display (number->string (object-address mod) 16) port) |
| 1094 | (display ">" port)) |
| 1095 | |
| 1096 | ;; module-type |
| 1097 | ;; |
| 1098 | ;; A module is characterized by an obarray in which local symbols |
| 1099 | ;; are interned, a list of modules, "uses", from which non-local |
| 1100 | ;; bindings can be inherited, and an optional lazy-binder which |
| 1101 | ;; is a (CLOSURE module symbol) which, as a last resort, can provide |
| 1102 | ;; bindings that would otherwise not be found locally in the module. |
| 1103 | ;; |
| 1104 | (define module-type |
| 1105 | (make-record-type 'module '(obarray uses binder eval-closure name kind) |
| 1106 | %print-module)) |
| 1107 | |
| 1108 | ;; make-module &opt size uses binder |
| 1109 | ;; |
| 1110 | ;; Create a new module, perhaps with a particular size of obarray, |
| 1111 | ;; initial uses list, or binding procedure. |
| 1112 | ;; |
| 1113 | (define make-module |
| 1114 | (lambda args |
| 1115 | |
| 1116 | (define (parse-arg index default) |
| 1117 | (if (> (length args) index) |
| 1118 | (list-ref args index) |
| 1119 | default)) |
| 1120 | |
| 1121 | (if (> (length args) 3) |
| 1122 | (error "Too many args to make-module." args)) |
| 1123 | |
| 1124 | (let ((size (parse-arg 0 1021)) |
| 1125 | (uses (parse-arg 1 '())) |
| 1126 | (binder (parse-arg 2 #f))) |
| 1127 | |
| 1128 | (if (not (integer? size)) |
| 1129 | (error "Illegal size to make-module." size)) |
| 1130 | (if (not (and (list? uses) |
| 1131 | (and-map module? uses))) |
| 1132 | (error "Incorrect use list." uses)) |
| 1133 | (if (and binder (not (procedure? binder))) |
| 1134 | (error |
| 1135 | "Lazy-binder expected to be a procedure or #f." binder)) |
| 1136 | |
| 1137 | (let ((module (module-constructor (make-vector size '()) |
| 1138 | uses binder #f #f #f))) |
| 1139 | |
| 1140 | ;; We can't pass this as an argument to module-constructor, |
| 1141 | ;; because we need it to close over a pointer to the module |
| 1142 | ;; itself. |
| 1143 | (set-module-eval-closure! module |
| 1144 | (lambda (symbol define?) |
| 1145 | (if define? |
| 1146 | (module-make-local-var! module symbol) |
| 1147 | (module-variable module symbol)))) |
| 1148 | |
| 1149 | module)))) |
| 1150 | |
| 1151 | (define module-constructor (record-constructor module-type)) |
| 1152 | (define module-obarray (record-accessor module-type 'obarray)) |
| 1153 | (define set-module-obarray! (record-modifier module-type 'obarray)) |
| 1154 | (define module-uses (record-accessor module-type 'uses)) |
| 1155 | (define set-module-uses! (record-modifier module-type 'uses)) |
| 1156 | (define module-binder (record-accessor module-type 'binder)) |
| 1157 | (define set-module-binder! (record-modifier module-type 'binder)) |
| 1158 | (define module-eval-closure (record-accessor module-type 'eval-closure)) |
| 1159 | (define set-module-eval-closure! (record-modifier module-type 'eval-closure)) |
| 1160 | (define module-name (record-accessor module-type 'name)) |
| 1161 | (define set-module-name! (record-modifier module-type 'name)) |
| 1162 | (define module-kind (record-accessor module-type 'kind)) |
| 1163 | (define set-module-kind! (record-modifier module-type 'kind)) |
| 1164 | (define module? (record-predicate module-type)) |
| 1165 | |
| 1166 | |
| 1167 | (define (eval-in-module exp module) |
| 1168 | (eval2 exp (module-eval-closure module))) |
| 1169 | |
| 1170 | \f |
| 1171 | ;;; {Module Searching in General} |
| 1172 | ;;; |
| 1173 | ;;; We sometimes want to look for properties of a symbol |
| 1174 | ;;; just within the obarray of one module. If the property |
| 1175 | ;;; holds, then it is said to hold ``locally'' as in, ``The symbol |
| 1176 | ;;; DISPLAY is locally rebound in the module `safe-guile'.'' |
| 1177 | ;;; |
| 1178 | ;;; |
| 1179 | ;;; Other times, we want to test for a symbol property in the obarray |
| 1180 | ;;; of M and, if it is not found there, try each of the modules in the |
| 1181 | ;;; uses list of M. This is the normal way of testing for some |
| 1182 | ;;; property, so we state these properties without qualification as |
| 1183 | ;;; in: ``The symbol 'fnord is interned in module M because it is |
| 1184 | ;;; interned locally in module M2 which is a member of the uses list |
| 1185 | ;;; of M.'' |
| 1186 | ;;; |
| 1187 | |
| 1188 | ;; module-search fn m |
| 1189 | ;; |
| 1190 | ;; return the first non-#f result of FN applied to M and then to |
| 1191 | ;; the modules in the uses of m, and so on recursively. If all applications |
| 1192 | ;; return #f, then so does this function. |
| 1193 | ;; |
| 1194 | (define (module-search fn m v) |
| 1195 | (define (loop pos) |
| 1196 | (and (pair? pos) |
| 1197 | (or (module-search fn (car pos) v) |
| 1198 | (loop (cdr pos))))) |
| 1199 | (or (fn m v) |
| 1200 | (loop (module-uses m)))) |
| 1201 | |
| 1202 | |
| 1203 | ;;; {Is a symbol bound in a module?} |
| 1204 | ;;; |
| 1205 | ;;; Symbol S in Module M is bound if S is interned in M and if the binding |
| 1206 | ;;; of S in M has been set to some well-defined value. |
| 1207 | ;;; |
| 1208 | |
| 1209 | ;; module-locally-bound? module symbol |
| 1210 | ;; |
| 1211 | ;; Is a symbol bound (interned and defined) locally in a given module? |
| 1212 | ;; |
| 1213 | (define (module-locally-bound? m v) |
| 1214 | (let ((var (module-local-variable m v))) |
| 1215 | (and var |
| 1216 | (variable-bound? var)))) |
| 1217 | |
| 1218 | ;; module-bound? module symbol |
| 1219 | ;; |
| 1220 | ;; Is a symbol bound (interned and defined) anywhere in a given module |
| 1221 | ;; or its uses? |
| 1222 | ;; |
| 1223 | (define (module-bound? m v) |
| 1224 | (module-search module-locally-bound? m v)) |
| 1225 | |
| 1226 | ;;; {Is a symbol interned in a module?} |
| 1227 | ;;; |
| 1228 | ;;; Symbol S in Module M is interned if S occurs in |
| 1229 | ;;; of S in M has been set to some well-defined value. |
| 1230 | ;;; |
| 1231 | ;;; It is possible to intern a symbol in a module without providing |
| 1232 | ;;; an initial binding for the corresponding variable. This is done |
| 1233 | ;;; with: |
| 1234 | ;;; (module-add! module symbol (make-undefined-variable)) |
| 1235 | ;;; |
| 1236 | ;;; In that case, the symbol is interned in the module, but not |
| 1237 | ;;; bound there. The unbound symbol shadows any binding for that |
| 1238 | ;;; symbol that might otherwise be inherited from a member of the uses list. |
| 1239 | ;;; |
| 1240 | |
| 1241 | (define (module-obarray-get-handle ob key) |
| 1242 | ((if (symbol? key) hashq-get-handle hash-get-handle) ob key)) |
| 1243 | |
| 1244 | (define (module-obarray-ref ob key) |
| 1245 | ((if (symbol? key) hashq-ref hash-ref) ob key)) |
| 1246 | |
| 1247 | (define (module-obarray-set! ob key val) |
| 1248 | ((if (symbol? key) hashq-set! hash-set!) ob key val)) |
| 1249 | |
| 1250 | (define (module-obarray-remove! ob key) |
| 1251 | ((if (symbol? key) hashq-remove! hash-remove!) ob key)) |
| 1252 | |
| 1253 | ;; module-symbol-locally-interned? module symbol |
| 1254 | ;; |
| 1255 | ;; is a symbol interned (not neccessarily defined) locally in a given module |
| 1256 | ;; or its uses? Interned symbols shadow inherited bindings even if |
| 1257 | ;; they are not themselves bound to a defined value. |
| 1258 | ;; |
| 1259 | (define (module-symbol-locally-interned? m v) |
| 1260 | (not (not (module-obarray-get-handle (module-obarray m) v)))) |
| 1261 | |
| 1262 | ;; module-symbol-interned? module symbol |
| 1263 | ;; |
| 1264 | ;; is a symbol interned (not neccessarily defined) anywhere in a given module |
| 1265 | ;; or its uses? Interned symbols shadow inherited bindings even if |
| 1266 | ;; they are not themselves bound to a defined value. |
| 1267 | ;; |
| 1268 | (define (module-symbol-interned? m v) |
| 1269 | (module-search module-symbol-locally-interned? m v)) |
| 1270 | |
| 1271 | |
| 1272 | ;;; {Mapping modules x symbols --> variables} |
| 1273 | ;;; |
| 1274 | |
| 1275 | ;; module-local-variable module symbol |
| 1276 | ;; return the local variable associated with a MODULE and SYMBOL. |
| 1277 | ;; |
| 1278 | ;;; This function is very important. It is the only function that can |
| 1279 | ;;; return a variable from a module other than the mutators that store |
| 1280 | ;;; new variables in modules. Therefore, this function is the location |
| 1281 | ;;; of the "lazy binder" hack. |
| 1282 | ;;; |
| 1283 | ;;; If symbol is defined in MODULE, and if the definition binds symbol |
| 1284 | ;;; to a variable, return that variable object. |
| 1285 | ;;; |
| 1286 | ;;; If the symbols is not found at first, but the module has a lazy binder, |
| 1287 | ;;; then try the binder. |
| 1288 | ;;; |
| 1289 | ;;; If the symbol is not found at all, return #f. |
| 1290 | ;;; |
| 1291 | (define (module-local-variable m v) |
| 1292 | ; (caddr |
| 1293 | ; (list m v |
| 1294 | (let ((b (module-obarray-ref (module-obarray m) v))) |
| 1295 | (or (and (variable? b) b) |
| 1296 | (and (module-binder m) |
| 1297 | ((module-binder m) m v #f))))) |
| 1298 | ;)) |
| 1299 | |
| 1300 | ;; module-variable module symbol |
| 1301 | ;; |
| 1302 | ;; like module-local-variable, except search the uses in the |
| 1303 | ;; case V is not found in M. |
| 1304 | ;; |
| 1305 | (define (module-variable m v) |
| 1306 | (module-search module-local-variable m v)) |
| 1307 | |
| 1308 | |
| 1309 | ;;; {Mapping modules x symbols --> bindings} |
| 1310 | ;;; |
| 1311 | ;;; These are similar to the mapping to variables, except that the |
| 1312 | ;;; variable is dereferenced. |
| 1313 | ;;; |
| 1314 | |
| 1315 | ;; module-symbol-binding module symbol opt-value |
| 1316 | ;; |
| 1317 | ;; return the binding of a variable specified by name within |
| 1318 | ;; a given module, signalling an error if the variable is unbound. |
| 1319 | ;; If the OPT-VALUE is passed, then instead of signalling an error, |
| 1320 | ;; return OPT-VALUE. |
| 1321 | ;; |
| 1322 | (define (module-symbol-local-binding m v . opt-val) |
| 1323 | (let ((var (module-local-variable m v))) |
| 1324 | (if var |
| 1325 | (variable-ref var) |
| 1326 | (if (not (null? opt-val)) |
| 1327 | (car opt-val) |
| 1328 | (error "Locally unbound variable." v))))) |
| 1329 | |
| 1330 | ;; module-symbol-binding module symbol opt-value |
| 1331 | ;; |
| 1332 | ;; return the binding of a variable specified by name within |
| 1333 | ;; a given module, signalling an error if the variable is unbound. |
| 1334 | ;; If the OPT-VALUE is passed, then instead of signalling an error, |
| 1335 | ;; return OPT-VALUE. |
| 1336 | ;; |
| 1337 | (define (module-symbol-binding m v . opt-val) |
| 1338 | (let ((var (module-variable m v))) |
| 1339 | (if var |
| 1340 | (variable-ref var) |
| 1341 | (if (not (null? opt-val)) |
| 1342 | (car opt-val) |
| 1343 | (error "Unbound variable." v))))) |
| 1344 | |
| 1345 | |
| 1346 | \f |
| 1347 | ;;; {Adding Variables to Modules} |
| 1348 | ;;; |
| 1349 | ;;; |
| 1350 | |
| 1351 | |
| 1352 | ;; module-make-local-var! module symbol |
| 1353 | ;; |
| 1354 | ;; ensure a variable for V in the local namespace of M. |
| 1355 | ;; If no variable was already there, then create a new and uninitialzied |
| 1356 | ;; variable. |
| 1357 | ;; |
| 1358 | (define (module-make-local-var! m v) |
| 1359 | (or (let ((b (module-obarray-ref (module-obarray m) v))) |
| 1360 | (and (variable? b) b)) |
| 1361 | (and (module-binder m) |
| 1362 | ((module-binder m) m v #t)) |
| 1363 | (begin |
| 1364 | (let ((answer (make-undefined-variable v))) |
| 1365 | (module-obarray-set! (module-obarray m) v answer) |
| 1366 | answer)))) |
| 1367 | |
| 1368 | ;; module-add! module symbol var |
| 1369 | ;; |
| 1370 | ;; ensure a particular variable for V in the local namespace of M. |
| 1371 | ;; |
| 1372 | (define (module-add! m v var) |
| 1373 | (if (not (variable? var)) |
| 1374 | (error "Bad variable to module-add!" var)) |
| 1375 | (module-obarray-set! (module-obarray m) v var)) |
| 1376 | |
| 1377 | ;; module-remove! |
| 1378 | ;; |
| 1379 | ;; make sure that a symbol is undefined in the local namespace of M. |
| 1380 | ;; |
| 1381 | (define (module-remove! m v) |
| 1382 | (module-obarray-remove! (module-obarray m) v)) |
| 1383 | |
| 1384 | (define (module-clear! m) |
| 1385 | (vector-fill! (module-obarray m) '())) |
| 1386 | |
| 1387 | ;; MODULE-FOR-EACH -- exported |
| 1388 | ;; |
| 1389 | ;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE). |
| 1390 | ;; |
| 1391 | (define (module-for-each proc module) |
| 1392 | (let ((obarray (module-obarray module))) |
| 1393 | (do ((index 0 (+ index 1)) |
| 1394 | (end (vector-length obarray))) |
| 1395 | ((= index end)) |
| 1396 | (for-each |
| 1397 | (lambda (bucket) |
| 1398 | (proc (car bucket) (cdr bucket))) |
| 1399 | (vector-ref obarray index))))) |
| 1400 | |
| 1401 | |
| 1402 | (define (module-map proc module) |
| 1403 | (let* ((obarray (module-obarray module)) |
| 1404 | (end (vector-length obarray))) |
| 1405 | |
| 1406 | (let loop ((i 0) |
| 1407 | (answer '())) |
| 1408 | (if (= i end) |
| 1409 | answer |
| 1410 | (loop (+ 1 i) |
| 1411 | (append! |
| 1412 | (map (lambda (bucket) |
| 1413 | (proc (car bucket) (cdr bucket))) |
| 1414 | (vector-ref obarray i)) |
| 1415 | answer)))))) |
| 1416 | \f |
| 1417 | |
| 1418 | ;;; {Low Level Bootstrapping} |
| 1419 | ;;; |
| 1420 | |
| 1421 | ;; make-root-module |
| 1422 | |
| 1423 | ;; A root module uses the symhash table (the system's privileged |
| 1424 | ;; obarray). Being inside a root module is like using SCM without |
| 1425 | ;; any module system. |
| 1426 | ;; |
| 1427 | |
| 1428 | |
| 1429 | (define (root-module-closure m s define?) |
| 1430 | (let ((bi (and (symbol-interned? #f s) |
| 1431 | (builtin-variable s)))) |
| 1432 | (and bi |
| 1433 | (or define? (variable-bound? bi)) |
| 1434 | (begin |
| 1435 | (module-add! m s bi) |
| 1436 | bi)))) |
| 1437 | |
| 1438 | (define (make-root-module) |
| 1439 | (make-module 1019 '() root-module-closure)) |
| 1440 | |
| 1441 | |
| 1442 | ;; make-scm-module |
| 1443 | |
| 1444 | ;; An scm module is a module into which the lazy binder copies |
| 1445 | ;; variable bindings from the system symhash table. The mapping is |
| 1446 | ;; one way only; newly introduced bindings in an scm module are not |
| 1447 | ;; copied back into the system symhash table (and can be used to override |
| 1448 | ;; bindings from the symhash table). |
| 1449 | ;; |
| 1450 | |
| 1451 | (define (make-scm-module) |
| 1452 | (make-module 1019 '() |
| 1453 | (lambda (m s define?) |
| 1454 | (let ((bi (and (symbol-interned? #f s) |
| 1455 | (builtin-variable s)))) |
| 1456 | (and bi |
| 1457 | (variable-bound? bi) |
| 1458 | (begin |
| 1459 | (module-add! m s bi) |
| 1460 | bi)))))) |
| 1461 | |
| 1462 | |
| 1463 | |
| 1464 | |
| 1465 | ;; the-module |
| 1466 | ;; |
| 1467 | (define the-module #f) |
| 1468 | |
| 1469 | ;; set-current-module module |
| 1470 | ;; |
| 1471 | ;; set the current module as viewed by the normalizer. |
| 1472 | ;; |
| 1473 | (define (set-current-module m) |
| 1474 | (set! the-module m) |
| 1475 | (if m |
| 1476 | (set! *top-level-lookup-closure* (module-eval-closure the-module)) |
| 1477 | (set! *top-level-lookup-closure* #f))) |
| 1478 | |
| 1479 | |
| 1480 | ;; current-module |
| 1481 | ;; |
| 1482 | ;; return the current module as viewed by the normalizer. |
| 1483 | ;; |
| 1484 | (define (current-module) the-module) |
| 1485 | \f |
| 1486 | ;;; {Module-based Loading} |
| 1487 | ;;; |
| 1488 | |
| 1489 | (define (save-module-excursion thunk) |
| 1490 | (let ((inner-module (current-module)) |
| 1491 | (outer-module #f)) |
| 1492 | (dynamic-wind (lambda () |
| 1493 | (set! outer-module (current-module)) |
| 1494 | (set-current-module inner-module) |
| 1495 | (set! inner-module #f)) |
| 1496 | thunk |
| 1497 | (lambda () |
| 1498 | (set! inner-module (current-module)) |
| 1499 | (set-current-module outer-module) |
| 1500 | (set! outer-module #f))))) |
| 1501 | |
| 1502 | (define basic-load load) |
| 1503 | |
| 1504 | (define (load-module . args) |
| 1505 | (save-module-excursion (lambda () (apply basic-load args)))) |
| 1506 | |
| 1507 | |
| 1508 | \f |
| 1509 | ;;; {MODULE-REF -- exported} |
| 1510 | ;; |
| 1511 | ;; Returns the value of a variable called NAME in MODULE or any of its |
| 1512 | ;; used modules. If there is no such variable, then if the optional third |
| 1513 | ;; argument DEFAULT is present, it is returned; otherwise an error is signaled. |
| 1514 | ;; |
| 1515 | (define (module-ref module name . rest) |
| 1516 | (let ((variable (module-variable module name))) |
| 1517 | (if (and variable (variable-bound? variable)) |
| 1518 | (variable-ref variable) |
| 1519 | (if (null? rest) |
| 1520 | (error "No variable named" name 'in module) |
| 1521 | (car rest) ; default value |
| 1522 | )))) |
| 1523 | |
| 1524 | ;; MODULE-SET! -- exported |
| 1525 | ;; |
| 1526 | ;; Sets the variable called NAME in MODULE (or in a module that MODULE uses) |
| 1527 | ;; to VALUE; if there is no such variable, an error is signaled. |
| 1528 | ;; |
| 1529 | (define (module-set! module name value) |
| 1530 | (let ((variable (module-variable module name))) |
| 1531 | (if variable |
| 1532 | (variable-set! variable value) |
| 1533 | (error "No variable named" name 'in module)))) |
| 1534 | |
| 1535 | ;; MODULE-DEFINE! -- exported |
| 1536 | ;; |
| 1537 | ;; Sets the variable called NAME in MODULE to VALUE; if there is no such |
| 1538 | ;; variable, it is added first. |
| 1539 | ;; |
| 1540 | (define (module-define! module name value) |
| 1541 | (let ((variable (module-local-variable module name))) |
| 1542 | (if variable |
| 1543 | (variable-set! variable value) |
| 1544 | (module-add! module name (make-variable value name))))) |
| 1545 | |
| 1546 | ;; MODULE-USE! module interface |
| 1547 | ;; |
| 1548 | ;; Add INTERFACE to the list of interfaces used by MODULE. |
| 1549 | ;; |
| 1550 | (define (module-use! module interface) |
| 1551 | (set-module-uses! module |
| 1552 | (cons interface (delq! interface (module-uses module))))) |
| 1553 | |
| 1554 | \f |
| 1555 | ;;; {Recursive Namespaces} |
| 1556 | ;;; |
| 1557 | ;;; |
| 1558 | ;;; A hierarchical namespace emerges if we consider some module to be |
| 1559 | ;;; root, and variables bound to modules as nested namespaces. |
| 1560 | ;;; |
| 1561 | ;;; The routines in this file manage variable names in hierarchical namespace. |
| 1562 | ;;; Each variable name is a list of elements, looked up in successively nested |
| 1563 | ;;; modules. |
| 1564 | ;;; |
| 1565 | ;;; (nested-ref some-root-module '(foo bar baz)) |
| 1566 | ;;; => <value of a variable named baz in the module bound to bar in |
| 1567 | ;;; the module bound to foo in some-root-module> |
| 1568 | ;;; |
| 1569 | ;;; |
| 1570 | ;;; There are: |
| 1571 | ;;; |
| 1572 | ;;; ;; a-root is a module |
| 1573 | ;;; ;; name is a list of symbols |
| 1574 | ;;; |
| 1575 | ;;; nested-ref a-root name |
| 1576 | ;;; nested-set! a-root name val |
| 1577 | ;;; nested-define! a-root name val |
| 1578 | ;;; nested-remove! a-root name |
| 1579 | ;;; |
| 1580 | ;;; |
| 1581 | ;;; (current-module) is a natural choice for a-root so for convenience there are |
| 1582 | ;;; also: |
| 1583 | ;;; |
| 1584 | ;;; local-ref name == nested-ref (current-module) name |
| 1585 | ;;; local-set! name val == nested-set! (current-module) name val |
| 1586 | ;;; local-define! name val == nested-define! (current-module) name val |
| 1587 | ;;; local-remove! name == nested-remove! (current-module) name |
| 1588 | ;;; |
| 1589 | |
| 1590 | |
| 1591 | (define (nested-ref root names) |
| 1592 | (let loop ((cur root) |
| 1593 | (elts names)) |
| 1594 | (cond |
| 1595 | ((null? elts) cur) |
| 1596 | ((not (module? cur)) #f) |
| 1597 | (else (loop (module-ref cur (car elts) #f) (cdr elts)))))) |
| 1598 | |
| 1599 | (define (nested-set! root names val) |
| 1600 | (let loop ((cur root) |
| 1601 | (elts names)) |
| 1602 | (if (null? (cdr elts)) |
| 1603 | (module-set! cur (car elts) val) |
| 1604 | (loop (module-ref cur (car elts)) (cdr elts))))) |
| 1605 | |
| 1606 | (define (nested-define! root names val) |
| 1607 | (let loop ((cur root) |
| 1608 | (elts names)) |
| 1609 | (if (null? (cdr elts)) |
| 1610 | (module-define! cur (car elts) val) |
| 1611 | (loop (module-ref cur (car elts)) (cdr elts))))) |
| 1612 | |
| 1613 | (define (nested-remove! root names) |
| 1614 | (let loop ((cur root) |
| 1615 | (elts names)) |
| 1616 | (if (null? (cdr elts)) |
| 1617 | (module-remove! cur (car elts)) |
| 1618 | (loop (module-ref cur (car elts)) (cdr elts))))) |
| 1619 | |
| 1620 | (define (local-ref names) (nested-ref (current-module) names)) |
| 1621 | (define (local-set! names val) (nested-set! (current-module) names val)) |
| 1622 | (define (local-define names val) (nested-define! (current-module) names val)) |
| 1623 | (define (local-remove names) (nested-remove! (current-module) names)) |
| 1624 | |
| 1625 | |
| 1626 | \f |
| 1627 | ;;; {#/app} |
| 1628 | ;;; |
| 1629 | ;;; The root of conventionally named objects not directly in the top level. |
| 1630 | ;;; |
| 1631 | ;;; #/app/modules |
| 1632 | ;;; #/app/modules/guile |
| 1633 | ;;; |
| 1634 | ;;; The directory of all modules and the standard root module. |
| 1635 | ;;; |
| 1636 | |
| 1637 | (define (module-public-interface m) (module-ref m '%module-public-interface #f)) |
| 1638 | (define (set-module-public-interface! m i) (module-define! m '%module-public-interface i)) |
| 1639 | (define the-root-module (make-root-module)) |
| 1640 | (define the-scm-module (make-scm-module)) |
| 1641 | (set-module-public-interface! the-root-module the-scm-module) |
| 1642 | (set-module-name! the-root-module 'the-root-module) |
| 1643 | (set-module-name! the-scm-module 'the-scm-module) |
| 1644 | |
| 1645 | (set-current-module the-root-module) |
| 1646 | |
| 1647 | (define app (make-module 31)) |
| 1648 | (local-define '(app modules) (make-module 31)) |
| 1649 | (local-define '(app modules guile) the-root-module) |
| 1650 | |
| 1651 | ;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module))) |
| 1652 | |
| 1653 | (define (resolve-module name) |
| 1654 | (let ((full-name (append '(app modules) name))) |
| 1655 | (let ((already (local-ref full-name))) |
| 1656 | (or already |
| 1657 | (begin |
| 1658 | (try-module-autoload name) |
| 1659 | (make-modules-in (current-module) full-name)))))) |
| 1660 | |
| 1661 | (define (beautify-user-module! module) |
| 1662 | (if (not (module-public-interface module)) |
| 1663 | (let ((interface (make-module 31))) |
| 1664 | (set-module-name! interface (module-name module)) |
| 1665 | (set-module-kind! interface 'interface) |
| 1666 | (set-module-public-interface! module interface))) |
| 1667 | (if (not (memq the-scm-module (module-uses module))) |
| 1668 | (set-module-uses! module (append (module-uses module) (list the-scm-module))))) |
| 1669 | |
| 1670 | (define (make-modules-in module name) |
| 1671 | (if (null? name) |
| 1672 | module |
| 1673 | (cond |
| 1674 | ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name)))) |
| 1675 | (else (let ((m (make-module 31))) |
| 1676 | (set-module-kind! m 'directory) |
| 1677 | (set-module-name! m (car name)) |
| 1678 | (module-define! module (car name) m) |
| 1679 | (make-modules-in m (cdr name))))))) |
| 1680 | |
| 1681 | (define (resolve-interface name) |
| 1682 | (let ((module (resolve-module name))) |
| 1683 | (and module (module-public-interface module)))) |
| 1684 | |
| 1685 | |
| 1686 | (define %autoloader-developer-mode #t) |
| 1687 | |
| 1688 | (define (process-define-module args) |
| 1689 | (let* ((module-id (car args)) |
| 1690 | (module (resolve-module module-id)) |
| 1691 | (kws (cdr args))) |
| 1692 | (beautify-user-module! module) |
| 1693 | (let loop ((kws kws)) |
| 1694 | (and (not (null? kws)) |
| 1695 | (case (car kws) |
| 1696 | ((:use-module) |
| 1697 | (if (not (pair? (cdr kws))) |
| 1698 | (error "unrecognized defmodule argument" kws)) |
| 1699 | (let* ((used-name (cadr kws)) |
| 1700 | (used-module (resolve-module used-name))) |
| 1701 | (if (not (module-ref used-module '%module-public-interface #f)) |
| 1702 | (begin |
| 1703 | ((if %autoloader-developer-mode warn error) "no code for module" used-module) |
| 1704 | (beautify-user-module! used-module))) |
| 1705 | (let ((interface (module-ref used-module '%module-public-interface #f))) |
| 1706 | (if (not interface) |
| 1707 | (error "missing interface for use-module" used-module)) |
| 1708 | (set-module-uses! module |
| 1709 | (append! (delq! interface (module-uses module)) |
| 1710 | (list interface))))) |
| 1711 | (loop (cddr kws))) |
| 1712 | |
| 1713 | (else (error "unrecognized defmodule argument" kws))))) |
| 1714 | module)) |
| 1715 | \f |
| 1716 | ;;; {Autoloading modules} |
| 1717 | |
| 1718 | (define autoloads-in-progress '()) |
| 1719 | |
| 1720 | (define (try-module-autoload module-name) |
| 1721 | |
| 1722 | (define (sfx name) (string-append name (scheme-file-suffix))) |
| 1723 | (let* ((reverse-name (reverse module-name)) |
| 1724 | (name (car reverse-name)) |
| 1725 | (dir-hint-module-name (reverse (cdr reverse-name))) |
| 1726 | (dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name)))) |
| 1727 | (resolve-module dir-hint-module-name) |
| 1728 | (and (not (autoload-done-or-in-progress? dir-hint name)) |
| 1729 | (let ((didit #f)) |
| 1730 | (dynamic-wind |
| 1731 | (lambda () (autoload-in-progress! dir-hint name)) |
| 1732 | (lambda () |
| 1733 | (let loop ((dirs %load-path)) |
| 1734 | (and (not (null? dirs)) |
| 1735 | (or |
| 1736 | (let ((d (car dirs)) |
| 1737 | (trys (list |
| 1738 | dir-hint |
| 1739 | (sfx dir-hint) |
| 1740 | (in-vicinity dir-hint name) |
| 1741 | (in-vicinity dir-hint (sfx name))))) |
| 1742 | (and (or-map (lambda (f) |
| 1743 | (let ((full (in-vicinity d f))) |
| 1744 | full |
| 1745 | (and (file-exists? full) |
| 1746 | (not (file-is-directory? full)) |
| 1747 | (begin |
| 1748 | (save-module-excursion |
| 1749 | (lambda () |
| 1750 | (load (string-append |
| 1751 | d "/" f)))) |
| 1752 | #t)))) |
| 1753 | trys) |
| 1754 | (begin |
| 1755 | (set! didit #t) |
| 1756 | #t))) |
| 1757 | (loop (cdr dirs)))))) |
| 1758 | (lambda () (set-autoloaded! dir-hint name didit))) |
| 1759 | didit)))) |
| 1760 | |
| 1761 | (define autoloads-done '((guile . guile))) |
| 1762 | |
| 1763 | (define (autoload-done-or-in-progress? p m) |
| 1764 | (let ((n (cons p m))) |
| 1765 | (->bool (or (member n autoloads-done) |
| 1766 | (member n autoloads-in-progress))))) |
| 1767 | |
| 1768 | (define (autoload-done! p m) |
| 1769 | (let ((n (cons p m))) |
| 1770 | (set! autoloads-in-progress |
| 1771 | (delete! n autoloads-in-progress)) |
| 1772 | (or (member n autoloads-done) |
| 1773 | (set! autoloads-done (cons n autoloads-done))))) |
| 1774 | |
| 1775 | (define (autoload-in-progress! p m) |
| 1776 | (let ((n (cons p m))) |
| 1777 | (set! autoloads-done |
| 1778 | (delete! n autoloads-done)) |
| 1779 | (set! autoloads-in-progress (cons n autoloads-in-progress)))) |
| 1780 | |
| 1781 | (define (set-autoloaded! p m done?) |
| 1782 | (if done? |
| 1783 | (autoload-done! p m) |
| 1784 | (let ((n (cons p m))) |
| 1785 | (set! autoloads-done (delete! n autoloads-done)) |
| 1786 | (set! autoloads-in-progress (delete! n autoloads-in-progress))))) |
| 1787 | |
| 1788 | |
| 1789 | |
| 1790 | |
| 1791 | \f |
| 1792 | ;;; {Macros} |
| 1793 | ;;; |
| 1794 | |
| 1795 | (define macro-table (make-weak-key-hash-table 523)) |
| 1796 | (define xformer-table (make-weak-key-hash-table 523)) |
| 1797 | |
| 1798 | (define (defmacro? m) (hashq-ref macro-table m)) |
| 1799 | (define (assert-defmacro?! m) (hashq-set! macro-table m #t)) |
| 1800 | (define (defmacro-transformer m) (hashq-ref xformer-table m)) |
| 1801 | (define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t)) |
| 1802 | |
| 1803 | (define defmacro:transformer |
| 1804 | (lambda (f) |
| 1805 | (let* ((xform (lambda (exp env) |
| 1806 | (copy-tree (apply f (cdr exp))))) |
| 1807 | (a (procedure->memoizing-macro xform))) |
| 1808 | (assert-defmacro?! a) |
| 1809 | (set-defmacro-transformer! a f) |
| 1810 | a))) |
| 1811 | |
| 1812 | |
| 1813 | (define defmacro |
| 1814 | (let ((defmacro-transformer |
| 1815 | (lambda (name parms . body) |
| 1816 | (let ((transformer `(lambda ,parms ,@body))) |
| 1817 | `(define ,name |
| 1818 | (,(lambda (transformer) |
| 1819 | (defmacro:transformer transformer)) |
| 1820 | ,transformer)))))) |
| 1821 | (defmacro:transformer defmacro-transformer))) |
| 1822 | |
| 1823 | (define defmacro:syntax-transformer |
| 1824 | (lambda (f) |
| 1825 | (procedure->syntax |
| 1826 | (lambda (exp env) |
| 1827 | (copy-tree (apply f (cdr exp))))))) |
| 1828 | |
| 1829 | (define (macroexpand-1 e) |
| 1830 | (cond |
| 1831 | ((pair? e) (let* ((a (car e)) |
| 1832 | (val (and (symbol? a) (defined? a) (eval a)))) |
| 1833 | (if (defmacro? val) |
| 1834 | (apply (defmacro-transformer val) (cdr e)) |
| 1835 | e))) |
| 1836 | (#t e))) |
| 1837 | |
| 1838 | (define (macroexpand e) |
| 1839 | (cond |
| 1840 | ((pair? e) (let* ((a (car e)) |
| 1841 | (val (and (symbol? a) (defined? a) (eval a)))) |
| 1842 | (if (defmacro? val) |
| 1843 | (macroexpand (apply (defmacro-transformer val) (cdr e))) |
| 1844 | e))) |
| 1845 | (#t e))) |
| 1846 | |
| 1847 | (define gentemp |
| 1848 | (let ((*gensym-counter* -1)) |
| 1849 | (lambda () |
| 1850 | (set! *gensym-counter* (+ *gensym-counter* 1)) |
| 1851 | (string->symbol |
| 1852 | (string-append "scm:G" (number->string *gensym-counter*)))))) |
| 1853 | |
| 1854 | |
| 1855 | \f |
| 1856 | |
| 1857 | ;;; {Running Repls} |
| 1858 | ;;; |
| 1859 | |
| 1860 | (define (repl read evaler print) |
| 1861 | (let loop ((source (read (current-input-port) #t read-sharp))) |
| 1862 | (print (evaler source)) |
| 1863 | (loop (read (current-input-port) #t read-sharp)))) |
| 1864 | |
| 1865 | ;; A provisional repl that acts like the SCM repl: |
| 1866 | ;; |
| 1867 | (define scm-repl-silent #f) |
| 1868 | (define (assert-repl-silence v) (set! scm-repl-silent v)) |
| 1869 | |
| 1870 | (define *unspecified* (if #f #f)) |
| 1871 | (define (unspecified? v) (eq? v *unspecified*)) |
| 1872 | |
| 1873 | (define scm-repl-print-unspecified #f) |
| 1874 | (define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v)) |
| 1875 | |
| 1876 | (define scm-repl-verbose #f) |
| 1877 | (define (assert-repl-verbosity v) (set! scm-repl-verbose v)) |
| 1878 | |
| 1879 | (define scm-repl-prompt #t) |
| 1880 | (define (assert-repl-prompt v) (set! scm-repl-prompt v)) |
| 1881 | |
| 1882 | (define the-prompt-string "guile> ") |
| 1883 | |
| 1884 | (define (error-catching-loop thunk) |
| 1885 | (define (loop first) |
| 1886 | (let ((next |
| 1887 | (catch #t |
| 1888 | (lambda () |
| 1889 | (lazy-catch #t |
| 1890 | (lambda () |
| 1891 | (dynamic-wind |
| 1892 | (lambda () (unmask-signals)) |
| 1893 | (lambda () |
| 1894 | (first) |
| 1895 | |
| 1896 | ;; This line is needed because mark doesn't do closures quite right. |
| 1897 | ;; Unreferenced locals should be collected. |
| 1898 | ;; |
| 1899 | (set! first #f) |
| 1900 | (let loop ((v (thunk))) |
| 1901 | (loop (thunk))) |
| 1902 | #f) |
| 1903 | (lambda () (mask-signals)))) |
| 1904 | |
| 1905 | (lambda args |
| 1906 | (save-stack 1) |
| 1907 | (apply throw args)))) |
| 1908 | |
| 1909 | (lambda (key . args) |
| 1910 | (case key |
| 1911 | ((quit) |
| 1912 | (force-output) |
| 1913 | #f) |
| 1914 | |
| 1915 | ((switch-repl) |
| 1916 | (apply throw 'switch-repl args)) |
| 1917 | |
| 1918 | ((abort) |
| 1919 | ;; This is one of the closures that require |
| 1920 | ;; (set! first #f) above |
| 1921 | ;; |
| 1922 | (lambda () |
| 1923 | (force-output) |
| 1924 | (display "ABORT: " (current-error-port)) |
| 1925 | (write args (current-error-port)) |
| 1926 | (newline (current-error-port)) |
| 1927 | (if (and (not has-shown-debugger-hint?) |
| 1928 | (not (memq 'backtrace (debug-options-interface))) |
| 1929 | (stack? the-last-stack)) |
| 1930 | (begin |
| 1931 | (newline (current-error-port)) |
| 1932 | (display "Type \"(backtrace)\" to get more information, |
| 1933 | or type \"$\" to enter the debugger.\n" (current-error-port)) |
| 1934 | (set! has-shown-debugger-hint? #t))) |
| 1935 | (set! stack-saved? #f))) |
| 1936 | |
| 1937 | (else |
| 1938 | ;; This is the other cons-leak closure... |
| 1939 | (lambda () |
| 1940 | (cond ((= (length args) 4) |
| 1941 | (apply handle-system-error key args)) |
| 1942 | (else |
| 1943 | (apply bad-throw key args)))))))))) |
| 1944 | (and next (loop next)))) |
| 1945 | (loop (lambda () #t))) |
| 1946 | |
| 1947 | (define the-last-stack #f) |
| 1948 | (define stack-saved? #f) |
| 1949 | |
| 1950 | (define (save-stack . narrowing) |
| 1951 | (cond (stack-saved?) |
| 1952 | ((not (memq 'debug (debug-options-interface))) |
| 1953 | (set! the-last-stack #f) |
| 1954 | (set! stack-saved? #t)) |
| 1955 | (else |
| 1956 | (set! the-last-stack |
| 1957 | (case (stack-id #t) |
| 1958 | ((repl-stack) |
| 1959 | (apply make-stack #t save-stack eval narrowing)) |
| 1960 | ((load-stack) |
| 1961 | (apply make-stack #t save-stack gsubr-apply narrowing)) |
| 1962 | ((tk-stack) |
| 1963 | (apply make-stack #t save-stack tk-stack-mark narrowing)) |
| 1964 | ((#t) |
| 1965 | (apply make-stack #t save-stack narrowing)) |
| 1966 | (else (let ((id (stack-id #t))) |
| 1967 | (and (procedure? id) |
| 1968 | (apply make-stack #t save-stack id narrowing)))))) |
| 1969 | (set! stack-saved? #t)))) |
| 1970 | |
| 1971 | (define before-error-hook #f) |
| 1972 | (define after-error-hook #f) |
| 1973 | (define before-backtrace-hook #f) |
| 1974 | (define after-backtrace-hook #f) |
| 1975 | |
| 1976 | (define has-shown-debugger-hint? #f) |
| 1977 | |
| 1978 | (define (handle-system-error key . args) |
| 1979 | (let ((cep (current-error-port))) |
| 1980 | (cond ((not (stack? the-last-stack))) |
| 1981 | ((memq 'backtrace (debug-options-interface)) |
| 1982 | (and before-backtrace-hook (before-backtrace-hook)) |
| 1983 | (newline cep) |
| 1984 | (display-backtrace the-last-stack cep) |
| 1985 | (newline cep) |
| 1986 | (and after-backtrace-hook (after-backtrace-hook)))) |
| 1987 | (and before-error-hook (before-error-hook)) |
| 1988 | (apply display-error the-last-stack cep args) |
| 1989 | (and after-error-hook (after-error-hook)) |
| 1990 | (force-output cep) |
| 1991 | (throw 'abort key))) |
| 1992 | |
| 1993 | (define (quit . args) |
| 1994 | (apply throw 'quit args)) |
| 1995 | |
| 1996 | (define has-shown-backtrace-hint? #f) |
| 1997 | |
| 1998 | (define (backtrace) |
| 1999 | (if the-last-stack |
| 2000 | (begin |
| 2001 | (newline) |
| 2002 | (display-backtrace the-last-stack (current-output-port)) |
| 2003 | (newline) |
| 2004 | (if (and (not has-shown-backtrace-hint?) |
| 2005 | (not (memq 'backtrace (debug-options-interface)))) |
| 2006 | (begin |
| 2007 | (display |
| 2008 | "Type \"(debug-enable 'backtrace)\" if you would like a backtrace |
| 2009 | automatically if an error occurs in the future.\n") |
| 2010 | (set! has-shown-backtrace-hint? #t)))) |
| 2011 | (display "No backtrace available.\n"))) |
| 2012 | |
| 2013 | (define (error-catching-repl r e p) |
| 2014 | (error-catching-loop (lambda () (p (e (r)))))) |
| 2015 | |
| 2016 | (define (gc-run-time) |
| 2017 | (cdr (assq 'gc-time-taken (gc-stats)))) |
| 2018 | |
| 2019 | (define before-read-hook #f) |
| 2020 | (define after-read-hook #f) |
| 2021 | |
| 2022 | (define (scm-style-repl) |
| 2023 | (letrec ( |
| 2024 | (start-gc-rt #f) |
| 2025 | (start-rt #f) |
| 2026 | (repl-report-reset (lambda () #f)) |
| 2027 | (repl-report-start-timing (lambda () |
| 2028 | (set! start-gc-rt (gc-run-time)) |
| 2029 | (set! start-rt (get-internal-run-time)))) |
| 2030 | (repl-report (lambda () |
| 2031 | (display ";;; ") |
| 2032 | (display (inexact->exact |
| 2033 | (* 1000 (/ (- (get-internal-run-time) start-rt) |
| 2034 | internal-time-units-per-second)))) |
| 2035 | (display " msec (") |
| 2036 | (display (inexact->exact |
| 2037 | (* 1000 (/ (- (gc-run-time) start-gc-rt) |
| 2038 | internal-time-units-per-second)))) |
| 2039 | (display " msec in gc)\n"))) |
| 2040 | (-read (lambda () |
| 2041 | (if scm-repl-prompt |
| 2042 | (begin |
| 2043 | (display the-prompt-string) |
| 2044 | (force-output) |
| 2045 | (repl-report-reset))) |
| 2046 | (and before-read-hook (before-read-hook)) |
| 2047 | (let ((val (read (current-input-port) #t read-sharp))) |
| 2048 | (and after-read-hook (after-read-hook)) |
| 2049 | (if (eof-object? val) |
| 2050 | (begin |
| 2051 | (if scm-repl-verbose |
| 2052 | (begin |
| 2053 | (newline) |
| 2054 | (display ";;; EOF -- quitting") |
| 2055 | (newline))) |
| 2056 | (quit 0))) |
| 2057 | val))) |
| 2058 | |
| 2059 | (-eval (lambda (sourc) |
| 2060 | (repl-report-start-timing) |
| 2061 | (start-stack 'repl-stack (eval sourc)))) |
| 2062 | |
| 2063 | (-print (lambda (result) |
| 2064 | (if (not scm-repl-silent) |
| 2065 | (begin |
| 2066 | (if (or scm-repl-print-unspecified |
| 2067 | (not (unspecified? result))) |
| 2068 | (begin |
| 2069 | (write result) |
| 2070 | (newline))) |
| 2071 | (if scm-repl-verbose |
| 2072 | (repl-report)) |
| 2073 | (force-output))))) |
| 2074 | |
| 2075 | (-quit (lambda () |
| 2076 | (if scm-repl-verbose |
| 2077 | (begin |
| 2078 | (display ";;; QUIT executed, repl exitting") |
| 2079 | (newline) |
| 2080 | (repl-report))) |
| 2081 | #t)) |
| 2082 | |
| 2083 | (-abort (lambda () |
| 2084 | (if scm-repl-verbose |
| 2085 | (begin |
| 2086 | (display ";;; ABORT executed.") |
| 2087 | (newline) |
| 2088 | (repl-report))) |
| 2089 | (repl -read -eval -print)))) |
| 2090 | |
| 2091 | (error-catching-repl -read |
| 2092 | -eval |
| 2093 | -print))) |
| 2094 | |
| 2095 | (define (stand-alone-repl) |
| 2096 | (let ((oport (current-input-port))) |
| 2097 | (set-current-input-port *stdin*) |
| 2098 | (scm-style-repl) |
| 2099 | (set-current-input-port oport))) |
| 2100 | |
| 2101 | |
| 2102 | \f |
| 2103 | ;;; {IOTA functions: generating lists of numbers} |
| 2104 | |
| 2105 | (define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '())) |
| 2106 | (define (iota n) (list-reverse! (reverse-iota n))) |
| 2107 | |
| 2108 | \f |
| 2109 | ;;; {While} |
| 2110 | ;;; |
| 2111 | ;;; with `continue' and `break'. |
| 2112 | ;;; |
| 2113 | |
| 2114 | (defmacro while (cond . body) |
| 2115 | `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue))))) |
| 2116 | (break (lambda val (apply throw 'break val)))) |
| 2117 | (catch 'break |
| 2118 | (lambda () (continue)) |
| 2119 | (lambda v (cadr v))))) |
| 2120 | |
| 2121 | |
| 2122 | \f |
| 2123 | |
| 2124 | ;;; {Macros} |
| 2125 | ;;; |
| 2126 | |
| 2127 | ;; actually....hobbit might be able to hack these with a little |
| 2128 | ;; coaxing |
| 2129 | ;; |
| 2130 | |
| 2131 | (defmacro define-macro (first . rest) |
| 2132 | (let ((name (if (symbol? first) first (car first))) |
| 2133 | (transformer |
| 2134 | (if (symbol? first) |
| 2135 | (car rest) |
| 2136 | `(lambda ,(cdr first) ,@rest)))) |
| 2137 | `(define ,name (defmacro:transformer ,transformer)))) |
| 2138 | |
| 2139 | |
| 2140 | (defmacro define-syntax-macro (first . rest) |
| 2141 | (let ((name (if (symbol? first) first (car first))) |
| 2142 | (transformer |
| 2143 | (if (symbol? first) |
| 2144 | (car rest) |
| 2145 | `(lambda ,(cdr first) ,@rest)))) |
| 2146 | `(define ,name (defmacro:syntax-transformer ,transformer)))) |
| 2147 | \f |
| 2148 | ;;; {Module System Macros} |
| 2149 | ;;; |
| 2150 | |
| 2151 | (defmacro define-module args |
| 2152 | `(let* ((process-define-module process-define-module) |
| 2153 | (set-current-module set-current-module) |
| 2154 | (module (process-define-module ',args))) |
| 2155 | (set-current-module module) |
| 2156 | module)) |
| 2157 | |
| 2158 | (define define-private define) |
| 2159 | |
| 2160 | (defmacro define-public args |
| 2161 | (define (syntax) |
| 2162 | (error "bad syntax" (list 'define-public args))) |
| 2163 | (define (defined-name n) |
| 2164 | (cond |
| 2165 | ((symbol? n) n) |
| 2166 | ((pair? n) (defined-name (car n))) |
| 2167 | (else (syntax)))) |
| 2168 | (cond |
| 2169 | ((null? args) (syntax)) |
| 2170 | |
| 2171 | (#t (let ((name (defined-name (car args)))) |
| 2172 | `(begin |
| 2173 | (let ((public-i (module-public-interface (current-module)))) |
| 2174 | ;; Make sure there is a local variable: |
| 2175 | ;; |
| 2176 | (module-define! (current-module) |
| 2177 | ',name |
| 2178 | (module-ref (current-module) ',name #f)) |
| 2179 | |
| 2180 | ;; Make sure that local is exported: |
| 2181 | ;; |
| 2182 | (module-add! public-i ',name (module-variable (current-module) ',name))) |
| 2183 | |
| 2184 | ;; Now (re)define the var normally. |
| 2185 | ;; |
| 2186 | (define-private ,@ args)))))) |
| 2187 | |
| 2188 | |
| 2189 | |
| 2190 | (defmacro defmacro-public args |
| 2191 | (define (syntax) |
| 2192 | (error "bad syntax" (list 'defmacro-public args))) |
| 2193 | (define (defined-name n) |
| 2194 | (cond |
| 2195 | ((symbol? n) n) |
| 2196 | (else (syntax)))) |
| 2197 | (cond |
| 2198 | ((null? args) (syntax)) |
| 2199 | |
| 2200 | (#t (let ((name (defined-name (car args)))) |
| 2201 | `(begin |
| 2202 | (let ((public-i (module-public-interface (current-module)))) |
| 2203 | ;; Make sure there is a local variable: |
| 2204 | ;; |
| 2205 | (module-define! (current-module) |
| 2206 | ',name |
| 2207 | (module-ref (current-module) ',name #f)) |
| 2208 | |
| 2209 | ;; Make sure that local is exported: |
| 2210 | ;; |
| 2211 | (module-add! public-i ',name (module-variable (current-module) ',name))) |
| 2212 | |
| 2213 | ;; Now (re)define the var normally. |
| 2214 | ;; |
| 2215 | (defmacro ,@ args)))))) |
| 2216 | |
| 2217 | |
| 2218 | |
| 2219 | |
| 2220 | (define load load-module) |
| 2221 | ;(define (load . args) |
| 2222 | ; (start-stack 'load-stack (apply load-module args))) |
| 2223 | |
| 2224 | |
| 2225 | \f |
| 2226 | ;;; {I/O functions for Tcl channels (disabled)} |
| 2227 | |
| 2228 | ;; (define in-ch (get-standard-channel TCL_STDIN)) |
| 2229 | ;; (define out-ch (get-standard-channel TCL_STDOUT)) |
| 2230 | ;; (define err-ch (get-standard-channel TCL_STDERR)) |
| 2231 | ;; |
| 2232 | ;; (define inp (%make-channel-port in-ch "r")) |
| 2233 | ;; (define outp (%make-channel-port out-ch "w")) |
| 2234 | ;; (define errp (%make-channel-port err-ch "w")) |
| 2235 | ;; |
| 2236 | ;; (define %system-char-ready? char-ready?) |
| 2237 | ;; |
| 2238 | ;; (define (char-ready? p) |
| 2239 | ;; (if (not (channel-port? p)) |
| 2240 | ;; (%system-char-ready? p) |
| 2241 | ;; (let* ((channel (%channel-port-channel p)) |
| 2242 | ;; (old-blocking (channel-option-ref channel :blocking))) |
| 2243 | ;; (dynamic-wind |
| 2244 | ;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking "0")) |
| 2245 | ;; (lambda () (not (eof-object? (peek-char p)))) |
| 2246 | ;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking old-blocking)))))) |
| 2247 | ;; |
| 2248 | ;; (define (top-repl) |
| 2249 | ;; (with-input-from-port inp |
| 2250 | ;; (lambda () |
| 2251 | ;; (with-output-to-port outp |
| 2252 | ;; (lambda () |
| 2253 | ;; (with-error-to-port errp |
| 2254 | ;; (lambda () |
| 2255 | ;; (scm-style-repl)))))))) |
| 2256 | ;; |
| 2257 | ;; (set-current-input-port inp) |
| 2258 | ;; (set-current-output-port outp) |
| 2259 | ;; (set-current-error-port errp) |
| 2260 | |
| 2261 | (define (top-repl) (scm-style-repl)) |
| 2262 | |
| 2263 | (defmacro false-if-exception (expr) |
| 2264 | `(catch #t (lambda () ,expr) |
| 2265 | (lambda args #f))) |
| 2266 | |
| 2267 | \f |
| 2268 | ;;; {Calling Conventions} |
| 2269 | (define-module (ice-9 calling)) |
| 2270 | |
| 2271 | ;;;; |
| 2272 | ;;; |
| 2273 | ;;; This file contains a number of macros that support |
| 2274 | ;;; common calling conventions. |
| 2275 | |
| 2276 | ;;; |
| 2277 | ;;; with-excursion-function <vars> proc |
| 2278 | ;;; <vars> is an unevaluated list of names that are bound in the caller. |
| 2279 | ;;; proc is a procedure, called: |
| 2280 | ;;; (proc excursion) |
| 2281 | ;;; |
| 2282 | ;;; excursion is a procedure isolates all changes to <vars> |
| 2283 | ;;; in the dynamic scope of the call to proc. In other words, |
| 2284 | ;;; the values of <vars> are saved when proc is entered, and when |
| 2285 | ;;; proc returns, those values are restored. Values are also restored |
| 2286 | ;;; entering and leaving the call to proc non-locally, such as using |
| 2287 | ;;; call-with-current-continuation, error, or throw. |
| 2288 | ;;; |
| 2289 | (defmacro-public with-excursion-function (vars proc) |
| 2290 | `(,proc ,(excursion-function-syntax vars))) |
| 2291 | |
| 2292 | |
| 2293 | |
| 2294 | ;;; with-getter-and-setter <vars> proc |
| 2295 | ;;; <vars> is an unevaluated list of names that are bound in the caller. |
| 2296 | ;;; proc is a procedure, called: |
| 2297 | ;;; (proc getter setter) |
| 2298 | ;;; |
| 2299 | ;;; getter and setter are procedures used to access |
| 2300 | ;;; or modify <vars>. |
| 2301 | ;;; |
| 2302 | ;;; setter, called with keywords arguments, modifies the named |
| 2303 | ;;; values. If "foo" and "bar" are among <vars>, then: |
| 2304 | ;;; |
| 2305 | ;;; (setter :foo 1 :bar 2) |
| 2306 | ;;; == (set! foo 1 bar 2) |
| 2307 | ;;; |
| 2308 | ;;; getter, called with just keywords, returns |
| 2309 | ;;; a list of the corresponding values. For example, |
| 2310 | ;;; if "foo" and "bar" are among the <vars>, then |
| 2311 | ;;; |
| 2312 | ;;; (getter :foo :bar) |
| 2313 | ;;; => (<value-of-foo> <value-of-bar>) |
| 2314 | ;;; |
| 2315 | ;;; getter, called with no arguments, returns a list of all accepted |
| 2316 | ;;; keywords and the corresponding values. If "foo" and "bar" are |
| 2317 | ;;; the *only* <vars>, then: |
| 2318 | ;;; |
| 2319 | ;;; (getter) |
| 2320 | ;;; => (:foo <value-of-bar> :bar <value-of-foo>) |
| 2321 | ;;; |
| 2322 | ;;; The unusual calling sequence of a getter supports too handy |
| 2323 | ;;; idioms: |
| 2324 | ;;; |
| 2325 | ;;; (apply setter (getter)) ;; save and restore |
| 2326 | ;;; |
| 2327 | ;;; (apply-to-args (getter :foo :bar) ;; fetch and bind |
| 2328 | ;;; (lambda (foo bar) ....)) |
| 2329 | ;;; |
| 2330 | ;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it |
| 2331 | ;;; ;; takes its arguments in a different order. |
| 2332 | ;;; |
| 2333 | ;;; |
| 2334 | (defmacro-public with-getter-and-setter (vars proc) |
| 2335 | `(,proc ,@ (getter-and-setter-syntax vars))) |
| 2336 | |
| 2337 | ;;; with-getter vars proc |
| 2338 | ;;; A short-hand for a call to with-getter-and-setter. |
| 2339 | ;;; The procedure is called: |
| 2340 | ;;; (proc getter) |
| 2341 | ;;; |
| 2342 | (defmacro-public with-getter (vars proc) |
| 2343 | `(,proc ,(car (getter-and-setter-syntax vars)))) |
| 2344 | |
| 2345 | |
| 2346 | ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc |
| 2347 | ;;; Compose getters and setters. |
| 2348 | ;;; |
| 2349 | ;;; <vars> is an unevaluated list of names that are bound in the caller. |
| 2350 | ;;; |
| 2351 | ;;; get-delegate is called by the new getter to extend the set of |
| 2352 | ;;; gettable variables beyond just <vars> |
| 2353 | ;;; set-delegate is called by the new setter to extend the set of |
| 2354 | ;;; gettable variables beyond just <vars> |
| 2355 | ;;; |
| 2356 | ;;; proc is a procedure that is called |
| 2357 | ;;; (proc getter setter) |
| 2358 | ;;; |
| 2359 | (defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc) |
| 2360 | `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate))) |
| 2361 | |
| 2362 | |
| 2363 | ;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc |
| 2364 | ;;; <vars> is an unevaluated list of names that are bound in the caller. |
| 2365 | ;;; proc is called: |
| 2366 | ;;; |
| 2367 | ;;; (proc excursion getter setter) |
| 2368 | ;;; |
| 2369 | ;;; See also: |
| 2370 | ;;; with-getter-and-setter |
| 2371 | ;;; with-excursion-function |
| 2372 | ;;; |
| 2373 | (defmacro-public with-excursion-getter-and-setter (vars proc) |
| 2374 | `(,proc ,(excursion-function-syntax vars) |
| 2375 | ,@ (getter-and-setter-syntax vars))) |
| 2376 | |
| 2377 | |
| 2378 | (define (excursion-function-syntax vars) |
| 2379 | (let ((saved-value-names (map gensym vars)) |
| 2380 | (tmp-var-name (gensym 'temp)) |
| 2381 | (swap-fn-name (gensym 'swap)) |
| 2382 | (thunk-name (gensym 'thunk))) |
| 2383 | `(lambda (,thunk-name) |
| 2384 | (letrec ((,tmp-var-name #f) |
| 2385 | (,swap-fn-name |
| 2386 | (lambda () ,@ (map (lambda (n sn) `(set! ,tmp-var-name ,n ,n ,sn ,sn ,tmp-var-name)) |
| 2387 | vars saved-value-names))) |
| 2388 | ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars)) |
| 2389 | (dynamic-wind |
| 2390 | ,swap-fn-name |
| 2391 | ,thunk-name |
| 2392 | ,swap-fn-name))))) |
| 2393 | |
| 2394 | |
| 2395 | (define (getter-and-setter-syntax vars) |
| 2396 | (let ((args-name (gensym 'args)) |
| 2397 | (an-arg-name (gensym 'an-arg)) |
| 2398 | (new-val-name (gensym 'new-value)) |
| 2399 | (loop-name (gensym 'loop)) |
| 2400 | (kws (map symbol->keyword vars))) |
| 2401 | (list `(lambda ,args-name |
| 2402 | (let ,loop-name ((,args-name ,args-name)) |
| 2403 | (if (null? ,args-name) |
| 2404 | ,(if (null? kws) |
| 2405 | ''() |
| 2406 | `(let ((all-vals (,loop-name ',kws))) |
| 2407 | (let ,loop-name ((vals all-vals) |
| 2408 | (kws ',kws)) |
| 2409 | (if (null? vals) |
| 2410 | '() |
| 2411 | `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) |
| 2412 | (map (lambda (,an-arg-name) |
| 2413 | (case ,an-arg-name |
| 2414 | ,@ (append |
| 2415 | (map (lambda (kw v) `((,kw) ,v)) kws vars) |
| 2416 | `((else (throw 'bad-get-option ,an-arg-name)))))) |
| 2417 | ,args-name)))) |
| 2418 | |
| 2419 | `(lambda ,args-name |
| 2420 | (let ,loop-name ((,args-name ,args-name)) |
| 2421 | (or (null? ,args-name) |
| 2422 | (null? (cdr ,args-name)) |
| 2423 | (let ((,an-arg-name (car ,args-name)) |
| 2424 | (,new-val-name (cadr ,args-name))) |
| 2425 | (case ,an-arg-name |
| 2426 | ,@ (append |
| 2427 | (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars) |
| 2428 | `((else (throw 'bad-set-option ,an-arg-name))))) |
| 2429 | (,loop-name (cddr ,args-name))))))))) |
| 2430 | |
| 2431 | (define (delegating-getter-and-setter-syntax vars get-delegate set-delegate) |
| 2432 | (let ((args-name (gensym 'args)) |
| 2433 | (an-arg-name (gensym 'an-arg)) |
| 2434 | (new-val-name (gensym 'new-value)) |
| 2435 | (loop-name (gensym 'loop)) |
| 2436 | (kws (map symbol->keyword vars))) |
| 2437 | (list `(lambda ,args-name |
| 2438 | (let ,loop-name ((,args-name ,args-name)) |
| 2439 | (if (null? ,args-name) |
| 2440 | (append! |
| 2441 | ,(if (null? kws) |
| 2442 | ''() |
| 2443 | `(let ((all-vals (,loop-name ',kws))) |
| 2444 | (let ,loop-name ((vals all-vals) |
| 2445 | (kws ',kws)) |
| 2446 | (if (null? vals) |
| 2447 | '() |
| 2448 | `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) |
| 2449 | (,get-delegate)) |
| 2450 | (map (lambda (,an-arg-name) |
| 2451 | (case ,an-arg-name |
| 2452 | ,@ (append |
| 2453 | (map (lambda (kw v) `((,kw) ,v)) kws vars) |
| 2454 | `((else (car (,get-delegate ,an-arg-name))))))) |
| 2455 | ,args-name)))) |
| 2456 | |
| 2457 | `(lambda ,args-name |
| 2458 | (let ,loop-name ((,args-name ,args-name)) |
| 2459 | (or (null? ,args-name) |
| 2460 | (null? (cdr ,args-name)) |
| 2461 | (let ((,an-arg-name (car ,args-name)) |
| 2462 | (,new-val-name (cadr ,args-name))) |
| 2463 | (case ,an-arg-name |
| 2464 | ,@ (append |
| 2465 | (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars) |
| 2466 | `((else (,set-delegate ,an-arg-name ,new-val-name))))) |
| 2467 | (,loop-name (cddr ,args-name))))))))) |
| 2468 | |
| 2469 | |
| 2470 | |
| 2471 | |
| 2472 | ;;; with-configuration-getter-and-setter <vars-etc> proc |
| 2473 | ;;; |
| 2474 | ;;; Create a getter and setter that can trigger arbitrary computation. |
| 2475 | ;;; |
| 2476 | ;;; <vars-etc> is a list of variable specifiers, explained below. |
| 2477 | ;;; proc is called: |
| 2478 | ;;; |
| 2479 | ;;; (proc getter setter) |
| 2480 | ;;; |
| 2481 | ;;; Each element of the <vars-etc> list is of the form: |
| 2482 | ;;; |
| 2483 | ;;; (<var> getter-hook setter-hook) |
| 2484 | ;;; |
| 2485 | ;;; Both hook elements are evaluated; the variable name is not. |
| 2486 | ;;; Either hook may be #f or procedure. |
| 2487 | ;;; |
| 2488 | ;;; A getter hook is a thunk that returns a value for the corresponding |
| 2489 | ;;; variable. If omitted (#f is passed), the binding of <var> is |
| 2490 | ;;; returned. |
| 2491 | ;;; |
| 2492 | ;;; A setter hook is a procedure of one argument that accepts a new value |
| 2493 | ;;; for the corresponding variable. If omitted, the binding of <var> |
| 2494 | ;;; is simply set using set!. |
| 2495 | ;;; |
| 2496 | (defmacro-public with-configuration-getter-and-setter (vars-etc proc) |
| 2497 | `((lambda (simpler-get simpler-set body-proc) |
| 2498 | (with-delegating-getter-and-setter () |
| 2499 | simpler-get simpler-set body-proc)) |
| 2500 | |
| 2501 | (lambda (kw) |
| 2502 | (case kw |
| 2503 | ,@(map (lambda (v) `((,(symbol->keyword (car v))) |
| 2504 | ,(cond |
| 2505 | ((cadr v) => list) |
| 2506 | (else `(list ,(car v)))))) |
| 2507 | vars-etc))) |
| 2508 | |
| 2509 | (lambda (kw new-val) |
| 2510 | (case kw |
| 2511 | ,@(map (lambda (v) `((,(symbol->keyword (car v))) |
| 2512 | ,(cond |
| 2513 | ((caddr v) => (lambda (proc) `(,proc new-val))) |
| 2514 | (else `(set! ,(car v) new-val))))) |
| 2515 | vars-etc))) |
| 2516 | |
| 2517 | ,proc)) |
| 2518 | |
| 2519 | (defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc) |
| 2520 | `((lambda (simpler-get simpler-set body-proc) |
| 2521 | (with-delegating-getter-and-setter () |
| 2522 | simpler-get simpler-set body-proc)) |
| 2523 | |
| 2524 | (lambda (kw) |
| 2525 | (case kw |
| 2526 | ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) |
| 2527 | ,(cond |
| 2528 | ((cadr v) => list) |
| 2529 | (else `(list ,(car v)))))) |
| 2530 | vars-etc) |
| 2531 | `((else (,delegate-get kw)))))) |
| 2532 | |
| 2533 | (lambda (kw new-val) |
| 2534 | (case kw |
| 2535 | ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) |
| 2536 | ,(cond |
| 2537 | ((caddr v) => (lambda (proc) `(,proc new-val))) |
| 2538 | (else `(set! ,(car v) new-val))))) |
| 2539 | vars-etc) |
| 2540 | `((else (,delegate-set kw new-val)))))) |
| 2541 | |
| 2542 | ,proc)) |
| 2543 | |
| 2544 | |
| 2545 | ;;; let-configuration-getter-and-setter <vars-etc> proc |
| 2546 | ;;; |
| 2547 | ;;; This procedure is like with-configuration-getter-and-setter (q.v.) |
| 2548 | ;;; except that each element of <vars-etc> is: |
| 2549 | ;;; |
| 2550 | ;;; (<var> initial-value getter-hook setter-hook) |
| 2551 | ;;; |
| 2552 | ;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter |
| 2553 | ;;; introduces bindings for the variables named in <vars-etc>. |
| 2554 | ;;; It is short-hand for: |
| 2555 | ;;; |
| 2556 | ;;; (let ((<var1> initial-value-1) |
| 2557 | ;;; (<var2> initial-value-2) |
| 2558 | ;;; ...) |
| 2559 | ;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc)) |
| 2560 | ;;; |
| 2561 | (defmacro-public let-with-configuration-getter-and-setter (vars-etc proc) |
| 2562 | `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc) |
| 2563 | (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc) |
| 2564 | ,proc))) |
| 2565 | |
| 2566 | |
| 2567 | |
| 2568 | \f |
| 2569 | ;;; {Implementation of COMMON LISP list functions for Scheme} |
| 2570 | |
| 2571 | (define-module (ice-9 common-list)) |
| 2572 | |
| 2573 | ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme |
| 2574 | ; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. |
| 2575 | ; |
| 2576 | ;Permission to copy this software, to redistribute it, and to use it |
| 2577 | ;for any purpose is granted, subject to the following restrictions and |
| 2578 | ;understandings. |
| 2579 | ; |
| 2580 | ;1. Any copy made of this software must include this copyright notice |
| 2581 | ;in full. |
| 2582 | ; |
| 2583 | ;2. I have made no warrantee or representation that the operation of |
| 2584 | ;this software will be error-free, and I am under no obligation to |
| 2585 | ;provide any services, by way of maintenance, update, or otherwise. |
| 2586 | ; |
| 2587 | ;3. In conjunction with products arising from the use of this |
| 2588 | ;material, there shall be no use of my name in any advertising, |
| 2589 | ;promotional, or sales literature without prior written consent in |
| 2590 | ;each case. |
| 2591 | |
| 2592 | ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) |
| 2593 | (define-public (make-list k . init) |
| 2594 | (set! init (if (pair? init) (car init))) |
| 2595 | (do ((k k (+ -1 k)) |
| 2596 | (result '() (cons init result))) |
| 2597 | ((<= k 0) result))) |
| 2598 | |
| 2599 | (define-public (adjoin e l) (if (memq e l) l (cons e l))) |
| 2600 | |
| 2601 | (define-public (union l1 l2) |
| 2602 | (cond ((null? l1) l2) |
| 2603 | ((null? l2) l1) |
| 2604 | (else (union (cdr l1) (adjoin (car l1) l2))))) |
| 2605 | |
| 2606 | (define-public (intersection l1 l2) |
| 2607 | (cond ((null? l1) l1) |
| 2608 | ((null? l2) l2) |
| 2609 | ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2))) |
| 2610 | (else (intersection (cdr l1) l2)))) |
| 2611 | |
| 2612 | (define-public (set-difference l1 l2) |
| 2613 | (cond ((null? l1) l1) |
| 2614 | ((memv (car l1) l2) (set-difference (cdr l1) l2)) |
| 2615 | (else (cons (car l1) (set-difference (cdr l1) l2))))) |
| 2616 | |
| 2617 | (define-public (reduce-init p init l) |
| 2618 | (if (null? l) |
| 2619 | init |
| 2620 | (reduce-init p (p init (car l)) (cdr l)))) |
| 2621 | |
| 2622 | (define-public (reduce p l) |
| 2623 | (cond ((null? l) l) |
| 2624 | ((null? (cdr l)) (car l)) |
| 2625 | (else (reduce-init p (car l) (cdr l))))) |
| 2626 | |
| 2627 | (define-public (some pred l . rest) |
| 2628 | (cond ((null? rest) |
| 2629 | (let mapf ((l l)) |
| 2630 | (and (not (null? l)) |
| 2631 | (or (pred (car l)) (mapf (cdr l)))))) |
| 2632 | (else (let mapf ((l l) (rest rest)) |
| 2633 | (and (not (null? l)) |
| 2634 | (or (apply pred (car l) (map car rest)) |
| 2635 | (mapf (cdr l) (map cdr rest)))))))) |
| 2636 | |
| 2637 | (define-public (every pred l . rest) |
| 2638 | (cond ((null? rest) |
| 2639 | (let mapf ((l l)) |
| 2640 | (or (null? l) |
| 2641 | (and (pred (car l)) (mapf (cdr l)))))) |
| 2642 | (else (let mapf ((l l) (rest rest)) |
| 2643 | (or (null? l) |
| 2644 | (and (apply pred (car l) (map car rest)) |
| 2645 | (mapf (cdr l) (map cdr rest)))))))) |
| 2646 | |
| 2647 | (define-public (notany pred . ls) (not (apply some pred ls))) |
| 2648 | |
| 2649 | (define-public (notevery pred . ls) (not (apply every pred ls))) |
| 2650 | |
| 2651 | (define-public (find-if t l) |
| 2652 | (cond ((null? l) #f) |
| 2653 | ((t (car l)) (car l)) |
| 2654 | (else (find-if t (cdr l))))) |
| 2655 | |
| 2656 | (define-public (member-if t l) |
| 2657 | (cond ((null? l) #f) |
| 2658 | ((t (car l)) l) |
| 2659 | (else (member-if t (cdr l))))) |
| 2660 | |
| 2661 | (define-public (remove-if p l) |
| 2662 | (cond ((null? l) '()) |
| 2663 | ((p (car l)) (remove-if p (cdr l))) |
| 2664 | (else (cons (car l) (remove-if p (cdr l)))))) |
| 2665 | |
| 2666 | (define-public (delete-if! pred list) |
| 2667 | (let delete-if ((list list)) |
| 2668 | (cond ((null? list) '()) |
| 2669 | ((pred (car list)) (delete-if (cdr list))) |
| 2670 | (else |
| 2671 | (set-cdr! list (delete-if (cdr list))) |
| 2672 | list)))) |
| 2673 | |
| 2674 | (define-public (delete-if-not! pred list) |
| 2675 | (let delete-if ((list list)) |
| 2676 | (cond ((null? list) '()) |
| 2677 | ((not (pred (car list))) (delete-if (cdr list))) |
| 2678 | (else |
| 2679 | (set-cdr! list (delete-if (cdr list))) |
| 2680 | list)))) |
| 2681 | |
| 2682 | (define-public (butlast lst n) |
| 2683 | (letrec ((l (- (length lst) n)) |
| 2684 | (bl (lambda (lst n) |
| 2685 | (cond ((null? lst) lst) |
| 2686 | ((positive? n) |
| 2687 | (cons (car lst) (bl (cdr lst) (+ -1 n)))) |
| 2688 | (else '()))))) |
| 2689 | (bl lst (if (negative? n) |
| 2690 | (slib:error "negative argument to butlast" n) |
| 2691 | l)))) |
| 2692 | |
| 2693 | (define-public (and? . args) |
| 2694 | (cond ((null? args) #t) |
| 2695 | ((car args) (apply and? (cdr args))) |
| 2696 | (else #f))) |
| 2697 | |
| 2698 | (define-public (or? . args) |
| 2699 | (cond ((null? args) #f) |
| 2700 | ((car args) #t) |
| 2701 | (else (apply or? (cdr args))))) |
| 2702 | |
| 2703 | (define-public (has-duplicates? lst) |
| 2704 | (cond ((null? lst) #f) |
| 2705 | ((member (car lst) (cdr lst)) #t) |
| 2706 | (else (has-duplicates? (cdr lst))))) |
| 2707 | |
| 2708 | (define-public (list* x . y) |
| 2709 | (define (list*1 x) |
| 2710 | (if (null? (cdr x)) |
| 2711 | (car x) |
| 2712 | (cons (car x) (list*1 (cdr x))))) |
| 2713 | (if (null? y) |
| 2714 | x |
| 2715 | (cons x (list*1 y)))) |
| 2716 | |
| 2717 | ;; pick p l |
| 2718 | ;; Apply P to each element of L, returning a list of elts |
| 2719 | ;; for which P returns a non-#f value. |
| 2720 | ;; |
| 2721 | (define-public (pick p l) |
| 2722 | (let loop ((s '()) |
| 2723 | (l l)) |
| 2724 | (cond |
| 2725 | ((null? l) s) |
| 2726 | ((p (car l)) (loop (cons (car l) s) (cdr l))) |
| 2727 | (else (loop s (cdr l)))))) |
| 2728 | |
| 2729 | ;; pick p l |
| 2730 | ;; Apply P to each element of L, returning a list of the |
| 2731 | ;; non-#f return values of P. |
| 2732 | ;; |
| 2733 | (define-public (pick-mappings p l) |
| 2734 | (let loop ((s '()) |
| 2735 | (l l)) |
| 2736 | (cond |
| 2737 | ((null? l) s) |
| 2738 | ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l)))) |
| 2739 | (else (loop s (cdr l)))))) |
| 2740 | |
| 2741 | (define-public (uniq l) |
| 2742 | (if (null? l) |
| 2743 | '() |
| 2744 | (let ((u (uniq (cdr l)))) |
| 2745 | (if (memq (car l) u) |
| 2746 | u |
| 2747 | (cons (car l) u))))) |
| 2748 | |
| 2749 | \f |
| 2750 | ;;; {Functions for browsing modules} |
| 2751 | |
| 2752 | (define-module (ice-9 ls) |
| 2753 | :use-module (ice-9 common-list)) |
| 2754 | |
| 2755 | ;;;; |
| 2756 | ;;; local-definitions-in root name |
| 2757 | ;;; Returns a list of names defined locally in the named |
| 2758 | ;;; subdirectory of root. |
| 2759 | ;;; definitions-in root name |
| 2760 | ;;; Returns a list of all names defined in the named |
| 2761 | ;;; subdirectory of root. The list includes alll locally |
| 2762 | ;;; defined names as well as all names inherited from a |
| 2763 | ;;; member of a use-list. |
| 2764 | ;;; |
| 2765 | ;;; A convenient interface for examining the nature of things: |
| 2766 | ;;; |
| 2767 | ;;; ls . various-names |
| 2768 | ;;; |
| 2769 | ;;; With just one argument, interpret that argument as the |
| 2770 | ;;; name of a subdirectory of the current module and |
| 2771 | ;;; return a list of names defined there. |
| 2772 | ;;; |
| 2773 | ;;; With more than one argument, still compute |
| 2774 | ;;; subdirectory lists, but return a list: |
| 2775 | ;;; ((<subdir-name> . <names-defined-there>) |
| 2776 | ;;; (<subdir-name> . <names-defined-there>) |
| 2777 | ;;; ...) |
| 2778 | ;;; |
| 2779 | |
| 2780 | (define-public (local-definitions-in root names) |
| 2781 | (let ((m (nested-ref root names)) |
| 2782 | (answer '())) |
| 2783 | (if (not (module? m)) |
| 2784 | (set! answer m) |
| 2785 | (module-for-each (lambda (k v) (set! answer (cons k answer))) m)) |
| 2786 | answer)) |
| 2787 | |
| 2788 | (define-public (definitions-in root names) |
| 2789 | (let ((m (nested-ref root names))) |
| 2790 | (if (not (module? m)) |
| 2791 | m |
| 2792 | (reduce union |
| 2793 | (cons (local-definitions-in m '()) |
| 2794 | (map (lambda (m2) (definitions-in m2 '())) |
| 2795 | (module-uses m))))))) |
| 2796 | |
| 2797 | (define-public (ls . various-refs) |
| 2798 | (and various-refs |
| 2799 | (if (cdr various-refs) |
| 2800 | (map (lambda (ref) |
| 2801 | (cons ref (definitions-in (current-module) ref))) |
| 2802 | various-refs) |
| 2803 | (definitions-in (current-module) (car various-refs))))) |
| 2804 | |
| 2805 | (define-public (lls . various-refs) |
| 2806 | (and various-refs |
| 2807 | (if (cdr various-refs) |
| 2808 | (map (lambda (ref) |
| 2809 | (cons ref (local-definitions-in (current-module) ref))) |
| 2810 | various-refs) |
| 2811 | (local-definitions-in (current-module) (car various-refs))))) |
| 2812 | |
| 2813 | (define-public (recursive-local-define name value) |
| 2814 | (let ((parent (reverse! (cdr (reverse name))))) |
| 2815 | (and parent (make-modules-in (current-module) parent)) |
| 2816 | (local-define name value))) |
| 2817 | \f |
| 2818 | ;;; {Queues} |
| 2819 | |
| 2820 | (define-module (ice-9 q)) |
| 2821 | |
| 2822 | ;;;; Copyright (C) 1995 Free Software Foundation, Inc. |
| 2823 | ;;;; |
| 2824 | ;;;; This program is free software; you can redistribute it and/or modify |
| 2825 | ;;;; it under the terms of the GNU General Public License as published by |
| 2826 | ;;;; the Free Software Foundation; either version 2, or (at your option) |
| 2827 | ;;;; any later version. |
| 2828 | ;;;; |
| 2829 | ;;;; This program is distributed in the hope that it will be useful, |
| 2830 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 2831 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 2832 | ;;;; GNU General Public License for more details. |
| 2833 | ;;;; |
| 2834 | ;;;; You should have received a copy of the GNU General Public License |
| 2835 | ;;;; along with this software; see the file COPYING. If not, write to |
| 2836 | ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
| 2837 | ;;;; |
| 2838 | |
| 2839 | ;;;; |
| 2840 | ;;; Q: Based on the interface to |
| 2841 | ;;; |
| 2842 | ;;; "queue.scm" Queues/Stacks for Scheme |
| 2843 | ;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. |
| 2844 | ;;; |
| 2845 | |
| 2846 | ;;;; |
| 2847 | ;;; {Q} |
| 2848 | ;;; |
| 2849 | ;;; A list is just a bunch of cons pairs that follows some constrains, right? |
| 2850 | ;;; Association lists are the same. Hash tables are just vectors and association |
| 2851 | ;;; lists. You can print them, read them, write them as constants, pun them off as other data |
| 2852 | ;;; structures etc. This is good. This is lisp. These structures are fast and compact |
| 2853 | ;;; and easy to manipulate arbitrarily because of their simple, regular structure and |
| 2854 | ;;; non-disjointedness (associations being lists and so forth). |
| 2855 | ;;; |
| 2856 | ;;; So I figured, queues should be the same -- just a "subtype" of cons-pair |
| 2857 | ;;; structures in general. |
| 2858 | ;;; |
| 2859 | ;;; A queue is a cons pair: |
| 2860 | ;;; ( <the-q> . <last-pair> ) |
| 2861 | ;;; |
| 2862 | ;;; <the-q> is a list of things in the q. New elements go at the end of that list. |
| 2863 | ;;; |
| 2864 | ;;; <last-pair> is #f if the q is empty, and otherwise is the last pair of <the-q>. |
| 2865 | ;;; |
| 2866 | ;;; q's print nicely, but alas, they do not read well because the eq?-ness of |
| 2867 | ;;; <last-pair> and (last-pair <the-q>) is lost by read. The procedure |
| 2868 | ;;; |
| 2869 | ;;; (sync-q! q) |
| 2870 | ;;; |
| 2871 | ;;; recomputes and resets the <last-pair> component of a queue. |
| 2872 | ;;; |
| 2873 | |
| 2874 | (define-public (sync-q! obj) (set-cdr! obj (and (car obj) (last-pair (car obj))))) |
| 2875 | |
| 2876 | ;;; make-q |
| 2877 | ;;; return a new q. |
| 2878 | ;;; |
| 2879 | (define-public (make-q) (cons '() '())) |
| 2880 | |
| 2881 | ;;; q? obj |
| 2882 | ;;; Return true if obj is a Q. |
| 2883 | ;;; An object is a queue if it is equal? to '(#f . #f) or |
| 2884 | ;;; if it is a pair P with (list? (car P)) and (eq? (cdr P) (last-pair P)). |
| 2885 | ;;; |
| 2886 | (define-public (q? obj) (and (pair? obj) |
| 2887 | (or (and (null? (car obj)) |
| 2888 | (null? (cdr obj))) |
| 2889 | (and |
| 2890 | (list? (car obj)) |
| 2891 | (eq? (cdr obj) (last-pair (car obj))))))) |
| 2892 | |
| 2893 | ;;; q-empty? obj |
| 2894 | ;;; |
| 2895 | (define-public (q-empty? obj) (null? (car obj))) |
| 2896 | |
| 2897 | ;;; q-empty-check q |
| 2898 | ;;; Throw a q-empty exception if Q is empty. |
| 2899 | (define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q))) |
| 2900 | |
| 2901 | |
| 2902 | ;;; q-front q |
| 2903 | ;;; Return the first element of Q. |
| 2904 | (define-public (q-front q) (q-empty-check q) (caar q)) |
| 2905 | |
| 2906 | ;;; q-front q |
| 2907 | ;;; Return the last element of Q. |
| 2908 | (define-public (q-rear q) (q-empty-check q) (cadr q)) |
| 2909 | |
| 2910 | ;;; q-remove! q obj |
| 2911 | ;;; Remove all occurences of obj from Q. |
| 2912 | (define-public (q-remove! q obj) |
| 2913 | (while (memq obj (car q)) |
| 2914 | (set-car! q (delq! obj (car q)))) |
| 2915 | (set-cdr! q (last-pair (car q)))) |
| 2916 | |
| 2917 | ;;; q-push! q obj |
| 2918 | ;;; Add obj to the front of Q |
| 2919 | (define-public (q-push! q d) |
| 2920 | (let ((h (cons d (car q)))) |
| 2921 | (set-car! q h) |
| 2922 | (if (null? (cdr q)) |
| 2923 | (set-cdr! q h)))) |
| 2924 | |
| 2925 | ;;; enq! q obj |
| 2926 | ;;; Add obj to the rear of Q |
| 2927 | (define-public (enq! q d) |
| 2928 | (let ((h (cons d '()))) |
| 2929 | (if (not (null? (cdr q))) |
| 2930 | (set-cdr! (cdr q) h) |
| 2931 | (set-car! q h)) |
| 2932 | (set-cdr! q h))) |
| 2933 | |
| 2934 | ;;; q-pop! q |
| 2935 | ;;; Take the front of Q and return it. |
| 2936 | (define-public (q-pop! q) |
| 2937 | (q-empty-check q) |
| 2938 | (let ((it (caar q)) |
| 2939 | (next (cdar q))) |
| 2940 | (if (not next) |
| 2941 | (set-cdr! q #f)) |
| 2942 | (set-car! q next) |
| 2943 | it)) |
| 2944 | |
| 2945 | ;;; deq! q |
| 2946 | ;;; Take the front of Q and return it. |
| 2947 | (define-public deq! q-pop!) |
| 2948 | |
| 2949 | ;;; q-length q |
| 2950 | ;;; Return the number of enqueued elements. |
| 2951 | ;;; |
| 2952 | (define-public (q-length q) (length (car q))) |
| 2953 | |
| 2954 | |
| 2955 | |
| 2956 | \f |
| 2957 | ;;; {The runq data structure} |
| 2958 | |
| 2959 | (define-module (ice-9 runq) |
| 2960 | :use-module (ice-9 q)) |
| 2961 | |
| 2962 | ;;;; Copyright (C) 1996 Free Software Foundation, Inc. |
| 2963 | ;;;; |
| 2964 | ;;;; This program is free software; you can redistribute it and/or modify |
| 2965 | ;;;; it under the terms of the GNU General Public License as published by |
| 2966 | ;;;; the Free Software Foundation; either version 2, or (at your option) |
| 2967 | ;;;; any later version. |
| 2968 | ;;;; |
| 2969 | ;;;; This program is distributed in the hope that it will be useful, |
| 2970 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 2971 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 2972 | ;;;; GNU General Public License for more details. |
| 2973 | ;;;; |
| 2974 | ;;;; You should have received a copy of the GNU General Public License |
| 2975 | ;;;; along with this software; see the file COPYING. If not, write to |
| 2976 | ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
| 2977 | ;;;; |
| 2978 | |
| 2979 | ;;;; |
| 2980 | ;;; |
| 2981 | ;;; One way to schedule parallel computations in a serial environment is |
| 2982 | ;;; to explicitly divide each task up into small, finite execution time, |
| 2983 | ;;; strips. Then you interleave the execution of strips from various |
| 2984 | ;;; tasks to achieve a kind of parallelism. Runqs are a handy data |
| 2985 | ;;; structure for this style of programming. |
| 2986 | ;;; |
| 2987 | ;;; We use thunks (nullary procedures) and lists of thunks to represent |
| 2988 | ;;; strips. By convention, the return value of a strip-thunk must either |
| 2989 | ;;; be another strip or the value #f. |
| 2990 | ;;; |
| 2991 | ;;; A runq is a procedure that manages a queue of strips. Called with no |
| 2992 | ;;; arguments, it processes one strip from the queue. Called with |
| 2993 | ;;; arguments, the arguments form a control message for the queue. The |
| 2994 | ;;; first argument is a symbol which is the message selector. |
| 2995 | ;;; |
| 2996 | ;;; A strip is processed this way: If the strip is a thunk, the thunk is |
| 2997 | ;;; called -- if it returns a strip, that strip is added back to the |
| 2998 | ;;; queue. To process a strip which is a list of thunks, the CAR of that |
| 2999 | ;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips |
| 3000 | ;;; -- perhaps one returned by the thunk, and perhaps the CDR of the |
| 3001 | ;;; original strip if that CDR is not nil. The runq puts whichever of |
| 3002 | ;;; these strips exist back on the queue. (The exact order in which |
| 3003 | ;;; strips are put back on the queue determines the scheduling behavior of |
| 3004 | ;;; a particular queue -- it's a parameter.) |
| 3005 | ;;; |
| 3006 | ;;; |
| 3007 | |
| 3008 | |
| 3009 | |
| 3010 | ;;;; |
| 3011 | ;;; (runq-control q msg . args) |
| 3012 | ;;; |
| 3013 | ;;; processes in the default way the control messages that |
| 3014 | ;;; can be sent to a runq. Q should be an ordinary |
| 3015 | ;;; Q (see utils/q.scm). |
| 3016 | ;;; |
| 3017 | ;;; The standard runq messages are: |
| 3018 | ;;; |
| 3019 | ;;; 'add! strip0 strip1... ;; to enqueue one or more strips |
| 3020 | ;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips |
| 3021 | ;;; 'push! strip0 ... ;; add strips to the front of the queue |
| 3022 | ;;; 'empty? ;; true if it is |
| 3023 | ;;; 'length ;; how many strips in the queue? |
| 3024 | ;;; 'kill! ;; empty the queue |
| 3025 | ;;; else ;; throw 'not-understood |
| 3026 | ;;; |
| 3027 | (define-public (runq-control q msg . args) |
| 3028 | (case msg |
| 3029 | ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) |
| 3030 | ((enque!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) |
| 3031 | ((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*) |
| 3032 | ((empty?) (q-empty? q)) |
| 3033 | ((length) (q-length q)) |
| 3034 | ((kill!) (set! q (make-q))) |
| 3035 | (else (throw 'not-understood msg args)))) |
| 3036 | |
| 3037 | (define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f))) |
| 3038 | |
| 3039 | ;;;; |
| 3040 | ;;; make-void-runq |
| 3041 | ;;; |
| 3042 | ;;; Make a runq that discards all messages except "length", for which |
| 3043 | ;;; it returns 0. |
| 3044 | ;;; |
| 3045 | (define-public (make-void-runq) |
| 3046 | (lambda opts |
| 3047 | (and opts |
| 3048 | (apply-to-args opts |
| 3049 | (lambda (msg . args) |
| 3050 | (case msg |
| 3051 | ((length) 0) |
| 3052 | (else #f))))))) |
| 3053 | |
| 3054 | ;;;; |
| 3055 | ;;; (make-fair-runq) |
| 3056 | ;;; |
| 3057 | ;;; Returns a runq procedure. |
| 3058 | ;;; Called with no arguments, the procedure processes one strip from the queue. |
| 3059 | ;;; Called with arguments, it uses runq-control. |
| 3060 | ;;; |
| 3061 | ;;; In a fair runq, if a strip returns a new strip X, X is added |
| 3062 | ;;; to the end of the queue, meaning it will be the last to execute |
| 3063 | ;;; of all the remaining procedures. |
| 3064 | ;;; |
| 3065 | (define-public (make-fair-runq) |
| 3066 | (letrec ((q (make-q)) |
| 3067 | (self |
| 3068 | (lambda ctl |
| 3069 | (if ctl |
| 3070 | (apply runq-control q ctl) |
| 3071 | (and (not (q-empty? q)) |
| 3072 | (let ((next-strip (deq! q))) |
| 3073 | (cond |
| 3074 | ((procedure? next-strip) (let ((k (run-strip next-strip))) |
| 3075 | (and k (enq! q k)))) |
| 3076 | ((pair? next-strip) (let ((k (run-strip (car next-strip)))) |
| 3077 | (and k (enq! q k))) |
| 3078 | (if (not (null? (cdr next-strip))) |
| 3079 | (enq! q (cdr next-strip))))) |
| 3080 | self)))))) |
| 3081 | self)) |
| 3082 | |
| 3083 | |
| 3084 | ;;;; |
| 3085 | ;;; (make-exclusive-runq) |
| 3086 | ;;; |
| 3087 | ;;; Returns a runq procedure. |
| 3088 | ;;; Called with no arguments, the procedure processes one strip from the queue. |
| 3089 | ;;; Called with arguments, it uses runq-control. |
| 3090 | ;;; |
| 3091 | ;;; In an exclusive runq, if a strip W returns a new strip X, X is added |
| 3092 | ;;; to the front of the queue, meaning it will be the next to execute |
| 3093 | ;;; of all the remaining procedures. |
| 3094 | ;;; |
| 3095 | ;;; An exception to this occurs if W was the CAR of a list of strips. |
| 3096 | ;;; In that case, after the return value of W is pushed onto the front |
| 3097 | ;;; of the queue, the CDR of the list of strips is pushed in front |
| 3098 | ;;; of that (if the CDR is not nil). This way, the rest of the thunks |
| 3099 | ;;; in the list that contained W have priority over the return value of W. |
| 3100 | ;;; |
| 3101 | (define-public (make-exclusive-runq) |
| 3102 | (letrec ((q (make-q)) |
| 3103 | (self |
| 3104 | (lambda ctl |
| 3105 | (if ctl |
| 3106 | (apply runq-control q ctl) |
| 3107 | (and (not (q-empty? q)) |
| 3108 | (let ((next-strip (deq! q))) |
| 3109 | (cond |
| 3110 | ((procedure? next-strip) (let ((k (run-strip next-strip))) |
| 3111 | (and k (q-push! q k)))) |
| 3112 | ((pair? next-strip) (let ((k (run-strip (car next-strip)))) |
| 3113 | (and k (q-push! q k))) |
| 3114 | (if (not (null? (cdr next-strip))) |
| 3115 | (q-push! q (cdr next-strip))))) |
| 3116 | self)))))) |
| 3117 | self)) |
| 3118 | |
| 3119 | |
| 3120 | ;;;; |
| 3121 | ;;; (make-subordinate-runq-to superior basic-inferior) |
| 3122 | ;;; |
| 3123 | ;;; Returns a runq proxy for the runq basic-inferior. |
| 3124 | ;;; |
| 3125 | ;;; The proxy watches for operations on the basic-inferior that cause |
| 3126 | ;;; a transition from a queue length of 0 to a non-zero length and |
| 3127 | ;;; vice versa. While the basic-inferior queue is not empty, |
| 3128 | ;;; the proxy installs a task on the superior runq. Each strip |
| 3129 | ;;; of that task processes N strips from the basic-inferior where |
| 3130 | ;;; N is the length of the basic-inferior queue when the proxy |
| 3131 | ;;; strip is entered. [Countless scheduling variations are possible.] |
| 3132 | ;;; |
| 3133 | (define-public (make-subordinate-runq-to superior-runq basic-runq) |
| 3134 | (let ((runq-task (cons #f #f))) |
| 3135 | (set-car! runq-task |
| 3136 | (lambda () |
| 3137 | (if (basic-runq 'empty?) |
| 3138 | (set-cdr! runq-task #f) |
| 3139 | (do ((n (basic-runq 'length) (1- n))) |
| 3140 | ((<= n 0) #f) |
| 3141 | (basic-runq))))) |
| 3142 | (letrec ((self |
| 3143 | (lambda ctl |
| 3144 | (if (not ctl) |
| 3145 | (let ((answer (basic-runq))) |
| 3146 | (self 'empty?) |
| 3147 | answer) |
| 3148 | (begin |
| 3149 | (case (car ctl) |
| 3150 | ((suspend) (set-cdr! runq-task #f)) |
| 3151 | (else (let ((answer (apply basic-runq ctl))) |
| 3152 | (if (and (not (cdr runq-task)) (not (basic-runq 'empty?))) |
| 3153 | (begin |
| 3154 | (set-cdr! runq-task runq-task) |
| 3155 | (superior-runq 'add! runq-task))) |
| 3156 | answer)))))))) |
| 3157 | self))) |
| 3158 | |
| 3159 | ;;;; |
| 3160 | ;;; (define fork-strips (lambda args args)) |
| 3161 | ;;; Return a strip that starts several strips in |
| 3162 | ;;; parallel. If this strip is enqueued on a fair |
| 3163 | ;;; runq, strips of the parallel subtasks will run |
| 3164 | ;;; round-robin style. |
| 3165 | ;;; |
| 3166 | (define fork-strips (lambda args args)) |
| 3167 | |
| 3168 | |
| 3169 | ;;;; |
| 3170 | ;;; (strip-sequence . strips) |
| 3171 | ;;; |
| 3172 | ;;; Returns a new strip which is the concatenation of the argument strips. |
| 3173 | ;;; |
| 3174 | (define-public ((strip-sequence . strips)) |
| 3175 | (let loop ((st (let ((a strips)) (set! strips #f) a))) |
| 3176 | (and (not (null? st)) |
| 3177 | (let ((then ((car st)))) |
| 3178 | (if then |
| 3179 | (lambda () (loop (cons then (cdr st)))) |
| 3180 | (lambda () (loop (cdr st)))))))) |
| 3181 | |
| 3182 | |
| 3183 | ;;;; |
| 3184 | ;;; (fair-strip-subtask . initial-strips) |
| 3185 | ;;; |
| 3186 | ;;; Returns a new strip which is the synchronos, fair, |
| 3187 | ;;; parallel execution of the argument strips. |
| 3188 | ;;; |
| 3189 | ;;; |
| 3190 | ;;; |
| 3191 | (define-public (fair-strip-subtask . initial-strips) |
| 3192 | (let ((st (make-fair-runq))) |
| 3193 | (apply st 'add! initial-strips) |
| 3194 | st)) |
| 3195 | |
| 3196 | \f |
| 3197 | ;;; {String Fun} |
| 3198 | |
| 3199 | (define-module (ice-9 string-fun)) |
| 3200 | |
| 3201 | ;;;; |
| 3202 | ;;; |
| 3203 | ;;; Various string funcitons, particularly those that take |
| 3204 | ;;; advantage of the "shared substring" capability. |
| 3205 | ;;; |
| 3206 | \f |
| 3207 | ;;; {String Fun: Dividing Strings Into Fields} |
| 3208 | ;;; |
| 3209 | ;;; The names of these functions are very regular. |
| 3210 | ;;; Here is a grammar of a call to one of these: |
| 3211 | ;;; |
| 3212 | ;;; <string-function-invocation> |
| 3213 | ;;; := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>) |
| 3214 | ;;; |
| 3215 | ;;; <str> = the string |
| 3216 | ;;; |
| 3217 | ;;; <ret> = The continuation. String functions generally return |
| 3218 | ;;; multiple values by passing them to this procedure. |
| 3219 | ;;; |
| 3220 | ;;; <action> = split |
| 3221 | ;;; | separate-fields |
| 3222 | ;;; |
| 3223 | ;;; "split" means to divide a string into two parts. |
| 3224 | ;;; <ret> will be called with two arguments. |
| 3225 | ;;; |
| 3226 | ;;; "separate-fields" means to divide a string into as many |
| 3227 | ;;; parts as possible. <ret> will be called with |
| 3228 | ;;; however many fields are found. |
| 3229 | ;;; |
| 3230 | ;;; <seperator-disposition> = before |
| 3231 | ;;; | after |
| 3232 | ;;; | discarding |
| 3233 | ;;; |
| 3234 | ;;; "before" means to leave the seperator attached to |
| 3235 | ;;; the beginning of the field to its right. |
| 3236 | ;;; "after" means to leave the seperator attached to |
| 3237 | ;;; the end of the field to its left. |
| 3238 | ;;; "discarding" means to discard seperators. |
| 3239 | ;;; |
| 3240 | ;;; Other dispositions might be handy. For example, "isolate" |
| 3241 | ;;; could mean to treat the separator as a field unto itself. |
| 3242 | ;;; |
| 3243 | ;;; <seperator-determination> = char |
| 3244 | ;;; | predicate |
| 3245 | ;;; |
| 3246 | ;;; "char" means to use a particular character as field seperator. |
| 3247 | ;;; "predicate" means to check each character using a particular predicate. |
| 3248 | ;;; |
| 3249 | ;;; Other determinations might be handy. For example, "character-set-member". |
| 3250 | ;;; |
| 3251 | ;;; <seperator-param> = A parameter that completes the meaning of the determinations. |
| 3252 | ;;; For example, if the determination is "char", then this parameter |
| 3253 | ;;; says which character. If it is "predicate", the parameter is the |
| 3254 | ;;; predicate. |
| 3255 | ;;; |
| 3256 | ;;; |
| 3257 | ;;; For example: |
| 3258 | ;;; |
| 3259 | ;;; (separate-fields-discarding-char #\, "foo, bar, baz, , bat" list) |
| 3260 | ;;; => ("foo" " bar" " baz" " " " bat") |
| 3261 | ;;; |
| 3262 | ;;; (split-after-char #\- 'an-example-of-split list) |
| 3263 | ;;; => ("an-" "example-of-split") |
| 3264 | ;;; |
| 3265 | ;;; As an alternative to using a determination "predicate", or to trying to do anything |
| 3266 | ;;; complicated with these functions, consider using regular expressions. |
| 3267 | ;;; |
| 3268 | |
| 3269 | (define-public (split-after-char char str ret) |
| 3270 | (let ((end (cond |
| 3271 | ((string-index str char) => 1+) |
| 3272 | (else (string-length str))))) |
| 3273 | (ret (make-shared-substring str 0 end) |
| 3274 | (make-shared-substring str end)))) |
| 3275 | |
| 3276 | (define-public (split-before-char char str ret) |
| 3277 | (let ((end (or (string-index str char) |
| 3278 | (string-length str)))) |
| 3279 | (ret (make-shared-substring str 0 end) |
| 3280 | (make-shared-substring str end)))) |
| 3281 | |
| 3282 | (define-public (split-discarding-char char str ret) |
| 3283 | (let ((end (string-index str char))) |
| 3284 | (if (not end) |
| 3285 | (ret str "") |
| 3286 | (ret (make-shared-substring str 0 end) |
| 3287 | (make-shared-substring str (1+ end)))))) |
| 3288 | |
| 3289 | (define-public (split-after-char-last char str ret) |
| 3290 | (let ((end (cond |
| 3291 | ((string-rindex str char) => 1+) |
| 3292 | (else 0)))) |
| 3293 | (ret (make-shared-substring str 0 end) |
| 3294 | (make-shared-substring str end)))) |
| 3295 | |
| 3296 | (define-public (split-before-char-last char str ret) |
| 3297 | (let ((end (or (string-rindex str char) 0))) |
| 3298 | (ret (make-shared-substring str 0 end) |
| 3299 | (make-shared-substring str end)))) |
| 3300 | |
| 3301 | (define-public (split-discarding-char-last char str ret) |
| 3302 | (let ((end (string-rindex str char))) |
| 3303 | (if (not end) |
| 3304 | (ret str "") |
| 3305 | (ret (make-shared-substring str 0 end) |
| 3306 | (make-shared-substring str (1+ end)))))) |
| 3307 | |
| 3308 | (define (split-before-predicate pred str ret) |
| 3309 | (let loop ((n 0)) |
| 3310 | (cond |
| 3311 | ((= n (length str)) (ret str "")) |
| 3312 | ((not (pred (string-ref str n))) (loop (1+ n))) |
| 3313 | (else (ret (make-shared-substring str 0 n) |
| 3314 | (make-shared-substring str n)))))) |
| 3315 | (define (split-after-predicate pred str ret) |
| 3316 | (let loop ((n 0)) |
| 3317 | (cond |
| 3318 | ((= n (length str)) (ret str "")) |
| 3319 | ((not (pred (string-ref str n))) (loop (1+ n))) |
| 3320 | (else (ret (make-shared-substring str 0 (1+ n)) |
| 3321 | (make-shared-substring str (1+ n))))))) |
| 3322 | |
| 3323 | (define (split-discarding-predicate pred str ret) |
| 3324 | (let loop ((n 0)) |
| 3325 | (cond |
| 3326 | ((= n (length str)) (ret str "")) |
| 3327 | ((not (pred (string-ref str n))) (loop (1+ n))) |
| 3328 | (else (ret (make-shared-substring str 0 n) |
| 3329 | (make-shared-substring str (1+ n))))))) |
| 3330 | |
| 3331 | (define-public (separate-fields-discarding-char ch str ret) |
| 3332 | (let loop ((fields '()) |
| 3333 | (str str)) |
| 3334 | (cond |
| 3335 | ((string-rindex str ch) |
| 3336 | => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields) |
| 3337 | (make-shared-substring str 0 w)))) |
| 3338 | (else (ret (cons str fields)))))) |
| 3339 | |
| 3340 | (define-public (separate-fields-after-char ch str ret) |
| 3341 | (let loop ((fields '()) |
| 3342 | (str str)) |
| 3343 | (cond |
| 3344 | ((string-rindex str ch) |
| 3345 | => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields) |
| 3346 | (make-shared-substring str 0 (+ 1 w))))) |
| 3347 | (else (ret (cons str fields)))))) |
| 3348 | |
| 3349 | (define-public (separate-fields-before-char ch str ret) |
| 3350 | (let loop ((fields '()) |
| 3351 | (str str)) |
| 3352 | (cond |
| 3353 | ((string-rindex str ch) |
| 3354 | => (lambda (pos) (loop (cons (make-shared-substring str w) fields) |
| 3355 | (make-shared-substring str 0 w)))) |
| 3356 | (else (ret (cons str fields)))))) |
| 3357 | |
| 3358 | \f |
| 3359 | ;;; {String Fun: String Prefix Predicates} |
| 3360 | ;;; |
| 3361 | ;;; Very simple: |
| 3362 | ;;; |
| 3363 | ;;; (define-public ((string-prefix-predicate pred?) prefix str) |
| 3364 | ;;; (and (<= (length prefix) (length str)) |
| 3365 | ;;; (pred? prefix (make-shared-substring str 0 (length prefix))))) |
| 3366 | ;;; |
| 3367 | ;;; (define-public string-prefix=? (string-prefix-predicate string=?)) |
| 3368 | ;;; |
| 3369 | |
| 3370 | (define-public ((string-prefix-predicate pred?) prefix str) |
| 3371 | (and (<= (length prefix) (length str)) |
| 3372 | (pred? prefix (make-shared-substring str 0 (length prefix))))) |
| 3373 | |
| 3374 | (define-public string-prefix=? (string-prefix-predicate string=?)) |
| 3375 | |
| 3376 | \f |
| 3377 | ;;; {String Fun: Strippers} |
| 3378 | ;;; |
| 3379 | ;;; <stripper> = sans-<removable-part> |
| 3380 | ;;; |
| 3381 | ;;; <removable-part> = surrounding-whitespace |
| 3382 | ;;; | trailing-whitespace |
| 3383 | ;;; | leading-whitespace |
| 3384 | ;;; | final-newline |
| 3385 | ;;; |
| 3386 | |
| 3387 | (define-public (sans-surrounding-whitespace s) |
| 3388 | (let ((st 0) |
| 3389 | (end (string-length s))) |
| 3390 | (while (and (< st (string-length s)) |
| 3391 | (char-whitespace? (string-ref s st))) |
| 3392 | (set! st (1+ st))) |
| 3393 | (while (and (< 0 end) |
| 3394 | (char-whitespace? (string-ref s (1- end)))) |
| 3395 | (set! end (1- end))) |
| 3396 | (if (< end st) |
| 3397 | "" |
| 3398 | (make-shared-substring s st end)))) |
| 3399 | |
| 3400 | (define-public (sans-trailing-whitespace s) |
| 3401 | (let ((st 0) |
| 3402 | (end (string-length s))) |
| 3403 | (while (and (< 0 end) |
| 3404 | (char-whitespace? (string-ref s (1- end)))) |
| 3405 | (set! end (1- end))) |
| 3406 | (if (< end st) |
| 3407 | "" |
| 3408 | (make-shared-substring s st end)))) |
| 3409 | |
| 3410 | (define-public (sans-leading-whitespace s) |
| 3411 | (let ((st 0) |
| 3412 | (end (string-length s))) |
| 3413 | (while (and (< st (string-length s)) |
| 3414 | (char-whitespace? (string-ref s st))) |
| 3415 | (set! st (1+ st))) |
| 3416 | (if (< end st) |
| 3417 | "" |
| 3418 | (make-shared-substring s st end)))) |
| 3419 | |
| 3420 | (define-public (sans-final-newline str) |
| 3421 | (cond |
| 3422 | ((= 0 (string-length str)) |
| 3423 | str) |
| 3424 | |
| 3425 | ((char=? #\nl (string-ref str (1- (string-length str)))) |
| 3426 | (make-shared-substring str 0 (1- (string-length str)))) |
| 3427 | |
| 3428 | (else str))) |
| 3429 | \f |
| 3430 | ;;; {String Fun: has-trailing-newline?} |
| 3431 | ;;; |
| 3432 | |
| 3433 | (define-public (has-trailing-newline? str) |
| 3434 | (and (< 0 (string-length str)) |
| 3435 | (char=? #\nl (string-ref str (1- (string-length str)))))) |
| 3436 | |
| 3437 | |
| 3438 | \f |
| 3439 | ;;; {String Fun: with-regexp-parts} |
| 3440 | |
| 3441 | (define-public (with-regexp-parts regexp fields str return fail) |
| 3442 | (let ((parts (regexec regexp str fields))) |
| 3443 | (if (number? parts) |
| 3444 | (fail parts) |
| 3445 | (apply return parts)))) |
| 3446 | |
| 3447 | \f |
| 3448 | ;;; {Load debug extension code if debug extensions present.} |
| 3449 | ;;; |
| 3450 | ;;; *fixme* This is a temporary solution. |
| 3451 | ;;; |
| 3452 | |
| 3453 | (if (memq 'debug-extensions *features*) |
| 3454 | (define-module (guile) :use-module (ice-9 debug))) |
| 3455 | |
| 3456 | \f |
| 3457 | ;;; {Load thread code if threads are present.} |
| 3458 | ;;; |
| 3459 | ;;; *fixme* This is a temporary solution. |
| 3460 | ;;; |
| 3461 | |
| 3462 | (if (memq 'threads *features*) |
| 3463 | (define-module (guile) :use-module (ice-9 threads))) |
| 3464 | |
| 3465 | \f |
| 3466 | ;;; {Load emacs interface support if emacs option is given.} |
| 3467 | ;;; |
| 3468 | ;;; *fixme* This is a temporary solution. |
| 3469 | ;;; |
| 3470 | |
| 3471 | (if (or (member "-e" (cdr (program-arguments))) |
| 3472 | (member "--emacs" (cdr (program-arguments)))) |
| 3473 | (define-module (guile) :use-module (ice-9 emacs))) |
| 3474 | |
| 3475 | \f |
| 3476 | |
| 3477 | (define-module (guile)) |
| 3478 | |
| 3479 | (append! %load-path (cons "." ())) |