48 lines
1.1 KiB
Scheme
48 lines
1.1 KiB
Scheme
|
|
||
|
|
; Stuff in Pre-Scheme that is not in Scheme.
|
||
|
|
|
||
|
|
(define (ps-read-char port char-cont eof-cont)
|
||
|
|
(let ((next (read-char port)))
|
||
|
|
(if (eof-object? next)
|
||
|
|
(eof-cont)
|
||
|
|
(char-cont next))))
|
||
|
|
|
||
|
|
(define ashl arithmetic-shift)
|
||
|
|
|
||
|
|
(define (ashr i n)
|
||
|
|
(arithmetic-shift i (- 0 n)))
|
||
|
|
|
||
|
|
(define small* *) ; could do a range check
|
||
|
|
|
||
|
|
; What we will get in C.
|
||
|
|
(define pre-scheme-integer-size 32)
|
||
|
|
|
||
|
|
(define int-mask (- (arithmetic-shift 1 pre-scheme-integer-size) 1))
|
||
|
|
|
||
|
|
(define (lshr i n)
|
||
|
|
(if (>= i 0)
|
||
|
|
(arithmetic-shift i (- 0 n))
|
||
|
|
(arithmetic-shift (bitwise-and i int-mask) (- 0 n))))
|
||
|
|
|
||
|
|
(define (deallocate x) #f)
|
||
|
|
|
||
|
|
(define unassigned unspecific)
|
||
|
|
|
||
|
|
(define (write-string str port)
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((>= i (string-length str)))
|
||
|
|
(write-char (string-ref str i) port)))
|
||
|
|
|
||
|
|
(define-syntax goto
|
||
|
|
(lambda (exp rename compare)
|
||
|
|
(cdr exp)))
|
||
|
|
|
||
|
|
(define (null-port? x)
|
||
|
|
#f) ; no null-ports in Scheme
|
||
|
|
|
||
|
|
(define (call-external-value proc nargs pointer-to-args)
|
||
|
|
(error "~S" (list 'call-external-value proc nargs pointer-to-args)))
|
||
|
|
|
||
|
|
(define-syntax external
|
||
|
|
(lambda (exp rename compare)
|
||
|
|
(error "(EXTERNAL ...) can only be compiled" exp)))
|