/usr/share/racket/pkgs/algol60/runtime.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | #lang racket
(require racket/undefined)
(provide (struct-out a60:array)
(struct-out a60:switch)
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 (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))))
|