nendo 0.3.1 → 0.3.2

data/lib/init.nnd

@@ -2,7 +2,7 @@
 ;;;
 ;;; init.nnd - Nendo's init file.
 ;;;  
-;;;   Copyright (c) 2000-2010  Kiyoka Nishiyama  <kiyoka@sumibi.org>
+;;;   Copyright (c) 2009-2010  Kiyoka Nishiyama  <kiyoka@sumibi.org>
 ;;;   
 ;;;   Redistribution and use in source and binary forms, with or without
 ;;;   modification, are permitted provided that the following conditions
@@ -57,6 +57,12 @@
                                         body)))))))))
 
 
+;; debug-print macro is predefined as NOP.
+;; for self debugging of init.nnd.
+(define debug-print
+  (macro (_form sourcefile lineno sourcesexp)
+    _form))
+
 ;; ----------------------------------------
 ;; car and cdr functions
 ;; ----------------------------------------
@@ -106,6 +112,7 @@
 ;; ----------------------------------------
 ;; Utility functions
 ;; ----------------------------------------
+(define (vector . lst)  (to-arr lst))
 (define (list? arg)
   (if (pair? arg)
       (list? (cdr arg))
@@ -241,7 +248,6 @@
          (apply1 proc (append (reverse (cdr lol)) (car lol))))
        (reverse args))))
 
-
 ;; The following quasiquote macro is due to Eric S. Tiedemann. ( Imported from TinyScheme )
 ;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
 ;;
@@ -259,8 +265,11 @@
                    (if (or (procedure? f) (number? f) (string? f))
                        f
                        (list 'quote f))
-                   (list 'cons l r))))
-            
+                   (if (eqv? l vector)
+                       (apply l (eval r))
+                       (list 'cons l r)
+                       ))))
+
             (mappend
              (lambda (f l r)
                (if (or (null? (cdr f))
@@ -364,6 +373,37 @@
 ;; ----------------------------------------
 ;; List utilities imported from TinyScheme
 ;; ----------------------------------------
+;;
+;; (do ((var init inc) ...) (endtest result ...) body ...)
+;;
+(define do
+  (macro do-macro
+    (apply (lambda (vars endtest . body)
+             (let ((do-loop (gensym)))
+               `(letrec ((,do-loop
+                          (lambda ,(map (lambda (x)
+                                          (if (pair? x) (car x) x))
+                                        `,vars)
+                            (if ,(car endtest)
+                                (begin ,@(cdr endtest))
+                                (begin
+                                  ,@body
+                                  (,do-loop
+                                   ,@(map (lambda (x)
+                                            (cond
+                                             ((not (pair? x)) x)
+                                             ((< (length x) 3) (car x))
+                                             (else (car (cdr (cdr x))))))
+                                          `,vars)))))))
+                  (,do-loop
+                   ,@(map (lambda (x)
+                            (if (and (pair? x) (cdr x))
+                                (car (cdr x))
+                                '()))
+                          `,vars)))))
+           do-macro)))
+
+
 ;; generic-member 
 (define (generic-member cmp obj lst)
   (cond
@@ -408,13 +448,52 @@
 ;; ----------------------------------------
 ;; Higher-order functions
 ;; ----------------------------------------
-(define (map pred lst)
-  (if (null? lst)
-      '()
-      (cons
-       (pred (car lst))
-       (map pred (cdr lst)))))
-(define for-each map)
+;; List utilities imported from TinyScheme  by Kiyoka Nishiyama
+;;  and Fixed bugs in `map' and `for-each'.
+(define (foldr f x lst)
+     (if (null? lst)
+          x
+          (foldr f (f x (car lst)) (cdr lst))))
+
+(define (unzip1-with-cdr . lists)
+  (unzip1-with-cdr-iterative lists '() '()))
+
+(define (unzip1-with-cdr-iterative lists cars cdrs)
+  (if (null? lists)
+      (cons cars cdrs)
+      (let ((car1 (caar lists))
+	    (cdr1 (cdar lists)))
+	(unzip1-with-cdr-iterative 
+	 (cdr lists) 
+	 (append cars (list car1))
+	 (append cdrs (list cdr1))))))
+
+
+(define (map proc . lists)
+  (if (null? lists)
+      (apply proc)
+      (if (null? (car lists))
+	  '()
+	  (let1 unz (apply unzip1-with-cdr lists)
+            (let ((cars (car unz))
+                  (cdrs (cdr unz)))
+              (cons (apply proc cars)
+                    (if (null? cdrs)
+                        '()
+                        (apply map (cons proc cdrs)))))))))
+
+(define (for-each proc . lists)
+  (if (null? lists)
+      (apply proc)
+      (if (null? (car lists))
+	  #t
+	  (let1 unz (apply unzip1-with-cdr lists)
+            (let ((cars (car unz))
+                  (cdrs (cdr unz)))
+              (apply proc cars)
+              (if (null? cdrs)
+                  '()
+                  (apply map (cons proc cdrs))))))))
 
 (define (filter pred lst)
   (if (null? lst)
@@ -454,14 +533,18 @@
               (let ((defs
                       (filter
                        (lambda (x)
-                         (and (eq? 'define (car x))
-                              (symbol? (cadr x))))
+                         (if (pair? x)
+                             (and (eq? 'define (car x))
+                                  (symbol? (cadr x)))
+                             #f))
                        body))
                     (rest
                      (filter
                       (lambda (x)
-                        (not (and (eq? 'define (car x))
-                                  (symbol? (cadr x)))))
+                        (if (pair? x)
+                            (not (and (eq? 'define (car x))
+                                      (symbol? (cadr x))))
+                            #f))
                       body)))
                 (if (< 0 (length defs))
                     `(lambda
@@ -533,6 +616,17 @@
       (let*-expand exps body))))
 
 
+(define begin0
+  (macro body
+    (if (null? body)
+        '(begin
+           #f)
+        (let1 result (gensym)
+          `(receive ,result ,(car body)
+             ,@(cdr body)
+             (apply values ,result))))))
+
+
 ;; ----------------------------------------
 ;; values
 ;; ----------------------------------------
@@ -703,6 +797,7 @@
       (error "Error: alist->hash-table expects alist.")
       (apply hash-table alist)))
 
+
 ;; ----------------------------------------
 ;; Ruby interop librarys
 ;; ----------------------------------------
@@ -723,6 +818,60 @@
       (errorf "Error: can't load library file [%s]\n" path )))))
 
 
+
+;; ----------------------------------------
+;; Vector Library
+;; ----------------------------------------
+(define (vector? v)
+  (v.is_a? Array))
+
+(define (make-vector k . rest)
+  (if (null? rest)
+      (Array.new k)
+      (Array.new k (car rest))))
+
+(define (vector-length v)
+  (v.size))
+
+(define (vector-copy v)
+  (v.clone))
+
+(define (vector-ref v index . fallback)
+  (if (and (<= 0 index) (< index v.size))
+      (v.fetch index)
+      (if (null? fallback)
+          (errorf "Error: vector-ref  index value is overflow: %s\n" index)
+          (car fallback))))
+
+;;
+;; ported from tinyscheme-1.39 by Kiyoka Nishiyama
+;;
+(define (vector-equal? x y)
+     (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
+          (let ((n (vector-length x)))
+               (let loop ((i 0))
+                    (if (= i n)
+                         #t
+                         (and (equal? (vector-ref x i) (vector-ref y i))
+                              (loop (succ i))))))))
+
+(define (list->vector x)
+     (apply vector x))
+
+(define (vector-fill! v e)
+     (let ((n (vector-length v)))
+          (let loop ((i 0))
+               (if (= i n)
+                    v
+                    (begin (vector-set! v i e) (loop (succ i)))))))
+
+(define (vector->list v)
+     (let loop ((n (pred (vector-length v))) (l '()))
+          (if (= n -1)
+               l
+               (loop (pred n) (cons (vector-ref v n) l)))))
+
+
 ;; ----------------------------------------
 ;; Utility function for testing and debugging
 ;; ----------------------------------------
@@ -782,9 +931,92 @@
   (newline))
 
 
+
+;; ----------------------------------------
+;; global variables bind checker
+;; ----------------------------------------
+(define (global-defined? sym)
+  (find
+   (lambda (x)
+     (eq? sym x))
+   (global-variables)))
+
+
+;; ----------------------------------------
+;; Nendo compiler utility
+;; ----------------------------------------
+(define (compiled-code-string compiled-code filename)
+  (define (compiled-body-string string-list filename)
+    (+
+     (string-join
+      string-list
+      "\n#--------------------\n")
+     (string-join
+      `("\n\n"
+        "# -------------------------------------------------------"
+        "# [EOF]"
+        "# -------------------------------------------------------")
+      "\n")))
+    
+  (let ((str-list (assv-ref filename compiled-code))
+        (script-flag  (and (global-defined? 'main)
+                           (procedure? main))))
+    (values
+     script-flag
+     (compiled-body-string str-list filename))))
+
+
+(define (print-compiled-code src . rest)
+  (define (print-to-file f)
+    (receive (script-flag str)
+        (compiled-code-string (get-compiled-code) src)
+      (cond (script-flag
+             (f.puts (string-join
+                      `(
+                        "#!/usr/local/bin/ruby"
+                        "# -*- encoding: utf-8 -*-"
+                        "#"
+                        "#    This file is nendo's compiled script file. "
+                        "#    generated  \"nendo -c src\" command. "
+                        "#"
+                        ""
+                        "require 'rubygems'"
+                        "require 'nendo'"
+                        ""
+                        "core = Nendo.new()"
+                        "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) \" )"
+                        "")
+                      "\n")))
+            (else
+             (f.puts (+ (string-join
+                         '(
+                           "#"
+                           "#    This file is nendo's compiled library file. "
+                           "#    generated  \"nendo -c src\" command. "
+                           "# ")
+                         "\n")
+                        "\n"
+                        str))))))
+
+  (when (not (File.exist? src))
+    (errorf "Error: file [%s] not found." src)
+    (exit 1))
+  (clean-compiled-code)
+  (load src)
+  (if (null? rest)
+      (print-to-file STDOUT)
+      (with-open (car rest)
+                 (lambda (f)
+                   (print-to-file f))
+                 "w")))
+
+
 ;; ----------------------------------------
 ;; global variables
 ;; ----------------------------------------
 (define *nendo-version*
-  "0.3.1"  ;;NENDO-VERSION
+  "0.3.2"  ;;NENDO-VERSION
   )