nendo 0.1.0 → 0.2.0

data/lib/init.nnd

@@ -3,18 +3,25 @@
 ;; ----------------------------------------
 ;; define
 ;; ----------------------------------------
-(set! define
+(define define
       (macro (arg . body)
         (if (not (pair? arg))
-            (cons 'set!
+            ;; (define var body)
+            (cons 'define
                   (cons arg
                         body))
-            (cons 'set!
-                  (cons (car arg)
-                        (list
-                         (cons 'lambda
-                               (cons  (cdr arg)
-                                      body))))))))
+            ;; (define (func arg...) body)
+            (begin
+              (if (pair? (cdr arg))
+                  (if (pair? (car (cdr arg)))
+                      (error "Error: define syntax error.")))
+              (cons 'define
+                    (cons (car arg)
+                          (list
+                           (cons 'lambda
+                                 (cons  (cdr arg)
+                                        body)))))))))
+
 
 ;; ----------------------------------------
 ;; car and cdr functions
@@ -55,15 +62,17 @@
 (define iota range)
 
 (define (append a b)
-  (define (append-reverse a b)
-    (if (pair? a)
-        (append-reverse (cdr a) (cons (car a) b))
-        b))
-  (append-reverse (reverse a) b))
+  (letrec ((append-reverse
+            (lambda (a b)
+              (if (pair? a)
+                  (append-reverse (cdr a) (cons (car a) b))
+                  b))))
+    (append-reverse (reverse a) b)))
 
 ;; ----------------------------------------
 ;; Utility functions
 ;; ----------------------------------------
+(define list? pair?)
 (define (even? n) (= (% n 2) 0))
 (define (odd? n) (not (= (% n 2) 0)))
 (define (zero? n) (= n 0))
@@ -77,15 +86,16 @@
 (define (succ x) (+ x 1))
 (define (pred x) (- x 1))
 (define (nth n lst)
-  (define (nth-iter n index lst)
-    (if (null? lst)
-        nil
-        (if (not (pair? lst))
-            (error "Error: nth got improper list.")
-            (if (eqv? n index)
-                (car lst)
-                (nth-iter n (+ index 1) (cdr lst))))))
-  (nth-iter n 0 lst))
+  (letrec ((nth-iter
+            (lambda (n index lst)
+              (if (null? lst)
+                  nil
+                  (if (not (pair? lst))
+                      (error "Error: nth got improper list.")
+                      (if (eqv? n index)
+                          (car lst)
+                          (nth-iter n (+ index 1) (cdr lst))))))))
+    (nth-iter n 0 lst)))
 (define (first lst)    (nth  0 lst))
 (define (second lst)   (nth  1 lst))
 (define (third lst)    (nth  2 lst))
@@ -97,7 +107,6 @@
 (define (ninth lst)    (nth  8 lst))
 (define (tenth lst)    (nth  9 lst))
 
-
 ;; ----------------------------------------
 ;; basic forms
 ;; ----------------------------------------
@@ -112,38 +121,38 @@
 
 (define cond
   (macro lst
-    (define (case-block elem . elseblock)
-      (let ((condition (if (eq? 'else (car elem))
-                           true
-                           (car elem)))
-            (body      (cdr elem))
-            (tmpsym    (gensym)))
-        ;;(display "CONDITION") (print condition)
-        ;;(display "BODY")      (print body)
-        ;;(display "TMPSYM")    (print tmpsym)
-        (append
-         (if (eq? 'feedto (car body))
-             (cons 'if
-                   (list
-                    (list 'set! tmpsym condition)
-                    (list (cadr body) tmpsym)))
-             (cons 'if
-                   (list
-                    condition
-                    (cons 'begin body))))
-         (if (< 0 (length elseblock))
-             elseblock
-             '()))))
-
-    (define (cond-iter lst)
-      (if (eq? 0 (length lst))
-          '()
-          (if (eq? 1 (length lst))
-              (case-block (car lst) '())
-              (case-block (car lst)
-                          (cond-iter (cdr lst))))))
-    
-    (cond-iter lst)))
+    (letrec ((case-block
+              (lambda (elem . elseblock)
+                (let ((condition (if (eq? 'else (car elem))
+                                     true
+                                     (car elem)))
+                      (body      (cdr elem))
+                      (tmpsym    (gensym)))
+                  ;;(display "CONDITION") (print condition)
+                  ;;(display "BODY")      (print body)
+                  ;;(display "TMPSYM")    (print tmpsym)
+                  (append
+                   (if (eq? 'feedto (car body))
+                       (cons 'if
+                             (list
+                              (list 'set! tmpsym condition)
+                              (list (cadr body) tmpsym)))
+                       (cons 'if
+                             (list
+                              condition
+                              (cons 'begin body))))
+                   (if (< 0 (length elseblock))
+                       elseblock
+                       '())))))
+             (cond-iter
+              (lambda (lst)
+                (if (eq? 0 (length lst))
+                    '()
+                    (if (eq? 1 (length lst))
+                        (case-block (car lst) '())
+                        (case-block (car lst)
+                                    (cond-iter (cdr lst))))))))
+      (cond-iter lst))))
 
 (define let1
   (macro (var expr . body)
@@ -153,51 +162,43 @@
 
 (define or
   (macro lst
-    (define (or-iter lst)
-      (cond
-       ((eq? 0 (length lst))
-        false)
-       ((eq? 1 (length lst))
-        (let1 sym (gensym)
-              (list 'let1 sym (car lst)
-                    (list 'if sym sym false))))
-       (else
-        (let1 sym (gensym)
-              (list 'let1 sym (car lst)
-                    (list 'if sym sym (or-iter (cdr lst))))))))
-    (or-iter lst)))
+    (letrec ((or-iter
+              (lambda (lst)
+                (cond
+                 ((eq? 0 (length lst))
+                  false)
+                 ((eq? 1 (length lst))
+                  (let1 sym (gensym)
+                    (list 'let1 sym (car lst)
+                          (list 'if sym sym false))))
+                 (else
+                  (let1 sym (gensym)
+                    (list 'let1 sym (car lst)
+                          (list 'if sym sym (or-iter (cdr lst))))))))))
+      (or-iter lst))))
 
 (define and
   (macro lst
-    (define (and-iter lst)
-      (cond
-       ((eq? 0 (length lst))
-        true)
-       ((eq? 1 (length lst))
-        (car lst))
-       (else
-        (list 'if (list 'not (list 'eq? 'false (car lst)))
-              (and-iter (cdr lst))
-              'false))))
-    (and-iter lst)))
-
-(define apply
-  (macro (proc . args)
-    (define (strip-quote lst)
-      (if (eq? 'quote (car lst))
-          (cadr lst)
-          lst))
-    (define (apply-iter lst)
-      (cond
-       ((eq? 0 (length lst))
-        '())
-       ((eq? 1 (length lst))
-        (if (pair? (car lst))
-            (strip-quote (car lst))
-            (error "not a proper list")))
-       (else
-        (append (list (car lst)) (apply-iter (cdr lst))))))
-    (append (list proc) (apply-iter args))))
+    (letrec ((and-iter
+              (lambda (lst)
+                (cond
+                 ((eq? 0 (length lst))
+                  true)
+                 ((eq? 1 (length lst))
+                  (car lst))
+                 (else
+                  (list 'if (list 'not (list 'eq? 'false (car lst)))
+                        (and-iter (cdr lst))
+                        'false))))))
+      (and-iter lst))))
+
+
+(define (apply proc . args)
+  (if (null? args)
+      (proc)
+      ((lambda (lol)
+         (apply1 proc (append (reverse (cdr lol)) (car lol))))
+       (reverse args))))
 
 
 ;; The following quasiquote macro is due to Eric S. Tiedemann. ( Imported from TinyScheme )
@@ -206,52 +207,56 @@
 ;; Subsequently modified for initialize library for nendo: Kiyoka Nishiyama
 (define quasiquote
  (macro (l)
-   (define (mcons f l r)
-     (if (and (pair? r)
-              (eq? (car r) 'quote)
-              (eq? (car (cdr r)) (cdr f))
-              (pair? l)
-              (eq? (car l) 'quote)
-              (eq? (car (cdr l)) (car f)))
-         (if (or (procedure? f) (number? f) (string? f))
-               f
-               (list 'quote f))
-         (list 'cons l r)))
-   (define (mappend f l r)
-     (if (or (null? (cdr f))
-             (and (pair? r)
-                  (eq? (car r) 'quote)
-                  (eq? (car (cdr r)) '())))
-         l
-         (list 'append l r)))
-   (define (foo level form)
-     (cond ((not (pair? form))
-               (if (or (procedure? form) (number? form) (string? form))
-                    form
-                    (list 'quote form))
-               )
-           ((eq? 'quasiquote (car form))
-            (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
-           (else (if (zero? level)
-                   (cond ((eq? (car form) 'unquote) (car (cdr form)))
-                         ((eq? (car form) 'unquote-splicing)
-                          (error "Unquote-splicing wasn't in a list:"
-                                 form))
-                         ((and (pair? (car form))
-                               (eq? (car (car form)) 'unquote-splicing))
-                          (mappend form (car (cdr (car form)))
-                                   (foo level (cdr form))))
-                         (else (mcons form (foo level (car form))
-                                         (foo level (cdr form)))))
-                   (cond ((eq? (car form) 'unquote)
-                          (mcons form ''unquote (foo (- level 1)
-                                                     (cdr form))))
-                         ((eq? (car form) 'unquote-splicing)
-                          (mcons form ''unquote-splicing
-                                      (foo (- level 1) (cdr form))))
-                         (else (mcons form (foo level (car form))
-                                         (foo level (cdr form)))))))))
-   (foo 0 l)))
+   (letrec ((mcons
+             (lambda (f l r)
+               (if (and (pair? r)
+                        (eq? (car r) 'quote)
+                        (eq? (car (cdr r)) (cdr f))
+                        (pair? l)
+                        (eq? (car l) 'quote)
+                        (eq? (car (cdr l)) (car f)))
+                   (if (or (procedure? f) (number? f) (string? f))
+                       f
+                       (list 'quote f))
+                   (list 'cons l r))))
+            
+            (mappend
+             (lambda (f l r)
+               (if (or (null? (cdr f))
+                       (and (pair? r)
+                            (eq? (car r) 'quote)
+                            (eq? (car (cdr r)) '())))
+                   l
+                   (list 'append l r))))
+            (foo
+             (lambda (level form)
+               (cond ((not (pair? form))
+                      (if (or (procedure? form) (number? form) (string? form))
+                          form
+                          (list 'quote form))
+                      )
+                     ((eq? 'quasiquote (car form))
+                      (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
+                     (else (if (zero? level)
+                               (cond ((eq? (car form) 'unquote) (car (cdr form)))
+                                     ((eq? (car form) 'unquote-splicing)
+                                      (error "Unquote-splicing wasn't in a list:"
+                                             form))
+                                     ((and (pair? (car form))
+                                           (eq? (car (car form)) 'unquote-splicing))
+                                      (mappend form (car (cdr (car form)))
+                                               (foo level (cdr form))))
+                                     (else (mcons form (foo level (car form))
+                                                  (foo level (cdr form)))))
+                               (cond ((eq? (car form) 'unquote)
+                                      (mcons form ''unquote (foo (- level 1)
+                                                                 (cdr form))))
+                                     ((eq? (car form) 'unquote-splicing)
+                                      (mcons form ''unquote-splicing
+                                             (foo (- level 1) (cdr form))))
+                                     (else (mcons form (foo level (car form))
+                                                  (foo level (cdr form)))))))))))
+     (foo 0 l))))
 
 (define unquote
   (macro (lst)
@@ -286,6 +291,26 @@
     `(while (not ,(car form))
        ,@(cdr form))))
 
+;; named let supporting
+(define let
+  (macro lst
+    (if (symbol? (car lst))
+        ;; named let
+        `(letrec ((,(first lst)
+                   (lambda ,(map
+                             (lambda (x)
+                               (first x))
+                             (second lst))
+                     ,(third lst))))
+           (,(first lst)
+            ,@(map
+               (lambda (x)
+                 (second x))
+               (second lst))))
+           
+        ;; don't touch
+        `(let ,@lst))))
+
 
 ;; ----------------------------------------
 ;; List utilities imported from TinyScheme
@@ -345,21 +370,56 @@
 (define (filter pred lst)
   (if (null? lst)
       '()
-      (let1 result (pred (car lst))
-        (if result
-            (cons
-             result
-             (filter pred (cdr lst)))
-            (filter pred (cdr lst))))))
+      (if (pred (car lst))
+          (cons
+           (car lst)
+           (filter pred (cdr lst)))
+          (filter pred (cdr lst)))))
+
 
 (define (filter-map pred lst)
   (if (null? lst)
       '()
-      (if (pred (car lst))
-          (cons
-           (car lst)
-           (filter-map pred (cdr lst)))
-          (filter-map pred (cdr lst)))))
+      (let1 result (pred (car lst))
+        (if result
+            (cons
+             result
+             (filter-map pred (cdr lst)))
+            (filter-map pred (cdr lst))))))
+
+
+(define lambda
+  (macro src
+    (if (not (list? (cadr src)))
+        `(lambda ,@src)
+        (let1 body (cdr src)
+          (if (not (list? (car body)))
+              `(lambda ,@src)
+              (let ((defs
+                      (filter
+                       (lambda (x)
+                         (and (eq? 'define (car x))
+                              (symbol? (cadr x))))
+                       body))
+                    (rest
+                     (filter
+                      (lambda (x)
+                        (not (and (eq? 'define (car x))
+                                  (symbol? (cadr x)))))
+                      body)))
+                (if (< 0 (length defs))
+                    `(lambda
+                         ,(car src)
+                       (letrec
+                           ,(map
+                             (lambda (x)
+                               (list
+                                (cadr x)
+                                (caddr x)))
+                             defs)
+                         ,@rest))
+                    ;; found no `internal-define' syntax
+                    `(lambda ,@src))))))))
 
 
 ;; ----------------------------------------
@@ -367,51 +427,54 @@
 ;; ----------------------------------------
 (define case
   (macro (cond-exp . body)
-    (define (case-block val . elem)
-      (let1 block (car elem)
-        (let ((cond-vals (car block))
-              (body      (cdr block)))
-          (let1 v
-              (if (eq? 'else cond-vals)
-                  cond-vals
-                  (cons 'or
-                        (map
-                         (lambda (x)
-                           `(eqv? ,x ,val))
-                         cond-vals)))
-            `((,v
-               ,@body))))))
+    (letrec ((case-block
+              (lambda (val . elem)
+                (let1 block (car elem)
+                  (let ((cond-vals (car block))
+                        (body      (cdr block)))
+                    (let1 v
+                        (if (eq? 'else cond-vals)
+                            cond-vals
+                            (cons 'or
+                                  (map
+                                   (lambda (x)
+                                     `(eqv? ,x ,val))
+                                   cond-vals)))
+                      `((,v
+                         ,@body)))))))
     
-    (define (case-iter val lst)
-      (cond
-       ((eq? 0 (length lst))
-        '())
-       ((eq? 1 (length lst))
-        (case-block val (car lst)))
-       (else
-        (append (case-block val (car lst))
-                (case-iter  val (cdr lst))))))
-
-    (let1 sym (gensym)
-      `(let1 ,sym ,cond-exp
-         (cond
-          ,@(case-iter sym body))))))
+             (case-iter
+              (lambda (val lst)
+                (cond
+                 ((eq? 0 (length lst))
+                  '())
+                 ((eq? 1 (length lst))
+                  (case-block val (car lst)))
+                 (else
+                  (append (case-block val (car lst))
+                          (case-iter  val (cdr lst))))))))
+
+      (let1 sym (gensym)
+        `(let1 ,sym ,cond-exp
+           (cond
+            ,@(case-iter sym body)))))))
 
 
 (define let*
   (macro (exps . body)
-    (define (let*-expand rest body)
-      (case (length rest)
-        ((0)
-         '())
-        ((1)
-         `(let (,(car rest))
-            ,@body))
-        (else
-         `(let (,(car rest))
-            ,(let*-expand (cdr rest) body)))))
+    (letrec ((let*-expand
+              (lambda (rest body)
+                (case (length rest)
+                  ((0)
+                   '())
+                  ((1)
+                   `(let (,(car rest))
+                      ,@body))
+                  (else
+                   `(let (,(car rest))
+                      ,(let*-expand (cdr rest) body)))))))
 
-    (let*-expand exps body)))
+      (let*-expand exps body))))
 
 
 ;; ----------------------------------------
@@ -420,36 +483,37 @@
 ;; dot_operator
 (define dot-operator
   (macro lst
-    (define (dot-operator-iter lst)
+    (letrec ((dot-operator-iter
+              (lambda (lst)
+                (cond
+                 ((null? lst)
+                  '())
+                 ((pair? lst)
+                  (if (eq? 'dot-operator (car lst))
+                      (intern
+                       (string-join
+                        (map
+                         (lambda (x)
+                           (if (pair? x)
+                               (to-s (dot-operator-iter x))
+                               (if (symbol? x)
+                                   (to-s x)
+                                   (error (sprintf "dot-operator requires symbol, but got %s" x)))))
+                         (cdr lst))
+                        "."))
+                      (error "dot-operator requires symbol or (. symbol symbol) form.")))
+                 (else
+                  lst)))))
+
       (cond
-       ((null? lst)
-        '())
-       ((pair? lst)
-        (if (eq? 'dot-operator (car lst))
-            (intern
-             (string-join
-              (map
-               (lambda (x)
-                 (if (pair? x)
-                     (to-s (dot-operator-iter x))
-                     (if (symbol? x)
-                         (to-s x)
-                         (error (sprintf "dot-operator requires symbol, but got %s" x)))))
-               (cdr lst))
-              "."))
-            (error "dot-operator requires symbol or (. symbol symbol) form.")))
+       ((eq? 0 (length lst))
+        (error ". operator requires argument"))
+       ((and (eq? 1 (length lst))
+             (symbol? (car lst)))
+        (intern (+ "." (to-s (car lst)))))
        (else
-        lst)))
-
-    (cond
-     ((eq? 0 (length lst))
-      (error ". operator requires argument"))
-     ((and (eq? 1 (length lst))
-           (symbol? (car lst)))
-      (intern (+ "." (to-s (car lst)))))
-     (else
-      ((dot-operator-iter
-        (cons 'dot-operator lst)))))))
+        ((dot-operator-iter
+          (cons 'dot-operator lst))))))))
 
 (define (with-open filename pred . lst)
   (let1 len (length lst)
@@ -475,12 +539,59 @@
 
 
 ;; ----------------------------------------
-;; Utility function for testing
+;; Utility function for testing and debugging
 ;; ----------------------------------------
-;; pass through the argument value as return value.
-(define (pass x) x)
+;; Gauche's #?= like debug print function
+(define debug-print-length 63)
+(define (debug-print-output-func str)  ;; default output func
+  (STDERR.print str))
+(define (debug-limit-length x)
+  (+
+   (if (< debug-print-length x.length)
+       (let1 n debug-print-length.to_s
+         (sprintf (+ "%" n "." n "s ...") x))
+       x)
+   "\n"))
+
+(define debug-print
+  (macro (_form sourcefile lineno sourcesexp)
+    (let1 val (gensym)
+      `(let ((,val nil))
+         (debug-print-output-func (debug-limit-length (sprintf "#?=\"%s\":%s:%s" ,sourcefile ,lineno (write-to-string ,sourcesexp))))
+         (set! ,val ,_form)
+         (debug-print-output-func (debug-limit-length (+       "#?-    " (write-to-string ,val))))
+         ,val))))
+
 
-;; ruby's p like function.
-(define (p x)
-  (printf "%s\n" x)
-  x)
+;;
+;; imported from this URL ( written by bizen )
+;;    http://practical-scheme.net/wiliki/wiliki.cgi?Gauche%3APrettyPrint
+;; 
+;; Subsequently modified for initialize library for nendo: Kiyoka Nishiyama
+(define (pretty-print s)
+  (define (do-indent level)
+    (for-each (lambda (x) (display " ")) (range level)))
+  (define (pp-parenl)
+    (display "("))
+  (define (pp-parenr)
+    (display ")"))
+  (define (pp-atom e prefix)
+    (when prefix (display " "))
+    (write e))
+  (define (pp-list s level prefix)
+    (and prefix (do-indent level))
+    (pp-parenl)
+    (let loop ((s s)
+               (prefix #f))
+      (if (null? s)
+          (pp-parenr)
+          (let1 e (car s)
+            (if (list? e)
+                (begin (and prefix (newline))
+                       (pp-list e (+ level 1) prefix))
+                (pp-atom e prefix))
+            (loop (cdr s) #t)))))
+  (if (list? s)
+      (pp-list s 0 #f)
+      (write s))
+  (newline))