yasi

Check-in [a1fc67cd62]
Login

Check-in [a1fc67cd62]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Add let/let*/letrec. Much easier with quasiquote.
Timelines: family | ancestors | descendants | both | trunk | SEED_0_1_3
Files: files | file ages | folders
SHA1: a1fc67cd62041dd74b5c34bd964c3f2541907fe1
User & Date: martin 2013-06-26 21:44:53
Context
2013-06-28
14:36
Add & use abstrations for handling types and marks; rename type enum to sexp_type; add an exit primitive check-in: 2255fcbf82 user: martin tags: trunk
2013-06-26
21:44
Add let/let*/letrec. Much easier with quasiquote. check-in: a1fc67cd62 user: martin tags: trunk, SEED_0_1_3
2013-06-25
02:45
Welcome 0.1.2 check-in: cddbcd846e user: martin tags: trunk, SEED_0_1_2
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to Makefile. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

CC=gcc

CFLAGS=-Wall -Wextra -pedantic -std=c89 -g -pipe

OBJS=display.o env.o eval.o init.o memory.o \
primitives.o read.o seed.o symtab.o types.o 

VERSION="0.1.2"
BANNER="Seed $(VERSION)"

BIN=seed

all: repl test

$(BIN): $(OBJS)








|








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

CC=gcc

CFLAGS=-Wall -Wextra -pedantic -std=c89 -g -pipe

OBJS=display.o env.o eval.o init.o memory.o \
primitives.o read.o seed.o symtab.o types.o 

VERSION="0.1.3"
BANNER="Seed $(VERSION)"

BIN=seed

all: repl test

$(BIN): $(OBJS)
︙︙

Changes to init.seed. 

1
2
3
4


5
6
7
8
9
10
11
12
13
14
15
16
17
18

(define list (lambda x x))

(define list? (lambda (x) (or (pair? x) (null? x))))



(define procedure? 
  (lambda (x) 
    (or (primitive? x)
        (special? x)
        (lambda? x)
        (fexp? x)
) ) )

(define newline (lambda () (puts "")))

(define else begin)

(define reduce
	(lambda (f x l)





>
>





|
<








1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19

(define list (lambda x x))

(define list? (lambda (x) (or (pair? x) (null? x))))

(define atom? (lambda (x) (not (pair? x))))

(define procedure? 
  (lambda (x) 
    (or (primitive? x)
        (special? x)
        (lambda? x)
        (fexp? x))))


(define newline (lambda () (puts "")))

(define else begin)

(define reduce
	(lambda (f x l)
︙︙
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






























































































					(qq-list (car form) depth)
					(qq      (cdr form) depth))))

		;; No ,@
		;; Entry
		(define qq
			(lambda (form depth)
				(cond	((not (pair? form)) form)

					((eq? 'quasiquote (car form))
						(more form depth))

					((eq? 'unquote (car form))
						(less form depth))

					((eq? 'unquote-splicing (car form))
						(error "unquote-splicing must be in a list"))

					(else (add form depth))

		)	)	)

		;; ,@ is ok
		(define qq-list
			(lambda (form depth)
				(cond	((not (pair? form)) (list form))

					((eq? 'quasiquote (car form))
						(list (more form depth)))

					((eq? 'unquote (car form))
						(list (less form depth)))

					((eq? 'unquote-splicing (car form))
						(if (= depth 0)
							(eval (cadr form) #env)
							(list (cons (car form) (qq (cdr form) (- depth 1))))))

					(else (list (add form depth)))


		)	)	)






		(qq form 0)))







































































































|








|

|
<
<




|












|

>
|
>
>
>
>

>
|
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185

					(qq-list (car form) depth)
					(qq      (cdr form) depth))))

		;; No ,@
		;; Entry
		(define qq
			(lambda (form depth)
				(cond	((atom? form) form)

					((eq? 'quasiquote (car form))
						(more form depth))

					((eq? 'unquote (car form))
						(less form depth))

					((eq? 'unquote-splicing (car form))
						(error "unquote-splicing must be in a list" form))

					(else (add form depth)))))



		;; ,@ is ok
		(define qq-list
			(lambda (form depth)
				(cond	((atom? form) (list form))

					((eq? 'quasiquote (car form))
						(list (more form depth)))

					((eq? 'unquote (car form))
						(list (less form depth)))

					((eq? 'unquote-splicing (car form))
						(if (= depth 0)
							(eval (cadr form) #env)
							(list (cons (car form) (qq (cdr form) (- depth 1))))))

					(else (list (add form depth))))))

		(qq form 0)))

(define map
	(lambda (f l)
		(if (null? l) l
			(cons (f (car l)) (map f (cdr l))))))

(define let
	(fexp form
		(define name #f)

		(if (symbol? (car form))
			(begin
				(set! name (car form))
				(set! form (cdr form))))

		(define vars (map car (car form)))
		(define args (map cadr (car form)))
		(define body (cdr form))

		(if name
			(eval
;				`((lambda ()
;					(define ,name
;						(lambda ,vars ,@body))
;					(,name ,@args)))
;				`(let ((,name (lambda ,vars ,@body)))
;					(,name ,@args))
				;; (let ((f -)) (let f ((n (f 1))) n)) 
				`(let ((#let-args (lambda () (list ,@args)))
							(,name (lambda ,vars ,@body)))
					(apply ,name (#let-args)))
				#env)
			(eval
				`((lambda ,vars ,@body) ,@args)
				#env))))

(define length
	(lambda (lst)
		(define aux
			(lambda (lst cnt)
				(if (null? lst) cnt
					(aux (cdr lst) (+ 1 cnt)))))
		(aux lst 0)))

;(define let*
;	(fexp form
;
;		(define vars (map car (car form)))
;		(define args (map cadr (car form)))
;		(define body (cdr form))
;
;		(if (= 1 (length vars))
;			(eval
;				`(let ((,(car vars) ,(car args)))
;					,@body)
;				#env)
;			(eval
;				`(let ((,(car vars) ,(car args)))
;					(let* ,(cdar form)
;						,@body))
;				#env))))

(define let*
	(fexp form
		(if (null? (car form))
			`(let () ,@(cdr form))
			`(let (,(caar form))
				(let* ,(cdar form)
					,@(cdr form))))))

(define letrec
	(fexp (lofp . body)
		(eval
			`(let
				,(map
					(lambda (var) `(,var #f))
					(map car lofp))
				,@(map (lambda (p) (cons 'set! p)) lofp)
				,@body)
			#env)))
			
(define error
	(lambda msgs
		(newline)
		(map 
			(lambda (x) (display x) (display " "))
			(cons 'ERROR: msgs))
		(newline)
		(fflush)
		(/ 1 0)))

(define car
	(let ((prim-car car))
		(define aux
			(lambda (pair)
				(if (atom? pair)
					(error "CAR: not a pair:" pair)
					(prim-car pair))))
		aux))