nendo 0.3.3 → 0.3.4

data/lib/init.nnd

@@ -37,25 +37,39 @@
 ;; ----------------------------------------
 ;; define
 ;; ----------------------------------------
-(define define
-      (macro (arg . body)
-        (if (not (pair? arg))
-            ;; (define var body)
-            (cons 'define
-                  (cons 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)))))))))
+(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
+          (cons (car arg)
+                (list
+                 (cons 'lambda
+                       (cons  (cdr arg)
+                              body-list)))))))
 
+(define define
+  (macro (arg . body)
+    (if (not (pair? arg))
+        ;; (define var body)
+        (cons 'define
+              (cons arg
+                    body))
+        (%expand-define-form-lambda arg body))))
+
+(define %expand-define-form
+  (lambda (arg-and-body)
+    (let ((arg  (car arg-and-body))
+          (body (cdr arg-and-body)))
+      ;; (define (func arg...) body)
+      (if (not (pair? arg))
+          ;; (define var body)
+          (cons 'define
+                (cons arg
+                      body))
+          (%expand-define-form-lambda arg body)))))
 
 ;; debug-print macro is predefined as NOP.
 ;; for self debugging of init.nnd.
@@ -113,10 +127,7 @@
 ;; Utility functions
 ;; ----------------------------------------
 (define (vector . lst)  (to-arr lst))
-(define (list? arg)
-  (if (pair? arg)
-      (list? (cdr arg))
-      (null? arg)))
+(define list? %list?)
 (define (even? n) (= (% n 2) 0))
 (define (odd? n) (not (= (% n 2) 0)))
 (define (zero? n) (= n 0))
@@ -362,6 +373,12 @@
         ;; don't touch
         `(let ,@lst))))
 
+(define if-let1
+  (macro (var _expr _then . _else)
+    `(let1 ,var ,_expr
+       (if ,var ,_then ,@_else))))
+
+
 ;; ----------------------------------------
 ;; errorf
 ;; ----------------------------------------
@@ -370,6 +387,24 @@
     `(error
       (sprintf ,format ,@args))))
 
+
+;; ----------------------------------------
+;; optional argument parser
+;; ----------------------------------------
+(define get-optional
+  (macro (restarg default)
+    (let1 _restarg (gensym)
+      `(let1 ,_restarg ,restarg
+         (if (null? ,_restarg)
+             ,default
+             (car ,_restarg))))))
+
+;; pending
+(define check-arg
+  (macro (a b . c)
+    `(begin)))
+
+
 ;; ----------------------------------------
 ;; List utilities imported from TinyScheme
 ;; ----------------------------------------
@@ -469,9 +504,9 @@
 	 (append cdrs (list cdr1))))))
 
 
-(define (map proc . lists)
+(define (%map proc . lists)
   (letrec ((result '())
-           (map-arg1
+           (%map-arg1
             (lambda (proc lst)
               (if (null? lst)
                   #t
@@ -479,12 +514,12 @@
                     (set! result
                           (cons (proc (car lst))
                                 result))
-                    (map-arg1 proc (cdr lst)))))))
+                    (%map-arg1 proc (cdr lst)))))))
     (cond
      ((null? lists)
       (apply proc))
      ((eq? 1 (length lists))
-      (map-arg1 proc (car lists)) ;; tail call optimization version
+      (%map-arg1 proc (car lists)) ;; tail call optimization version
       (reverse result))
      (else
       (if (null? (car lists))
@@ -495,21 +530,61 @@
               (cons (apply proc cars)
                     (if (null? cdrs)
                         '()
-                        (apply map (cons proc cdrs)))))))))))
+                        (apply %map (cons proc cdrs)))))))))))
+
+(define (%internal-define-to-letrec _sym _src)
+  (if (not (list? (cadr _src)))
+      `(,_sym ,@_src)
+      (let ((body (cdr _src))
+            (defs '())
+            (rest '()))
+        (if (not (list? (car body)))
+            `(,_sym ,@_src)
+            (begin
+              (%map
+               (lambda (x)
+                 (if (and (pair? x)
+                          (eq? 'define (car x)))
+                     (set! defs (cons (%expand-define-form (cdr x)) defs))
+                     (set! rest (cons x rest))))
+               body)
+              (let ((defs (reverse defs))
+                    (rest (reverse rest)))
+                (if (< 0 (length defs))
+                    `(,_sym
+                      ,(car _src)
+                      (letrec
+                          ,(%map
+                            (lambda (x)
+                              (list
+                               (cadr x)
+                               (caddr x)))
+                            defs)
+                        ,@rest))
+                    ;; found no `internal-define' syntax
+                    `(,_sym ,@_src))))))))
+
 
+(define lambda
+  (macro src
+    (%internal-define-to-letrec 'lambda src)))
 
-(define (for-each proc . lists)
-  (define (for-each-arg1 proc lst)
+(define macro
+  (macro src
+    (%internal-define-to-letrec 'macro src)))
+
+(define (%for-each proc . lists)
+  (define (%for-each-arg1 proc lst)
     (if (null? lst)
         #t
         (begin
           (proc (car lst))
-          (for-each-arg1 proc (cdr lst)))))
+          (%for-each-arg1 proc (cdr lst)))))
   (cond
    ((null? lists)
     (apply proc))
    ((eq? 1 (length lists))
-    (for-each-arg1 proc (car lists))) ;; tail call optimization version
+    (%for-each-arg1 proc (car lists))) ;; tail call optimization version
    (else
     (if (null? (car lists))
         #t
@@ -519,73 +594,47 @@
             (apply proc cars)
             (if (null? cdrs)
                 '()
-                (apply for-each (cons proc cdrs)))))))))
-
-
-(define (filter pred lst)
-  (if (null? lst)
-      '()
-      (if (pred (car lst))
-          (cons
-           (car lst)
-           (filter pred (cdr lst)))
-          (filter pred (cdr lst)))))
+                (apply %for-each (cons proc cdrs)))))))))
 
+(define (%filter pred lst)
+  (define result '())
+  (define (%filter-arg1 proc lst)
+    (if (null? lst)
+        '()
+        (let1 v (proc (car lst))
+          (when v
+            (set! result (cons (car lst) result)))
+          (%filter-arg1 proc (cdr lst)))))
+
+  (%filter-arg1 pred lst) ;; tail call optimization version
+  (reverse result))
+
+(define (%filter-map pred lst)
+  (define result '())
+  (define (%filter-map-arg1 proc lst)
+    (if (null? lst)
+        '()
+        (let1 v (proc (car lst))
+          (when v
+            (set! result (cons v result)))
+          (%filter-map-arg1 proc (cdr lst)))))
 
-(define (filter-map pred lst)
-  (if (null? lst)
-      '()
-      (let1 result (pred (car lst))
-        (if result
-            (cons
-             result
-             (filter-map pred (cdr lst)))
-            (filter-map pred (cdr lst))))))
+  (%filter-map-arg1 pred lst) ;; tail call optimization version
+  (reverse result))
 
 
 (define (find pred lst)
-  (let1 result (filter pred lst)
+  (let1 result (%filter pred lst)
     (if (null? result)
         #f
         (car result))))
 
+(define map         %map)
+(define for-each    %for-each)
+(define filter      %filter)
+(define filter-map  %filter-map)
+
 
-(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)
-                         (if (pair? x)
-                             (and (eq? 'define (car x))
-                                  (symbol? (cadr x)))
-                             #f))
-                       body))
-                    (rest
-                     (filter
-                      (lambda (x)
-                        (if (pair? x)
-                            (not (and (eq? 'define (car x))
-                                      (symbol? (cadr x))))
-                            #f))
-                      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))))))))
 
 
 ;; ----------------------------------------
@@ -593,54 +642,50 @@
 ;; ----------------------------------------
 (define case
   (macro (cond-exp . 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)))))))
-    
-             (case-iter
-              (lambda (val lst)
-                (cond
-                 ((eq? 0 (length lst))
-                  '())
-                 ((eq? 1 (length lst))
-                  (case-block val (car lst)))
+    (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))))))
+  
+    (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))))))))
+                          (case-iter  val (cdr lst))))))
 
-      (let1 sym (gensym)
-        `(let1 ,sym ,cond-exp
-           (cond
-            ,@(case-iter sym body)))))))
+    (let1 sym (gensym)
+      `(let1 ,sym ,cond-exp
+         (cond
+          ,@(case-iter sym body))))))
 
 
 (define let*
   (macro (exps . 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))))
+    (define (let*-expand rest body)
+      (case (length rest)
+        ((0)
+         '())
+        ((1)
+         `(let (,(car rest))
+            ,@body))
+        (else
+         `(let (,(car rest))
+            ,(let*-expand (cdr rest) body)))))
+    (let*-expand exps body)))
 
 
 (define begin0
@@ -711,36 +756,30 @@
 ;; ----------------------------------------
 (define dot-operator
   (macro lst
-    (letrec ((generate-method-call-form
-              (lambda (lst)
-                (let1 tmp (gensym)
-                  (if (symbol? (first lst))
-                      `(,(string->symbol (+ (to-s (first lst)) "." (to-s (second lst))))
-                        ,@(cddr lst))
-                      `(let ((,tmp ,(first lst)))
-                         (,(string->symbol (+ (to-s tmp) "." (to-s (second lst))))
-                          ,@(cddr lst))))))))
-      (cond
-       ((> 2 (length lst))
-        (raise ArgumentError ". dot-operator requires 2+ arguments." (sprintf "%s:%s in dot-operator" (*FILE*) (*LINE*))))
-       (else
-        (if (symbol? (second lst))
-            (generate-method-call-form lst)
-            (raise TypeError ". dot-operator requires method name as symbol." (sprintf "%s:%s in dot-operator" (*FILE*) (*LINE*)))))))))
+    (define (generate-method-call-form lst)
+      (let1 tmp (gensym)
+        (if (symbol? (first lst))
+            `(,(string->symbol (+ (to-s (first lst)) "." (to-s (second lst))))
+              ,@(cddr lst))
+            `(let ((,tmp ,(first lst)))
+               (,(string->symbol (+ (to-s tmp) "." (to-s (second lst))))
+                ,@(cddr lst))))))
+    (cond
+     ((> 2 (length lst))
+      (raise ArgumentError ". dot-operator requires 2+ arguments." (sprintf "%s:%s in dot-operator" (*FILE*) (*LINE*))))
+     (else
+      (if (symbol? (second lst))
+          (generate-method-call-form lst)
+          (raise TypeError ". dot-operator requires method name as symbol." (sprintf "%s:%s in dot-operator" (*FILE*) (*LINE*))))))))
 
 
 (define (with-open filename pred . lst)
-  (let1 len (length lst)
-    (let1 f (cond
-             ((= 0 len)
-              (.open filename))
-             ((< 0 len)
-              (.open filename (car lst)))
-             (else
-              (error "with-open requires 2 or 3 arguments.")))
-      (let1 result (pred f)
-        (f.close)
-        result))))
+  (let1 opt (get-optional lst #f)
+    (if (< 1 (length lst))
+        (error "with-open requires 2 or 3 arguments.")
+        (if opt
+            (.open filename opt (&block (f) (pred f)))
+            (.open filename     (&block (f) (pred f)))))))
 
 
 ;; ----------------------------------------
@@ -775,15 +814,10 @@
   (let1 h (make-hash-table)
     (for-each
      (lambda (entry)
-       (if (pair? (cdr entry))
-           (hash-table-put! h (car entry) (cadr entry))
-           (hash-table-put! h (car entry) (cdr  entry))))
+       (hash-table-put! h (car entry) (cdr  entry)))
      kv-list)
     h))
 
-(define (hash-table-exist? h key)
-  (h.has_key? key))
-
 (define (hash-table-clear! h)
   (h.clear))
 
@@ -820,7 +854,7 @@
          keys))))
 
 (define (alist->hash-table alist)
-  (if (not (list? alist))
+  (if (not (%list? alist))
       (error "Error: alist->hash-table expects alist.")
       (apply hash-table alist)))
 
@@ -828,10 +862,10 @@
 ;; ----------------------------------------
 ;; Ruby interop librarys
 ;; ----------------------------------------
-;; I will implement in the future...
-(define export
-  (macro (name)
-    `(define ,name nil)))
+;; export Nendo's function to the Ruby world
+(define export-to-ruby
+  (macro (funcname)
+    `(%export-to-ruby ,funcname.to_s ,funcname)))
 
 (define (load-library name)
   (let* ((home (get-nendo-home))
@@ -844,6 +878,20 @@
      (else
       (errorf "Error: can't load library file [%s]\n" path )))))
 
+;; use macro like Gauche
+(define use
+  (macro (sym)
+    (if (symbol? sym)
+        (let*
+            ((str      (symbol->string sym))
+             (pathname (str.gsub "." "/")))
+          `(load-library ,pathname))
+        (errorf "Error: use macro requires a symbol argument."))))
+
+;; exporting a symbol in the module. (I will implement in the future...)
+(define export
+  (macro (name)
+    `(define ,name nil)))
 
 
 ;; ----------------------------------------
@@ -929,50 +977,111 @@
 ;;    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)
+(define (pretty-print s . f)
+  (define (do-indent f level)
+    (for-each (lambda (x) (f.print " ")) (range level)))
+  (define (pp-parenl f)
+    (f.print "("))
+  (define (pp-parenr f)
+    (f.print ")"))
+  (define (pp-atom f e prefix)
+    (when prefix (f.print " "))
+    (f.print (write-to-string e)))
+  (define (pp-list f s level prefix)
+    (and prefix (do-indent f level))
+    (pp-parenl f)
     (let loop ((s s)
                (prefix #f))
       (if (null? s)
-          (pp-parenr)
+          (pp-parenr f)
           (let1 e (car s)
             (if (list? e)
-                (begin (and prefix (newline))
-                       (pp-list e (+ level 1) prefix))
-                (pp-atom e prefix))
+                (begin (and prefix (f.print "\n"))
+                       (pp-list f e (+ level 1) prefix))
+                (pp-atom f e prefix))
             (loop (cdr s) #t)))))
-  (if (list? s)
-      (pp-list s 0 #f)
-      (write s))
-  (newline))
+  (let1 f (get-optional f STDOUT)
+    (if (list? s)
+        (pp-list f s 0 #f)
+        (f.print (write-to-string s)))
+    (f.print "\n")))
+
 
+(define (pretty-print-to-string s)
+  (let1 io (StringIO.new)
+    (pretty-print s io)
+    (io.rewind)
+    (io.read)))
 
 ;; ----------------------------------------
-;; optional argument parser
+;; sort library functions
 ;; ----------------------------------------
-(define get-optional
-  (macro (restarg default)
-    (let1 _restarg (gensym)
-      `(let1 ,_restarg ,restarg
-         (if (null? ,_restarg)
-             ,default
-             (car ,_restarg))))))
+(define (sort lst . cmpfn)
+  (if (null? lst)
+      '()
+      (let1 cmpfn (get-optional cmpfn #f)
+        (to-list
+         (if cmpfn
+             (lst.to_arr.sort (&block (a b) (cmpfn a b)))
+             (lst.to_arr.sort))))))
+
+
+(define (sort-by lst keyfn)
+  (if (null? lst)
+      '()
+      (to-list
+       (lst.to_arr.sort_by (&block (item) (keyfn item))))))
+
+
+;; ----------------------------------------
+;; string library
+;; ----------------------------------------
+(define (string-length str) (str.size))
+
+
+;; ----------------------------------------
+;; regexp library functions
+;; ----------------------------------------
+(define (string->regexp str . casefold)
+  (if (not (str.is_a? String))
+      (error "Error: string->regexp requires a String argument.")
+      (if (get-optional casefold #f)
+          (Regexp.new str Regexp::IGNORECASE)
+          (Regexp.new str))))
+
+(define (regexp? obj)
+  (obj.is_a? Regexp))
+
+(define (regexp->string regexp)
+  (regexp.source))
+
+;; return:  Ruby's MatchData instance
+(define (rxmatch regexp str)
+  (let1 m (regexp.match str)
+    (if m m #f)))
+
+(define (rxmatch-start match . index)
+  (let1 index (get-optional index 0)
+    (match.begin index)))
+
+(define (rxmatch-end match . index)
+  (let1 index (get-optional index 0)
+    (match.end index)))
+
+(define (rxmatch-substring match . index)
+  (let1 index (get-optional index 0)
+    (nth index (match.to_a.to_list))))
+
+(define (rxmatch-num-matches match)
+  (match.size))
+
+(define (rxmatch->string regexp str . index)
+  (let1 index (get-optional index 0)
+    (let1 m (rxmatch regexp str)
+      (if m
+          (rxmatch-substring m index)
+          #f))))
 
-;; pending
-(define check-arg
-  (macro (a b . c)
-    `(begin)))
 
 ;; ----------------------------------------
 ;; global variables bind checker
@@ -987,6 +1096,29 @@
 ;; ----------------------------------------
 ;; Nendo compiler utility
 ;; ----------------------------------------
+(define (disasm varname . opt)
+  (let ((kind  (get-optional opt 'compiled))
+        (alist (get-source-info (varname.to_s))))
+    (cond
+     ((eqv? kind 'compiled)
+      (assv-ref "compiled_str" alist))
+     ((eqv? kind 'source)
+      (assv-ref "source" alist))
+     ((eqv? kind 'expanded)
+      (assv-ref "expanded" alist))
+     ((eqv? kind 'info)
+      (string-join
+       (list
+        (sprintf " file:   %s \n" (assv-ref "sourcefile" alist))
+        (sprintf " lineno: %s \n" (assv-ref "lineno"     alist))
+        (sprintf " source: \n" )
+        (pretty-print-to-string
+         (assv-ref "source" alist))
+        (sprintf " expanded: \n" )
+        (pretty-print-to-string
+         (assv-ref "expanded" alist))))))))
+
+
 (define (compiled-code-string compiled-code filename)
   (define (compiled-body-string string-list filename)
     (+
@@ -1029,7 +1161,7 @@
                         "core.loadInitFile()"
                         "core.setArgv( ARGV )"
                         "core.load_compiled_code_from_string( " ,(write-to-string str) " ) "
-                        "core.replStr( \"(if (and (global-defined? 'main) (procedure? main)) (main *argv*) #f) \" )"
+                        "core.evalStr( \"(if (and (global-defined? 'main) (procedure? main)) (main *argv*) #f) \" )"
                         "")
                       "\n")))
             (else
@@ -1193,5 +1325,5 @@
 ;; global variables
 ;; ----------------------------------------
 (define *nendo-version*
-  "0.3.3"  ;;NENDO-VERSION
+  "0.3.4"  ;;NENDO-VERSION
   )