123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209 |
- (define (char->ascii c)
- (let ((scalar-value (char->scalar-value c)))
- (if (>= scalar-value ascii-limit)
- (signal-condition
- (cons 'call-error
- (cons "not an ASCII character"
- (cons char->ascii (cons c '()))))))
- scalar-value))
- (define (ascii->char x)
- (if (or (>= x ascii-limit) (< x 0))
- (signal-condition
- (cons 'call-error
- (cons"not an ASCII code"
- (cons ascii->char
- (cons x '()))))))
- (scalar-value->char x))
- (define (char->integer c) (char->scalar-value c))
- (define (integer->char n) (scalar-value->char n))
- (define ascii-limit 128)
- (define ascii-whitespaces '(32 9 10 11 12 13))
- (define procedure? closure?)
- (define (invoke-closure closure . args)
- (apply (loophole :procedure closure)
- args))
- (define (primitive-cwcc p)
- (primitive-catch (lambda (cont)
- (p (loophole :escape cont)))))
- (define (make-undefined-location id)
- (let ((loc (make-location id #f)))
- (set-location-defined?! loc #f)
- loc))
- (define (location-assigned? loc)
- (and (location-defined? loc)
- (if (eq? (contents loc)
- (unassigned))
- #f
- #t)))
- (define (cell-unassigned? cell)
- (eq? (cell-ref cell) (unassigned)))
- (define (vector-unassigned? v i)
- (eq? (vector-ref v i) (unassigned)))
- (define (string-copy s)
- (let* ((z (string-length s))
- (copy (make-string z)))
- (copy-string-chars! s 0 copy 0 z)
- copy))
- (define (string->symbol string)
- (intern (if (immutable? string)
- string
- (make-immutable! (string-copy string)))))
- (define (input-port? port)
- (and (port? port)
- (= 1 (bitwise-and 1 (port-status port)))))
- (define (output-port? port)
- (and (port? port)
- (= 2 (bitwise-and 2 (port-status port)))))
- (define (record-type r)
- (record-ref r 0))
- (define (make-code-vector length init) (make-byte-vector length init))
- (define (code-vector? x) (byte-vector? x))
- (define (code-vector-length bv) (byte-vector-length bv))
- (define (code-vector-ref bv i) (byte-vector-ref bv i))
- (define (code-vector-set! bv i x) (byte-vector-set! bv i x))
- (define (lookup-imported-binding name)
- (lookup-shared-binding name #t))
- (define (lookup-exported-binding name)
- (lookup-shared-binding name #f))
- (define (define-imported-binding name value)
- (shared-binding-set! (lookup-shared-binding name #t)
- value))
-
- (define (define-exported-binding name value)
- (shared-binding-set! (lookup-shared-binding name #f)
- value))
- (define (undefine-imported-binding name)
- (undefine-shared-binding name #t))
- (define (undefine-exported-binding name)
- (undefine-shared-binding name #f))
- (define (byte-vector . l)
- (let ((v (make-byte-vector (secret-length l 0) 0)))
- (do ((i 0 (+ i 1))
- (l l (cdr l)))
- ((eq? l '()) v)
- (byte-vector-set! v i (car l)))))
- (define (secret-length list length)
- (if (eq? list '())
- length
- (secret-length (cdr list) (+ length 1))))
- (define (debug-message . stuff)
- (message stuff))
- (define (write-image file-name start-procedure message)
- (let ((undumpable (make-vector 1000 #f)))
- (write-image-low file-name
- start-procedure
- message
- undumpable)
- (if (vector-ref undumpable 0)
- (signal 'error
- "undumpable records written in image"
- (vector-prefix->list undumpable)))))
- (define (vector-prefix->list vector)
- (do ((i 0 (+ i 1))
- (losers '() (cons (vector-ref vector i) losers)))
- ((or (= i (vector-length vector))
- (if (vector-ref vector i) #f #t))
- losers)))
- (define empty-log '#(#f))
- (define (make-proposal)
- (vector #f empty-log empty-log #f))
|