nendo 0.4.1 → 0.5.0

data/example/scratch.nnd

@@ -2,60 +2,118 @@
 ;; -----------------
 (enable-idebug)
 (disable-idebug)
-(define debug-print-length 2000)
-
-
-
-
-(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? (quote ,x) ,val))
-                         cond-vals)))
-            `((,v
-               ,@body))))))
-  
-    (define (case-iter val lst)
-      (cond
-       ((null? 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))))))
+(exit)
+
+(debug-print-length)
+(debug-print-length 2000)
+
+(error "Error: (error) func test 1")
+(error "Error: (error) func test 1" '(r a i s e))
+
+
+(define (generic-member cmp obj lst)
+  (cond
+    ((null? lst) #f)
+    ((not (pair? lst)) #f)
+    ((cmp obj (car lst)) lst)
+    (else (generic-member cmp obj (cdr lst)))))
+
+
+(memq 'b '(a b c d))
+(memq 'a '(a b c d . e))
+
+
+
+;; :optional feature from Gauche-0.9.1 .
+
+(define %expand-define-form-lambda
+  (lambda (arg body-list)
+    ;; (define (func arg...) body)
+    (if (pair? (cdr arg))
+        (if (pair? (car (cdr arg)))
+            (error "Error: define syntax error.")))
+    (cons 'define
+          (list (car arg)
+                (%transform-optional-arguments (cdr arg) body-list)))))
+
+
+  (define (%transform-optional-arguments arg body-list)
+    (if-let1 rest-of-opts (memq :optional arg)
+             (let([opts         '()]
+                  [rest-of-opts (cdr rest-of-opts)]
+                  [_rest        (gensym)])
+               ;; arguemnt form check
+               (for-each
+                (lambda (x)
+                  (let1 syntax-is-ok  (if (pair? x)
+                                          (= 2 (length x))
+                                          #f)
+                    (unless syntax-is-ok
+                      (error "Error:  :optional format is illegal ... " arg))))
+                rest-of-opts)
+               (let loop ((arg arg))
+                 (if (eq? :optional (car arg))
+                     arg
+                     (begin
+                       (set! opts (cons (car arg) opts))
+                       (loop (cdr arg)))))
+               (let1 new-arg (apply list* (append (reverse opts) (list _rest)))
+                 (list 'lambda
+                       new-arg
+                       `(let
+                            ,rest-of-opts
+                          ,@(map
+                             (lambda (k n)
+                               `(when (< ,n (length ,_rest))
+                                  (set! ,(car k) (nth ,n ,_rest))))
+                             rest-of-opts
+                             (range (length rest-of-opts)))
+                          ,@body-list))))
+             `(lambda ,arg ,@body-list)))
 
+
+(%transform-optional-arguments '(arg1 arg2)
+                               '((begin 1 2)))
+(pretty-print
+ (%transform-optional-arguments '(arg1 arg2 :optional (arg3 #f))
+                                '((begin 1 2))))
+
+(pretty-print
+ (%transform-optional-arguments '(arg1 arg2 :optional (arg3 #f) (arg4 #t))
+                                '((begin 1 2))))
+
+(pretty-print
+ (%transform-optional-arguments '(arg1 arg2 :optional illegal-arg (arg3 #f) (arg4 #t))
+                                '((begin 1 2))))
 (pretty-print
- (macroexpand-1
-  '(case (car '(a b c d))
-     ((a) 'a)
-     ((b) 'b)
-     ((1) 1)
-     (else 'else))))
+ (%transform-optional-arguments '(arg1 arg2 :optional (arg3 #f) (arg4 #t) illegal-arg)
+                                '((begin 1 2))))
+(pretty-print
+ (%transform-optional-arguments '(arg1 arg2 :optional (arg3 #f) illegal-arg (arg4 #t))
+                                '((begin 1 2))))
+
+(pretty-print
+ (%transform-optional-arguments '(arg1 arg2 :optional (arg3 #f #f))
+                                '((begin 1 2))))
 
-(case (caddr '(a b 1 2))
-  ((a) 'a)
-  ((b) 'b)
-  ((1) 1)
-  (else 'else))
 
- 
+(macroexpand
+ '(define (func arg1 arg2)
+    (begin
+      1
+      2)))
 
+(pretty-print
+ (macroexpand
+  '(define (func arg1 arg2 :optional (arg3 #t))
+     (print "1")
+     (print "2"))))
 
+(define (func arg1 arg2 :optional (arg3 #t))
+  (printf "[%d]" arg1)(newline)
+  (printf "[%d]" arg2)(newline)
+  (printf "[%s]" arg3)(newline))
+
+(func 1 2 'a)
 
-(exit)