109 lines
3.7 KiB
Racket
109 lines
3.7 KiB
Racket
(module runtime mzscheme
|
|
|
|
(provide (struct a60:array (vec dimens))
|
|
(struct a60:switch (choices))
|
|
undefined
|
|
check-boolean
|
|
goto
|
|
get-value
|
|
set-target!
|
|
make-array
|
|
array-ref
|
|
array-set!
|
|
make-switch
|
|
switch-ref
|
|
coerce)
|
|
|
|
(define-struct a60:array (vec dimens))
|
|
(define-struct a60:switch (choices))
|
|
|
|
(define undefined (letrec ([x x]) x))
|
|
(define (check-boolean b) b)
|
|
(define (goto f) (f))
|
|
(define (get-value v) (v))
|
|
(define (set-target! t name v)
|
|
(unless (procedure-arity-includes? t 1)
|
|
(error 'assignment "formal-argument variable ~a is assigned, but actual argument was not assignable"
|
|
name))
|
|
(t v))
|
|
|
|
(define (bad what v)
|
|
(error '|bad value| "expected a ~a, got ~e" what v))
|
|
(define (coerce type v)
|
|
(cond
|
|
[(eq? type 'integer)
|
|
(if (number? v)
|
|
(inexact->exact (floor v))
|
|
(bad 'number v))]
|
|
[(eq? type 'real)
|
|
(if (number? v)
|
|
(exact->inexact v)
|
|
(bad 'number v))]
|
|
[(eq? type 'boolean)
|
|
(if (boolean? v)
|
|
v
|
|
(bad 'boolean v))]
|
|
[else v]))
|
|
|
|
(define (make-array . dimens)
|
|
(make-a60:array
|
|
((let loop ([dimens dimens])
|
|
(if (null? dimens)
|
|
(lambda () undefined)
|
|
(let ([start (car dimens)]
|
|
[end (cadr dimens)])
|
|
(let ([build (loop (cddr dimens))])
|
|
(lambda ()
|
|
(let ([len (add1 (- end start))])
|
|
(let ([v (make-vector len)])
|
|
(let loop ([len len])
|
|
(unless (zero? len)
|
|
(vector-set! v (sub1 len) (build))
|
|
(loop (sub1 len))))
|
|
v))))))))
|
|
dimens))
|
|
|
|
(define (check-array a is who)
|
|
(unless (a60:array? a)
|
|
(error who "not an array: ~e" a))
|
|
(unless (= (length is) (/ (length (a60:array-dimens a)) 2))
|
|
(error who "array dimension ~a doesn't match the number of provided indices ~a"
|
|
(length is) (/ (length (a60:array-dimens a)) 2))))
|
|
|
|
(define (check-index who dimens indices)
|
|
(unless (and (number? (car indices))
|
|
(exact? (car indices))
|
|
(integer? (car indices)))
|
|
(error who "index is not an integer: ~e"
|
|
(car indices)))
|
|
(unless (<= (car dimens) (car indices) (cadr dimens))
|
|
(error who "index ~a out of range ~a:~a"
|
|
(car indices) (car dimens) (cadr dimens))))
|
|
|
|
(define (array-ref a . indices)
|
|
(check-array a indices 'array-reference)
|
|
(let loop ([v (a60:array-vec a)][indices indices][dimens (a60:array-dimens a)])
|
|
(check-index 'array-reference dimens indices)
|
|
(let ([i (vector-ref v (- (car indices) (car dimens)))])
|
|
(if (null? (cdr indices))
|
|
i
|
|
(loop i (cdr indices) (cddr dimens))))))
|
|
|
|
(define (array-set! a val . indices)
|
|
(check-array a indices 'array-assignment)
|
|
(let loop ([v (a60:array-vec a)][indices indices][dimens (a60:array-dimens a)])
|
|
(check-index 'array-assignment dimens indices)
|
|
(if (null? (cdr indices))
|
|
(vector-set! v (- (car indices) (car dimens)) val)
|
|
(loop (vector-ref v (- (car indices) (car dimens))) (cdr indices) (cddr dimens)))))
|
|
|
|
(define (make-switch . choices)
|
|
(make-a60:switch (list->vector choices)))
|
|
(define (switch-ref sw index)
|
|
(unless (and (number? index)
|
|
(integer? index)
|
|
(exact? index)
|
|
(<= 1 index (vector-length (a60:switch-choices sw))))
|
|
(error "bad switch index: " index))
|
|
((vector-ref (a60:switch-choices sw) (sub1 index)))))
|