-
Notifications
You must be signed in to change notification settings - Fork 0
/
builtins.scm
120 lines (97 loc) · 3.35 KB
/
builtins.scm
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
108
109
110
111
112
113
114
115
116
117
118
119
120
;; builtins.scm
(use miscmacros)
(define-record logo-function
name ;; name of the function (a symbol)
arity ;; number of arguments (an integer >= 0)
parameters ;; list of parameter names (as symbols, no leading ':' here)
code ;; list of sexps, -OR- a Scheme procedure for builtins
)
(define *logo-functions* (create-namespace #f))
(define (add-logo-function name arity f)
(namespace-define! *logo-functions* name
(make-logo-function name arity '() f)))
;;; --- macros ---
;; Macro(s) for easy definition of Logo functions. Unhygienic, but we
;; want it that way. ;-) (The idea is that we can still refer to ENV
;; and FENV from within the Logo function's body.)
;; (car exp) = define-logo-function
;; (cadr exp) = (name . arglist)
;; (caadr exp) = name
;; (cdadr exp) = arglist
;; (cddr exp) = body (as a list)
(define-syntax define-logo-function
(lambda (exp ren cmp)
(list 'add-logo-function
(list 'quote (caadr exp))
(length (cdadr exp))
(list 'lambda '(env fenv args)
(list 'apply (cons* 'lambda (cdadr exp) (cddr exp))
'args)))))
;;; --- Built-in Logo functions. ---
(define-logo-function (repeat n block)
(if (< n 0)
(while #t (logo-eval-exprs block env fenv)) ;; infinite loop
(dotimes (i n (void))
(logo-eval-exprs block env fenv))))
(define-logo-function (+ a b)
(+ a b))
(define-logo-function (- a b)
(- a b))
(define-logo-function (* a b)
(* a b))
(define-logo-function (say x)
(print x))
(define-logo-function (print x)
(logo-print x))
(define-logo-function (show x)
(printf "~a~%" x))
(define-logo-function (interpolate x)
(logo-interpolate x env fenv))
(define-logo-function (true) #t)
(define-logo-function (false) #f)
(define-logo-function (eval block)
(logo-eval-exprs block env fenv))
;; special form: TO
(define-logo-function (to name args body)
(let ((logo-func
(make-logo-function
name (length args)
(map strip-var-name args)
body)))
(namespace-define! fenv name logo-func)))
;; special form: MAKE
;; Currently used like: ' make :foo 4 '
;; Might be changed to take a symbol literal and/or a string.
(define-logo-function (make var-name value)
(namespace-define! env (strip-var-name var-name)
(logo-eval value env fenv)))
(define-logo-function (forever) -1)
(define-logo-function (load filename)
(with-input-from-file filename
(lambda ()
(let ((sexps (read-all-sexps (current-input-port))))
(logo-eval-exprs sexps env fenv)))))
;;; --- aliases ---
;; NOTE: This only works if the original function has already been
;; defined, of course. So we should do this *after* loading turtle
;; stuff and everything.
;; first item in the list is the original function name, names after
;; that are the aliases.
(define *function-aliases*
'((forward fd)
(backward back)
(right rt)
(left lt)
(print pr)
(interpolate $ intp)))
(define (add-aliases state)
(for-each
(lambda (lst)
(let ((original (car lst))
(aliases (cdr lst))
(fenv (logo-state-function-env state)))
(let ((f (namespace-get fenv original)))
(for-each (lambda (alias)
(namespace-define! fenv alias (second f)))
aliases))))
*function-aliases*))