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
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
(define (foo)
(fact 10)
(fact 20))
(foo)
(foo)
(fact 5)
(define *one* (unassigned))
(define-local-syntax (define-primitive id nargs)
(let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
`(define (,id . ,args)
(call-primitively ,id . ,args))))
(define-local-syntax (define-effect-primitive id nargs)
(let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
`(define (,id . ,args)
(call-primitively ,id . ,args)
(call-primitively undefined-value))))
(define-primitive + 2)
(define-primitive - 2)
(define-primitive * 2)
(define-primitive < 2)
;(define-primitive quotient 2)
;(define-primitive remainder 2)
(define-primitive char->ascii 1)
(define-primitive ascii->char 1)
(define-effect-primitive write-char 2)
(define (unassigned) (call-primitively undefined-value))
(define (byte-vector-ref vec index)
(call-primitively byte-contents (ptr+ vec index)))
(define (byte-vector-set! vec index value)
(call-primitively byte-set-contents! (ptr+ vec index) value))
(define (vector-set! vec index value)
(call-primitively set-contents! (ptr+ vec (* index 4)) value))
;(write-number-no-newline 102 port)
;(define (write-number-no-newline x port)
; (let ((x (cond ((< x 0)
; (write-char '#\- port)
; (- 0 x))
; (else
; x))))
; (let loop ((x x) (mask foo))
; (let ((digit (quotient x mask)))
; (write-char (ascii->char (+ digit (char->ascii '#\0))) port)
; (if (< mask 1)
; (loop (remainder x mask) (quotient mask 10)))))))
(define (fact n)
(let loop ((i n) (r *one*))
(if (<= *one* i)
(loop (- i *one*) (* i r))
r)))
;(define (poobah x)
; (+ x (* x (+ x (* x *two*)))))
;(define *two* 2)
(define (<= x y)
(not (< y x)))
(define (not x)
(if x #f #t))
(define (identity x)
x)
(define (two x)
2)
|
