nendo 0.4.1 → 0.5.0

data/lib/init.nnd

@@ -2,7 +2,7 @@
 ;;;
 ;;; init.nnd - Nendo's init file.
 ;;;  
-;;;   Copyright (c) 2009-2010  Kiyoka Nishiyama  <kiyoka@sumibi.org>
+;;;   Copyright (c) 2009-2011  Kiyoka Nishiyama  <kiyoka@sumibi.org>
 ;;;   
 ;;;   Redistribution and use in source and binary forms, with or without
 ;;;   modification, are permitted provided that the following conditions
@@ -162,7 +162,12 @@
 (define (ninth lst)    (nth  8 lst))
 (define (tenth lst)    (nth  9 lst))
 
-(define (x->string object) (to-s object))
+(define (x->string object)   (to-s object))
+(define (number->string num) (x->string num))
+(define string-append
+  (lambda str-lst
+    (string-join str-lst "")))
+
 
 ;; ----------------------------------------
 ;; basic forms
@@ -442,7 +447,8 @@
 ;; generic-member 
 (define (generic-member cmp obj lst)
   (cond
-    ((null? lst) false)
+    ((null? lst) #f)
+    ((not (pair? lst)) #f)
     ((cmp obj (car lst)) lst)
     (else (generic-member cmp obj (cdr lst)))))
 
@@ -565,14 +571,6 @@
                     `(,_sym ,@_src))))))))
 
 
-(define lambda
-  (macro src
-    (%internal-define-to-letrec 'lambda src)))
-
-(define macro
-  (macro src
-    (%internal-define-to-letrec 'macro src)))
-
 (define (%for-each proc . lists)
   (define (%for-each-arg1 proc lst)
     (if (null? lst)
@@ -629,12 +627,87 @@
         #f
         (car result))))
 
+(define (any pred lst)
+  (let1 result (%filter-map pred lst)
+    (if (null? result)
+        #f
+        (car result))))
+
 (define map         %map)
 (define for-each    %for-each)
 (define filter      %filter)
 (define filter-map  %filter-map)
 
 
+;; ----------------------------------------
+;;  lambda & macro
+;; ----------------------------------------
+(define (%%optional-argument-check target arg-and-body)
+  (let1 arg-list (if (list? arg-and-body)
+                     (car arg-and-body)
+                     '())
+    (when (list? arg-list)
+      (when (any (lambda (x) (keyword? x)) arg-list)
+        (errorf "Error: %s can't handle keyword argument." target)))))
+
+(define lambda
+  (macro src
+    (%%optional-argument-check 'lambda src)
+    (%internal-define-to-letrec 'lambda src)))
+
+(define macro
+  (macro src
+    (%%optional-argument-check 'macro src)
+    (%internal-define-to-letrec 'macro src)))
+
+;; ----------------------------------------
+;; :optional argument feature for define  (The original is Gauche 0.9.1's feature)
+;;  like  "(define (func a b : optional (c #f)) ... )"
+;; ----------------------------------------
+(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)))
+
+(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)))))
+
 
 
 ;; ----------------------------------------
@@ -751,6 +824,11 @@
                    (cadr rest)
                    (cddr rest)))))))))
 
+(define (keyword->symbol kw)
+  (string->symbol
+   (keyword->string kw)))
+  
+
 ;; ----------------------------------------
 ;; for Ruby interop
 ;; ----------------------------------------
@@ -801,7 +879,7 @@
 ;; ----------------------------------------
 ;; hash-table library functions
 ;; ----------------------------------------
-(define (make-hash-table)
+(define (make-hash-table . eq)
   (Hash.new))
 
 (define (hash-table? h)
@@ -810,7 +888,10 @@
 (define (hash-table-num-entries h)
   (h.length))
 
-(define (hash-table . kv-list)
+(define (hash-table type . kv-list)
+  (unless (or (eq? type eq?)
+              (eq? type eqv?))
+    (error "Error: hash-table got eq? or eqv? as type"))
   (let1 h (make-hash-table)
     (for-each
      (lambda (entry)
@@ -844,20 +925,6 @@
      keys)))
 (define hash-table-for-each hash-table-map)
 
-(define (hash-table->alist h)
-  (if (not (h.is_a? Hash))
-      (error "Error: hash-table->alist expects Hash instance.")
-      (let1 keys (hash-table-keys h)
-        (map
-         (lambda (key)
-           (cons key (hash-table-get h key)))
-         keys))))
-
-(define (alist->hash-table alist)
-  (if (not (%list? alist))
-      (error "Error: alist->hash-table expects alist.")
-      (apply hash-table alist)))
-
 
 ;; ----------------------------------------
 ;; Vector Library
@@ -916,15 +983,24 @@
 ;; Utility function for testing and debugging
 ;; ----------------------------------------
 ;; Gauche's #?= like debug print function
-(define debug-print-length 63)
+(define *debug-print-length* 63)
+(define (debug-print-length . len)
+  (let1 len (get-optional len 'none)
+    (if (eq? len 'none)
+        *debug-print-length*
+        (set! *debug-print-length* len))))
 (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)
+   (cond
+    ((not *debug-print-length*)
+     x)
+    ((< *debug-print-length* x.length)
+     (let1 n *debug-print-length*.to_s
+       (sprintf (+ "%" n "." n "s ...") x)))
+    (else
+     x))
    "\n"))
 
 (define debug-print
@@ -1232,8 +1308,14 @@
 ;; ----------------------------------------
 (define (setup-tailcall-mark sexp)
   (define (reserved? sym)
-    (memq sym '(quote macro begin lambda if let letrec define)))
-  
+    (let* ([reserved-orig '(quote syntax-quote macro %syntax begin lambda if let letrec define define-syntax)]
+           [reserved (append reserved-orig
+                             (map
+                              (lambda (orig)
+                                (string->symbol (+ "/nendo/core/" (symbol->string orig))))
+                              reserved-orig))])
+      (memq sym reserved)))
+
   (define (setup-let-args args)
     (map
      (lambda (arg)
@@ -1285,50 +1367,64 @@
    ((null? sexp)
     '())
    ((list? sexp)
-    (case (car sexp)
-      ((quote)
-       sexp)
-      ((macro)
-       sexp)
-      ((begin)
-       `(begin
-          ,@(setup-proc-body (cdr sexp))))
-      ((lambda)
-       `(lambda
-            ,(second sexp)
-          ,@(setup-proc-body (cddr sexp))))
-      ((if)
-       (case (length sexp)
-         ((3)
-          `(if
-            ,(second sexp)
-            ,(setup-proc     (third  sexp))))
-         ((4)
-          `(if
-            ,(second sexp)
-            ,(setup-proc     (third sexp))
-            ,(setup-proc     (fourth sexp))))))
-      ((let)
-       `(let
-            ,(setup-let-args (second sexp))
-          ,@(setup-proc-body (cddr sexp))))
-      ((letrec)
-       `(letrec
-            ,(setup-let-args (second sexp))
-          ,@(setup-proc-body (cddr sexp))))
-      ((define)
-       (let1 val (third sexp)
-         `(define
-            ,(second sexp)
-            ,(if (and (list? val)
-                      (not (null? val))
-                      (reserved? (car val)))
-                 (setup-tailcall-mark val)
-                 val))))
-      (else
-       (if (symbol? (car sexp))
-           `(%tailcall ,sexp)
-           sexp))))
+    (let1 _car (car sexp)
+      (case _car
+        ((quote /nendo/core/quote)
+         sexp)
+        ((syntax-quote /nendo/core/syntax-quote)
+         sexp)
+        ((macro /nendo/core/macro)
+         sexp)
+        ((%syntax /nendo/core/%syntax)
+         sexp)
+        ((begin /nendo/core/begin)
+         `(,_car
+           ,@(setup-proc-body (cdr sexp))))
+        ((lambda /nendo/core/lambda)
+         `(,_car
+              ,(second sexp)
+            ,@(setup-proc-body (cddr sexp))))
+        ((if /nendo/core/if)
+         (case (length sexp)
+           ((3)
+            `(,_car
+              ,(second sexp)
+              ,(setup-proc     (third  sexp))))
+           ((4)
+            `(,_car
+              ,(second sexp)
+              ,(setup-proc     (third sexp))
+              ,(setup-proc     (fourth sexp))))))
+        ((let /nendo/core/let)
+         `(,_car
+           ,(setup-let-args (second sexp))
+           ,@(setup-proc-body (cddr sexp))))
+        ((letrec /nendo/core/letrec)
+         `(,_car
+           ,(setup-let-args (second sexp))
+           ,@(setup-proc-body (cddr sexp))))
+        ((define /nendo/core/define define-syntax /nendo/core/define-syntax)
+         (let1 val (third sexp)
+           `(,_car
+              ,(second sexp)
+              ,(if (and (list? val)
+                        (not (null? val))
+                        (reserved? (car val)))
+                   (setup-tailcall-mark val)
+                   val))))
+        ((set! /nendo/core/set!)
+         (let1 val (third sexp)
+           `(,_car
+             ,(second sexp)
+             ,(if (and (list? val)
+                       (not (null? val))
+                       (reserved? (car val)))
+                  (setup-tailcall-mark val)
+                  val))))
+        (else
+         (if (symbol? (car sexp))
+             `(%tailcall ,sexp)
+             sexp)))))
    (else
     sexp)))
 
@@ -1339,4 +1435,259 @@
        setup-tailcall-mark
        ))
 
+
+
+;; explicit renameing macro transformer
+;;   ported from chibi-scheme-0.3  by Kiyoka Nishiyama
+;;
+;;   URL: http://community.schemewiki.org/?syntactic-closures
+;;
+(define (strip-syntactic-closures expr)
+  expr)
+
+
+(define (identifier? x)
+  (symbol? x))
+
+(define (identifier=? use-env-x x use-env-y y)
+  (eq? x y))
+
+
+;; readable code for nendo. (original code is chibi-scheme-0.3)
+(define er-macro-transformer
+  (lambda (f)
+    (%syntax (expr use-env mac-env)
+      (define (expander-main rename compare)
+        (f expr rename compare))
+      (define (_rename renames)
+        (lambda (identifier)
+          (let ([cell (assq identifier renames)])
+            (if cell
+                (cdr cell)
+                ((lambda (name)
+                   (set! renames (cons (cons identifier name) renames))
+                   name)
+                 (make-syntactic-closure mac-env '() identifier))))))
+      (define (_compare x y)
+        (sprintf "compare( %s %s )" x y)
+        (identifier=? use-env x use-env y))
+      
+      (expander-main
+       (_rename '())
+       _compare))))
+
+
+;; explicit renameing macro transformer
+;;   ported from chibi-scheme-0.3  by Kiyoka Nishiyama
+(define ... '...)
+(define-syntax syntax-rules
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((ellipse-specified? (identifier? (cadr expr)))
+           (count 0)
+           (_er-macro-transformer (rename 'er-macro-transformer))
+           (_lambda (rename 'lambda))      (_let (rename 'let))
+           (_begin (rename 'begin))        (_if (rename 'if))
+           (_and (rename 'and))            (_or (rename 'or))
+           (_eq? (rename 'eq?))            (_equal? (rename 'equal?))
+           (_car (rename 'car))            (_cdr (rename 'cdr))
+           (_cons (rename 'cons))          (_pair? (rename 'pair?))
+           (_null? (rename 'null?))        (_expr (rename 'expr))
+           (_rename (rename 'rename))      (_compare (rename 'compare))
+           (_quote (rename 'syntax-quote)) (_apply (rename 'apply))
+           (_append (rename 'append))      (_map (rename 'map))
+           (_vector? (rename 'vector?))    (_list? (rename 'list?))
+           (_lp (rename 'lp))              (_reverse (rename 'reverse))
+           (_len (rename'len))             (_length (rename 'length))
+           (_- (rename '-))   (_>= (rename '>=))   (_error (rename 'error))
+           (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
+           (_vector->list (rename 'vector->list))
+           (_list->vector (rename 'list->vector)))
+       (define ellipse (rename (if ellipse-specified? (cadr expr) '...)))
+       (define lits (if ellipse-specified? (caddr expr) (cadr expr)))
+       (define forms (if ellipse-specified? (cdddr expr) (cddr expr)))
+       (define (next-v)
+         (set! count (+ count 1))
+         (rename (string->symbol (string-append "v__" (number->string count)))))
+       (define (expand-pattern pat tmpl)
+         (let lp ((p (cdr pat))
+                  (x (list _cdr _expr))
+                  (dim 0)
+                  (vars '())
+                  (k (lambda (vars)
+                       (or (expand-template tmpl vars)
+                           (list _begin #f)))))
+           (let ((v (next-v)))
+             (list
+              _let (list (list v x))
+              (cond
+               ((identifier? p)
+                (if (find (lambda (l) (compare p l)) lits)
+                    (list _and (list _compare v (list _quote p)) (k vars))
+                    (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
+               ((ellipse? p)
+                (cond
+                 ((not (null? (cddr p)))
+                  (cond
+                   ((not (list? (cddr p)))
+                    (error "dotted ellipse" p))
+                   ((find (lambda (x) (and (identifier? x) (compare x ellipse)))
+                         (cddr p))
+                    (error "multiple ellipses" p))
+                   (else
+                    (let ((len (length (cdr (cdr p)))))
+                      `(,_let ((,_len (,_length ,v)))
+                         (,_and (,_>= ,_len ,len)
+                                (,_let ,_lp ((,_ls ,v)
+                                             (,_i (,_- ,_len ,len))
+                                             (,_res (,_quote ())))
+                                  (,_if (,_>= 0 ,_i)
+                                      ,(lp `(,@(cdr (cdr p)) ,(car p) ,(car (cdr p)))
+                                           `(,_append ,_ls (,_reverse ,_res))
+                                           dim
+                                           vars
+                                           k)
+                                      (,_lp (,_cdr ,_ls)
+                                            (,_- ,_i 1)
+                                            (,_cons (,_car ,_ls) ,_res))))))))))
+                 ((identifier? (car p))
+                  (list _and (list _list? v)
+                        (list _let (list (list (car p) v))
+                              (k (cons (cons (car p) (+ 1 dim)) vars)))))
+                 (else
+                  (let* ((w (next-v))
+                         (new-vars (all-vars (car p) (+ dim 1)))
+                         (ls-vars (map (lambda (x)
+                                         (rename
+                                          (string->symbol
+                                           (string-append
+                                            (symbol->string
+                                             (identifier->symbol (car x)))
+                                            "-ls"))))
+                                       new-vars))
+                         (once
+                          (lp (car p) (list _car w) (+ dim 1) '()
+                              (lambda (_)
+                                (cons
+                                 _lp
+                                 (cons
+                                  (list _cdr w)
+                                  (map (lambda (x l)
+                                         (list _cons (car x) l))
+                                       new-vars
+                                       ls-vars)))))))
+                    (list
+                     _let
+                     _lp (cons (list w v)
+                               (map (lambda (x) (list x '())) ls-vars))
+                     (list _if (list _null? w)
+                           (list _let (map (lambda (x l)
+                                             (list (car x) (list _reverse l)))
+                                           new-vars
+                                           ls-vars)
+                                 (k (append new-vars vars)))
+                           (list _and (list _pair? w) once)))))))
+               ((pair? p)
+                (list _and (list _pair? v)
+                      (lp (car p)
+                          (list _car v)
+                          dim
+                          vars
+                          (lambda (vars)
+                            (lp (cdr p) (list _cdr v) dim vars k)))))
+               ((vector? p)
+                (list _and
+                      (list _vector? v)
+                      (lp (vector->list p) (list _vector->list v) dim vars k)))
+               ((null? p) (list _and (list _null? v) (k vars)))
+               (else (list _and (list _equal? v p) (k vars))))))))
+       (define (ellipse-escape? x) (and (pair? x) (compare ellipse (car x))))
+       (define (ellipse? x)
+         (and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x))))
+       (define (ellipse-depth x)
+         (if (ellipse? x)
+             (+ 1 (ellipse-depth (cdr x)))
+             0))
+       (define (ellipse-tail x)
+         (if (ellipse? x)
+             (ellipse-tail (cdr x))
+             (cdr x)))
+       (define (all-vars x dim)
+         (let lp ((x x) (dim dim) (vars '()))
+           (cond ((identifier? x)
+                  (if (find (lambda (lit) (compare x lit)) lits)
+                      vars
+                      (cons (cons x dim) vars)))
+                 ((ellipse? x) (lp (car x) (+ dim 1) vars))
+                 ((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
+                 ((vector? x) (lp (vector->list x) dim vars))
+                 (else vars))))
+       (define (free-vars x vars dim)
+         (let lp ((x x) (free '()))
+           (cond
+            ((identifier? x)
+             (if (and (not (memq x free))
+                      (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
+                            (else #f)))
+                 (cons x free)
+                 free))
+            ((pair? x) (lp (car x) (lp (cdr x) free)))
+            ((vector? x) (lp (vector->list x) free))
+            (else free))))
+       (define (expand-template tmpl vars)
+         (let lp ((t tmpl) (dim 0))
+           (cond
+            ((identifier? t)
+             (cond
+              ((find (lambda (v) (compare t (car v))) vars)
+               => (lambda (cell)
+                    (if (<= (cdr cell) dim)
+                        t
+                        (error "too few ...'s"))))
+              (else
+               (list _rename (list _quote t)))))
+            ((pair? t)
+             (cond
+              ((ellipse-escape? t)
+               (if (pair? (cdr t))
+                   (if (pair? (cddr t)) (cddr t) (cadr t))
+                   (cdr t)))
+              ((ellipse? t)
+               (let* ((depth (ellipse-depth t))
+                      (ell-dim (+ dim depth))
+                      (ell-vars (free-vars (car t) vars ell-dim)))
+                 (if (null? ell-vars)
+                     (error "too many ...'s")
+                     (let* ((once (lp (car t) ell-dim))
+                            (nest (if (and (null? (cdr ell-vars))
+                                           (identifier? once)
+                                           (eq? once (car vars)))
+                                      once ;; shortcut
+                                      (cons _map
+                                            (cons (list _lambda ell-vars once)
+                                                  ell-vars))))
+                            (many (do ((d depth (- d 1))
+                                       (many nest
+                                             (list _apply _append many)))
+                                      ((= d 1) many))))
+                       (if (null? (ellipse-tail t))
+                           many ;; shortcut
+                           (list _append many (lp (ellipse-tail t) dim)))))))
+              (else (list _cons (lp (car t) dim) (lp (cdr t) dim)))))
+            ((vector? t) (list _list->vector (lp (vector->list t) dim)))
+            ((null? t) (list _quote '()))
+            (else t))))
+       (list
+        _er-macro-transformer
+        (list _lambda (list _expr _rename _compare)
+              (cons
+               _or
+               (append
+                (map
+                 (lambda (clause) (expand-pattern (car clause) (cadr clause)))
+                 forms)
+                (list (list _error "no expansion for"
+                            (list (rename 'strip-syntactic-closures) _expr)))))))))))
+
+
 ;;[EOS]