nendo 0.1.0 → 0.2.0

This diff represents the content of publicly available package versions that have been released to one of the supported registries. The information contained in this diff is provided for informational purposes only and reflects changes between package versions as they appear in their respective public registries.
Files changed (10) hide show
  1. data/emacs/nendo-mode.el +84 -0
  2. data/lib/init.nnd +339 -228
  3. data/lib/init.nndc +8676 -0
  4. data/lib/nendo.rb +372 -110
  5. data/sample/exit.nnd +2 -0
  6. data/sample/fact.nnd +15 -0
  7. data/sample/fizzbuzz1.nnd +23 -0
  8. data/sample/scratch.nnd +11 -0
  9. data/sample/tak.nnd +13 -0
  10. metadata +11 -6
data/lib/init.nnd CHANGED
@@ -3,18 +3,25 @@
3
3
  ;; ----------------------------------------
4
4
  ;; define
5
5
  ;; ----------------------------------------
6
- (set! define
6
+ (define define
7
7
  (macro (arg . body)
8
8
  (if (not (pair? arg))
9
- (cons 'set!
9
+ ;; (define var body)
10
+ (cons 'define
10
11
  (cons arg
11
12
  body))
12
- (cons 'set!
13
- (cons (car arg)
14
- (list
15
- (cons 'lambda
16
- (cons (cdr arg)
17
- body))))))))
13
+ ;; (define (func arg...) body)
14
+ (begin
15
+ (if (pair? (cdr arg))
16
+ (if (pair? (car (cdr arg)))
17
+ (error "Error: define syntax error.")))
18
+ (cons 'define
19
+ (cons (car arg)
20
+ (list
21
+ (cons 'lambda
22
+ (cons (cdr arg)
23
+ body)))))))))
24
+
18
25
 
19
26
  ;; ----------------------------------------
20
27
  ;; car and cdr functions
@@ -55,15 +62,17 @@
55
62
  (define iota range)
56
63
 
57
64
  (define (append a b)
58
- (define (append-reverse a b)
59
- (if (pair? a)
60
- (append-reverse (cdr a) (cons (car a) b))
61
- b))
62
- (append-reverse (reverse a) b))
65
+ (letrec ((append-reverse
66
+ (lambda (a b)
67
+ (if (pair? a)
68
+ (append-reverse (cdr a) (cons (car a) b))
69
+ b))))
70
+ (append-reverse (reverse a) b)))
63
71
 
64
72
  ;; ----------------------------------------
65
73
  ;; Utility functions
66
74
  ;; ----------------------------------------
75
+ (define list? pair?)
67
76
  (define (even? n) (= (% n 2) 0))
68
77
  (define (odd? n) (not (= (% n 2) 0)))
69
78
  (define (zero? n) (= n 0))
@@ -77,15 +86,16 @@
77
86
  (define (succ x) (+ x 1))
78
87
  (define (pred x) (- x 1))
79
88
  (define (nth n lst)
80
- (define (nth-iter n index lst)
81
- (if (null? lst)
82
- nil
83
- (if (not (pair? lst))
84
- (error "Error: nth got improper list.")
85
- (if (eqv? n index)
86
- (car lst)
87
- (nth-iter n (+ index 1) (cdr lst))))))
88
- (nth-iter n 0 lst))
89
+ (letrec ((nth-iter
90
+ (lambda (n index lst)
91
+ (if (null? lst)
92
+ nil
93
+ (if (not (pair? lst))
94
+ (error "Error: nth got improper list.")
95
+ (if (eqv? n index)
96
+ (car lst)
97
+ (nth-iter n (+ index 1) (cdr lst))))))))
98
+ (nth-iter n 0 lst)))
89
99
  (define (first lst) (nth 0 lst))
90
100
  (define (second lst) (nth 1 lst))
91
101
  (define (third lst) (nth 2 lst))
@@ -97,7 +107,6 @@
97
107
  (define (ninth lst) (nth 8 lst))
98
108
  (define (tenth lst) (nth 9 lst))
99
109
 
100
-
101
110
  ;; ----------------------------------------
102
111
  ;; basic forms
103
112
  ;; ----------------------------------------
@@ -112,38 +121,38 @@
112
121
 
113
122
  (define cond
114
123
  (macro lst
115
- (define (case-block elem . elseblock)
116
- (let ((condition (if (eq? 'else (car elem))
117
- true
118
- (car elem)))
119
- (body (cdr elem))
120
- (tmpsym (gensym)))
121
- ;;(display "CONDITION") (print condition)
122
- ;;(display "BODY") (print body)
123
- ;;(display "TMPSYM") (print tmpsym)
124
- (append
125
- (if (eq? 'feedto (car body))
126
- (cons 'if
127
- (list
128
- (list 'set! tmpsym condition)
129
- (list (cadr body) tmpsym)))
130
- (cons 'if
131
- (list
132
- condition
133
- (cons 'begin body))))
134
- (if (< 0 (length elseblock))
135
- elseblock
136
- '()))))
137
-
138
- (define (cond-iter lst)
139
- (if (eq? 0 (length lst))
140
- '()
141
- (if (eq? 1 (length lst))
142
- (case-block (car lst) '())
143
- (case-block (car lst)
144
- (cond-iter (cdr lst))))))
145
-
146
- (cond-iter lst)))
124
+ (letrec ((case-block
125
+ (lambda (elem . elseblock)
126
+ (let ((condition (if (eq? 'else (car elem))
127
+ true
128
+ (car elem)))
129
+ (body (cdr elem))
130
+ (tmpsym (gensym)))
131
+ ;;(display "CONDITION") (print condition)
132
+ ;;(display "BODY") (print body)
133
+ ;;(display "TMPSYM") (print tmpsym)
134
+ (append
135
+ (if (eq? 'feedto (car body))
136
+ (cons 'if
137
+ (list
138
+ (list 'set! tmpsym condition)
139
+ (list (cadr body) tmpsym)))
140
+ (cons 'if
141
+ (list
142
+ condition
143
+ (cons 'begin body))))
144
+ (if (< 0 (length elseblock))
145
+ elseblock
146
+ '())))))
147
+ (cond-iter
148
+ (lambda (lst)
149
+ (if (eq? 0 (length lst))
150
+ '()
151
+ (if (eq? 1 (length lst))
152
+ (case-block (car lst) '())
153
+ (case-block (car lst)
154
+ (cond-iter (cdr lst))))))))
155
+ (cond-iter lst))))
147
156
 
148
157
  (define let1
149
158
  (macro (var expr . body)
@@ -153,51 +162,43 @@
153
162
 
154
163
  (define or
155
164
  (macro lst
156
- (define (or-iter lst)
157
- (cond
158
- ((eq? 0 (length lst))
159
- false)
160
- ((eq? 1 (length lst))
161
- (let1 sym (gensym)
162
- (list 'let1 sym (car lst)
163
- (list 'if sym sym false))))
164
- (else
165
- (let1 sym (gensym)
166
- (list 'let1 sym (car lst)
167
- (list 'if sym sym (or-iter (cdr lst))))))))
168
- (or-iter lst)))
165
+ (letrec ((or-iter
166
+ (lambda (lst)
167
+ (cond
168
+ ((eq? 0 (length lst))
169
+ false)
170
+ ((eq? 1 (length lst))
171
+ (let1 sym (gensym)
172
+ (list 'let1 sym (car lst)
173
+ (list 'if sym sym false))))
174
+ (else
175
+ (let1 sym (gensym)
176
+ (list 'let1 sym (car lst)
177
+ (list 'if sym sym (or-iter (cdr lst))))))))))
178
+ (or-iter lst))))
169
179
 
170
180
  (define and
171
181
  (macro lst
172
- (define (and-iter lst)
173
- (cond
174
- ((eq? 0 (length lst))
175
- true)
176
- ((eq? 1 (length lst))
177
- (car lst))
178
- (else
179
- (list 'if (list 'not (list 'eq? 'false (car lst)))
180
- (and-iter (cdr lst))
181
- 'false))))
182
- (and-iter lst)))
183
-
184
- (define apply
185
- (macro (proc . args)
186
- (define (strip-quote lst)
187
- (if (eq? 'quote (car lst))
188
- (cadr lst)
189
- lst))
190
- (define (apply-iter lst)
191
- (cond
192
- ((eq? 0 (length lst))
193
- '())
194
- ((eq? 1 (length lst))
195
- (if (pair? (car lst))
196
- (strip-quote (car lst))
197
- (error "not a proper list")))
198
- (else
199
- (append (list (car lst)) (apply-iter (cdr lst))))))
200
- (append (list proc) (apply-iter args))))
182
+ (letrec ((and-iter
183
+ (lambda (lst)
184
+ (cond
185
+ ((eq? 0 (length lst))
186
+ true)
187
+ ((eq? 1 (length lst))
188
+ (car lst))
189
+ (else
190
+ (list 'if (list 'not (list 'eq? 'false (car lst)))
191
+ (and-iter (cdr lst))
192
+ 'false))))))
193
+ (and-iter lst))))
194
+
195
+
196
+ (define (apply proc . args)
197
+ (if (null? args)
198
+ (proc)
199
+ ((lambda (lol)
200
+ (apply1 proc (append (reverse (cdr lol)) (car lol))))
201
+ (reverse args))))
201
202
 
202
203
 
203
204
  ;; The following quasiquote macro is due to Eric S. Tiedemann. ( Imported from TinyScheme )
@@ -206,52 +207,56 @@
206
207
  ;; Subsequently modified for initialize library for nendo: Kiyoka Nishiyama
207
208
  (define quasiquote
208
209
  (macro (l)
209
- (define (mcons f l r)
210
- (if (and (pair? r)
211
- (eq? (car r) 'quote)
212
- (eq? (car (cdr r)) (cdr f))
213
- (pair? l)
214
- (eq? (car l) 'quote)
215
- (eq? (car (cdr l)) (car f)))
216
- (if (or (procedure? f) (number? f) (string? f))
217
- f
218
- (list 'quote f))
219
- (list 'cons l r)))
220
- (define (mappend f l r)
221
- (if (or (null? (cdr f))
222
- (and (pair? r)
223
- (eq? (car r) 'quote)
224
- (eq? (car (cdr r)) '())))
225
- l
226
- (list 'append l r)))
227
- (define (foo level form)
228
- (cond ((not (pair? form))
229
- (if (or (procedure? form) (number? form) (string? form))
230
- form
231
- (list 'quote form))
232
- )
233
- ((eq? 'quasiquote (car form))
234
- (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
235
- (else (if (zero? level)
236
- (cond ((eq? (car form) 'unquote) (car (cdr form)))
237
- ((eq? (car form) 'unquote-splicing)
238
- (error "Unquote-splicing wasn't in a list:"
239
- form))
240
- ((and (pair? (car form))
241
- (eq? (car (car form)) 'unquote-splicing))
242
- (mappend form (car (cdr (car form)))
243
- (foo level (cdr form))))
244
- (else (mcons form (foo level (car form))
245
- (foo level (cdr form)))))
246
- (cond ((eq? (car form) 'unquote)
247
- (mcons form ''unquote (foo (- level 1)
248
- (cdr form))))
249
- ((eq? (car form) 'unquote-splicing)
250
- (mcons form ''unquote-splicing
251
- (foo (- level 1) (cdr form))))
252
- (else (mcons form (foo level (car form))
253
- (foo level (cdr form)))))))))
254
- (foo 0 l)))
210
+ (letrec ((mcons
211
+ (lambda (f l r)
212
+ (if (and (pair? r)
213
+ (eq? (car r) 'quote)
214
+ (eq? (car (cdr r)) (cdr f))
215
+ (pair? l)
216
+ (eq? (car l) 'quote)
217
+ (eq? (car (cdr l)) (car f)))
218
+ (if (or (procedure? f) (number? f) (string? f))
219
+ f
220
+ (list 'quote f))
221
+ (list 'cons l r))))
222
+
223
+ (mappend
224
+ (lambda (f l r)
225
+ (if (or (null? (cdr f))
226
+ (and (pair? r)
227
+ (eq? (car r) 'quote)
228
+ (eq? (car (cdr r)) '())))
229
+ l
230
+ (list 'append l r))))
231
+ (foo
232
+ (lambda (level form)
233
+ (cond ((not (pair? form))
234
+ (if (or (procedure? form) (number? form) (string? form))
235
+ form
236
+ (list 'quote form))
237
+ )
238
+ ((eq? 'quasiquote (car form))
239
+ (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
240
+ (else (if (zero? level)
241
+ (cond ((eq? (car form) 'unquote) (car (cdr form)))
242
+ ((eq? (car form) 'unquote-splicing)
243
+ (error "Unquote-splicing wasn't in a list:"
244
+ form))
245
+ ((and (pair? (car form))
246
+ (eq? (car (car form)) 'unquote-splicing))
247
+ (mappend form (car (cdr (car form)))
248
+ (foo level (cdr form))))
249
+ (else (mcons form (foo level (car form))
250
+ (foo level (cdr form)))))
251
+ (cond ((eq? (car form) 'unquote)
252
+ (mcons form ''unquote (foo (- level 1)
253
+ (cdr form))))
254
+ ((eq? (car form) 'unquote-splicing)
255
+ (mcons form ''unquote-splicing
256
+ (foo (- level 1) (cdr form))))
257
+ (else (mcons form (foo level (car form))
258
+ (foo level (cdr form)))))))))))
259
+ (foo 0 l))))
255
260
 
256
261
  (define unquote
257
262
  (macro (lst)
@@ -286,6 +291,26 @@
286
291
  `(while (not ,(car form))
287
292
  ,@(cdr form))))
288
293
 
294
+ ;; named let supporting
295
+ (define let
296
+ (macro lst
297
+ (if (symbol? (car lst))
298
+ ;; named let
299
+ `(letrec ((,(first lst)
300
+ (lambda ,(map
301
+ (lambda (x)
302
+ (first x))
303
+ (second lst))
304
+ ,(third lst))))
305
+ (,(first lst)
306
+ ,@(map
307
+ (lambda (x)
308
+ (second x))
309
+ (second lst))))
310
+
311
+ ;; don't touch
312
+ `(let ,@lst))))
313
+
289
314
 
290
315
  ;; ----------------------------------------
291
316
  ;; List utilities imported from TinyScheme
@@ -345,21 +370,56 @@
345
370
  (define (filter pred lst)
346
371
  (if (null? lst)
347
372
  '()
348
- (let1 result (pred (car lst))
349
- (if result
350
- (cons
351
- result
352
- (filter pred (cdr lst)))
353
- (filter pred (cdr lst))))))
373
+ (if (pred (car lst))
374
+ (cons
375
+ (car lst)
376
+ (filter pred (cdr lst)))
377
+ (filter pred (cdr lst)))))
378
+
354
379
 
355
380
  (define (filter-map pred lst)
356
381
  (if (null? lst)
357
382
  '()
358
- (if (pred (car lst))
359
- (cons
360
- (car lst)
361
- (filter-map pred (cdr lst)))
362
- (filter-map pred (cdr lst)))))
383
+ (let1 result (pred (car lst))
384
+ (if result
385
+ (cons
386
+ result
387
+ (filter-map pred (cdr lst)))
388
+ (filter-map pred (cdr lst))))))
389
+
390
+
391
+ (define lambda
392
+ (macro src
393
+ (if (not (list? (cadr src)))
394
+ `(lambda ,@src)
395
+ (let1 body (cdr src)
396
+ (if (not (list? (car body)))
397
+ `(lambda ,@src)
398
+ (let ((defs
399
+ (filter
400
+ (lambda (x)
401
+ (and (eq? 'define (car x))
402
+ (symbol? (cadr x))))
403
+ body))
404
+ (rest
405
+ (filter
406
+ (lambda (x)
407
+ (not (and (eq? 'define (car x))
408
+ (symbol? (cadr x)))))
409
+ body)))
410
+ (if (< 0 (length defs))
411
+ `(lambda
412
+ ,(car src)
413
+ (letrec
414
+ ,(map
415
+ (lambda (x)
416
+ (list
417
+ (cadr x)
418
+ (caddr x)))
419
+ defs)
420
+ ,@rest))
421
+ ;; found no `internal-define' syntax
422
+ `(lambda ,@src))))))))
363
423
 
364
424
 
365
425
  ;; ----------------------------------------
@@ -367,51 +427,54 @@
367
427
  ;; ----------------------------------------
368
428
  (define case
369
429
  (macro (cond-exp . body)
370
- (define (case-block val . elem)
371
- (let1 block (car elem)
372
- (let ((cond-vals (car block))
373
- (body (cdr block)))
374
- (let1 v
375
- (if (eq? 'else cond-vals)
376
- cond-vals
377
- (cons 'or
378
- (map
379
- (lambda (x)
380
- `(eqv? ,x ,val))
381
- cond-vals)))
382
- `((,v
383
- ,@body))))))
430
+ (letrec ((case-block
431
+ (lambda (val . elem)
432
+ (let1 block (car elem)
433
+ (let ((cond-vals (car block))
434
+ (body (cdr block)))
435
+ (let1 v
436
+ (if (eq? 'else cond-vals)
437
+ cond-vals
438
+ (cons 'or
439
+ (map
440
+ (lambda (x)
441
+ `(eqv? ,x ,val))
442
+ cond-vals)))
443
+ `((,v
444
+ ,@body)))))))
384
445
 
385
- (define (case-iter val lst)
386
- (cond
387
- ((eq? 0 (length lst))
388
- '())
389
- ((eq? 1 (length lst))
390
- (case-block val (car lst)))
391
- (else
392
- (append (case-block val (car lst))
393
- (case-iter val (cdr lst))))))
394
-
395
- (let1 sym (gensym)
396
- `(let1 ,sym ,cond-exp
397
- (cond
398
- ,@(case-iter sym body))))))
446
+ (case-iter
447
+ (lambda (val lst)
448
+ (cond
449
+ ((eq? 0 (length lst))
450
+ '())
451
+ ((eq? 1 (length lst))
452
+ (case-block val (car lst)))
453
+ (else
454
+ (append (case-block val (car lst))
455
+ (case-iter val (cdr lst))))))))
456
+
457
+ (let1 sym (gensym)
458
+ `(let1 ,sym ,cond-exp
459
+ (cond
460
+ ,@(case-iter sym body)))))))
399
461
 
400
462
 
401
463
  (define let*
402
464
  (macro (exps . body)
403
- (define (let*-expand rest body)
404
- (case (length rest)
405
- ((0)
406
- '())
407
- ((1)
408
- `(let (,(car rest))
409
- ,@body))
410
- (else
411
- `(let (,(car rest))
412
- ,(let*-expand (cdr rest) body)))))
465
+ (letrec ((let*-expand
466
+ (lambda (rest body)
467
+ (case (length rest)
468
+ ((0)
469
+ '())
470
+ ((1)
471
+ `(let (,(car rest))
472
+ ,@body))
473
+ (else
474
+ `(let (,(car rest))
475
+ ,(let*-expand (cdr rest) body)))))))
413
476
 
414
- (let*-expand exps body)))
477
+ (let*-expand exps body))))
415
478
 
416
479
 
417
480
  ;; ----------------------------------------
@@ -420,36 +483,37 @@
420
483
  ;; dot_operator
421
484
  (define dot-operator
422
485
  (macro lst
423
- (define (dot-operator-iter lst)
486
+ (letrec ((dot-operator-iter
487
+ (lambda (lst)
488
+ (cond
489
+ ((null? lst)
490
+ '())
491
+ ((pair? lst)
492
+ (if (eq? 'dot-operator (car lst))
493
+ (intern
494
+ (string-join
495
+ (map
496
+ (lambda (x)
497
+ (if (pair? x)
498
+ (to-s (dot-operator-iter x))
499
+ (if (symbol? x)
500
+ (to-s x)
501
+ (error (sprintf "dot-operator requires symbol, but got %s" x)))))
502
+ (cdr lst))
503
+ "."))
504
+ (error "dot-operator requires symbol or (. symbol symbol) form.")))
505
+ (else
506
+ lst)))))
507
+
424
508
  (cond
425
- ((null? lst)
426
- '())
427
- ((pair? lst)
428
- (if (eq? 'dot-operator (car lst))
429
- (intern
430
- (string-join
431
- (map
432
- (lambda (x)
433
- (if (pair? x)
434
- (to-s (dot-operator-iter x))
435
- (if (symbol? x)
436
- (to-s x)
437
- (error (sprintf "dot-operator requires symbol, but got %s" x)))))
438
- (cdr lst))
439
- "."))
440
- (error "dot-operator requires symbol or (. symbol symbol) form.")))
509
+ ((eq? 0 (length lst))
510
+ (error ". operator requires argument"))
511
+ ((and (eq? 1 (length lst))
512
+ (symbol? (car lst)))
513
+ (intern (+ "." (to-s (car lst)))))
441
514
  (else
442
- lst)))
443
-
444
- (cond
445
- ((eq? 0 (length lst))
446
- (error ". operator requires argument"))
447
- ((and (eq? 1 (length lst))
448
- (symbol? (car lst)))
449
- (intern (+ "." (to-s (car lst)))))
450
- (else
451
- ((dot-operator-iter
452
- (cons 'dot-operator lst)))))))
515
+ ((dot-operator-iter
516
+ (cons 'dot-operator lst))))))))
453
517
 
454
518
  (define (with-open filename pred . lst)
455
519
  (let1 len (length lst)
@@ -475,12 +539,59 @@
475
539
 
476
540
 
477
541
  ;; ----------------------------------------
478
- ;; Utility function for testing
542
+ ;; Utility function for testing and debugging
479
543
  ;; ----------------------------------------
480
- ;; pass through the argument value as return value.
481
- (define (pass x) x)
544
+ ;; Gauche's #?= like debug print function
545
+ (define debug-print-length 63)
546
+ (define (debug-print-output-func str) ;; default output func
547
+ (STDERR.print str))
548
+ (define (debug-limit-length x)
549
+ (+
550
+ (if (< debug-print-length x.length)
551
+ (let1 n debug-print-length.to_s
552
+ (sprintf (+ "%" n "." n "s ...") x))
553
+ x)
554
+ "\n"))
555
+
556
+ (define debug-print
557
+ (macro (_form sourcefile lineno sourcesexp)
558
+ (let1 val (gensym)
559
+ `(let ((,val nil))
560
+ (debug-print-output-func (debug-limit-length (sprintf "#?=\"%s\":%s:%s" ,sourcefile ,lineno (write-to-string ,sourcesexp))))
561
+ (set! ,val ,_form)
562
+ (debug-print-output-func (debug-limit-length (+ "#?- " (write-to-string ,val))))
563
+ ,val))))
564
+
482
565
 
483
- ;; ruby's p like function.
484
- (define (p x)
485
- (printf "%s\n" x)
486
- x)
566
+ ;;
567
+ ;; imported from this URL ( written by bizen )
568
+ ;; http://practical-scheme.net/wiliki/wiliki.cgi?Gauche%3APrettyPrint
569
+ ;;
570
+ ;; Subsequently modified for initialize library for nendo: Kiyoka Nishiyama
571
+ (define (pretty-print s)
572
+ (define (do-indent level)
573
+ (for-each (lambda (x) (display " ")) (range level)))
574
+ (define (pp-parenl)
575
+ (display "("))
576
+ (define (pp-parenr)
577
+ (display ")"))
578
+ (define (pp-atom e prefix)
579
+ (when prefix (display " "))
580
+ (write e))
581
+ (define (pp-list s level prefix)
582
+ (and prefix (do-indent level))
583
+ (pp-parenl)
584
+ (let loop ((s s)
585
+ (prefix #f))
586
+ (if (null? s)
587
+ (pp-parenr)
588
+ (let1 e (car s)
589
+ (if (list? e)
590
+ (begin (and prefix (newline))
591
+ (pp-list e (+ level 1) prefix))
592
+ (pp-atom e prefix))
593
+ (loop (cdr s) #t)))))
594
+ (if (list? s)
595
+ (pp-list s 0 #f)
596
+ (write s))
597
+ (newline))