nendo 0.3.2 → 0.3.3

data/bin/nendo

@@ -50,6 +50,8 @@ def userOptionEater
       i += 1
     when '-l'
       i += 2
+    when '-O'
+      i += 2
     when /^[^-]/
       break
     else
@@ -63,32 +65,19 @@ def userOptionEater
   return userOptions
 end
 
-def cache_exist?( fn )
-  dotdir_path = File.expand_path( "~/.nendo" )
-  cache_path  = File.expand_path( "~/.nendo/cache" )
-  Dir.mkdir( dotdir_path ) unless File.exist?( dotdir_path )
-  Dir.mkdir( cache_path  ) unless File.exist?( cache_path  )
-  sha1 = Digest::SHA1.hexdigest( File.expand_path( fn ))
-  cache_name = cache_path + "/" + sha1 + "_" + File.basename( fn ) + ".rb"
-  if File.exist?( cache_name )
-    [  true, cache_name ]
-  else
-    [ false, cache_name ]
-  end
-end
-
 def main
   loadInit  = true
   compile   = false
   conflict = 0
-  core = Nendo.new()
+  core = Nendo::Core.new()
 
   userOptions = userOptionEater
   opts = GetoptLong.new(
                         [ '-h', GetoptLong::NO_ARGUMENT ],
                         [ '-q', GetoptLong::NO_ARGUMENT ],
                         [ '-c', GetoptLong::NO_ARGUMENT ],
-                        [ '-l', GetoptLong::REQUIRED_ARGUMENT ]
+                        [ '-l', GetoptLong::REQUIRED_ARGUMENT ],
+                        [ '-O', GetoptLong::REQUIRED_ARGUMENT ]
                         ).each { |opt, arg|
     case opt
     when '-h'
@@ -108,6 +97,9 @@ def main
       -c:
         compile nendo script file. (and initialization file was loaded)
 
+      -O:
+        set optimize level. (0:no optimize,   1:tail call optimize)
+
       EOF
       exit 0
     when '-q'
@@ -120,6 +112,8 @@ def main
     when '-l'
       core.load( arg )
       STDERR.printf( "loaded file [%s]\n", arg )
+    when '-O'
+      core.setOptimizeLevel( arg.to_i )
     end
   }
 

data/example/deep-loop1.nnd

@@ -0,0 +1,15 @@
+#!/bin/sh
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
+
+(define count 0)
+
+(define (loop1)
+  (when (eq? 0 (% count 1000))
+    (printf "count = %6d\n" count))
+  (set! count (+ count 1))
+  (loop1))
+   
+(define (main args)
+  (loop1))
+

data/example/deep-loop2.nnd

@@ -0,0 +1,14 @@
+#!/bin/sh
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
+
+   
+(define (main args)
+  (letrec ((loop1
+            (lambda (count)
+              (when (eq? 0 (% count 1000))
+                (printf "count = %6d\n" count))
+              (loop1 (+ count 1)))))
+    (loop1 0)))
+
+     

data/example/scratch.nnd

@@ -4,3 +4,21 @@
 (disable-idebug)
 (define debug-print-length 256)
 
+;; Bug : got in `translate': undefined method `sourcefile' for #<Nendo::Cell:0x00000101580668> (NoMethodError)
+(let-values (((a b) (car+cdr '(1 . 2))))
+  (or (and (= a 1) (= b 2))
+      (fail 'car+cdr:1)))
+
+(define (foo lis)
+  (second lis))
+  
+(foo '(1 2 3))
+(foo 1)
+
+'(1 2 3)
+(exit)
+
+;; circular
+(load-library "srfi-1")
+(list?
+ (circular-list 1 2))

data/example/tak.nnd

@@ -1,13 +1,14 @@
-;;-*- mode: scheme; syntax: scheme -*-;;
+#!/bin/sh
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
 
-;; takeuchi function
+;; takeuchi function ( tarai mawashi bench )
 (define (tak x y z)
-  (if (> x y)
+  (if (>= y x)
+      y
       (tak (tak (- x 1) y z)
            (tak (- y 1) z x)
-           (tak (- z 1) x y))
-      y))
-
-(print (tak 8 4 0))
-
+           (tak (- z 1) x y))))
 
+(define (main argv)
+  (print (tak 10 5 0)))

data/example/twitterTL.nnd

@@ -0,0 +1,38 @@
+#!/bin/sh
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
+
+(require "rubygems")
+(require "twitter")
+
+(define (display-tl tl)
+  (for-each
+   (lambda (x)
+     (printf "%15s : %s \n"
+             (hash-table-get (assq-ref "user" x) "screen_name")
+             (assq-ref "text" x)))
+   tl))
+
+(define (main argv)
+  (let* ((httpauth (Twitter::HTTPAuth.new (first argv) (second argv)))
+         (client   (Twitter::Base.new httpauth))
+         (lst (client.friends_timeline.to_a.to_list)))
+    (let1 tl (map
+              (lambda (h)
+                (hash-table->alist h))
+              lst)
+      (display-tl tl))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+

data/lib/debug/syslog.nndc

@@ -3,58 +3,65 @@
 #    generated  "nendo -c src" command. 
 # 
 
-  callProcedure( 'require',
+trampCall( 
+  delayCall( 'require',
       begin
         if @global_lisp_binding.has_key?('_require') then
-          @_require
+          trampCall(@_require)
         else raise NameError.new( "Error: undefined variable _require", "_require" ) end
         rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:37"] + __e.backtrace ) ; raise __e
       end    ,
       Cell.new(
       "syslog"
                ))
+ )
 #--------------------
 
+trampCall( 
   begin
-    @global_lisp_binding['_debug_MIMARKprint_MIMARKoutput_MIMARKfunc'] = true
+      def self._debug_MIMARKprint_MIMARKoutput_MIMARKfunc_METHOD( origname, pred, args ) callProcedure( origname, pred, args ) end
+      @global_lisp_binding['_debug_MIMARKprint_MIMARKoutput_MIMARKfunc'] = self.method( :_debug_MIMARKprint_MIMARKoutput_MIMARKfunc_METHOD )
     @_debug_MIMARKprint_MIMARKoutput_MIMARKfunc = 
-        Proc.new { |_str| 
-            begin
-                Syslog.open(
-                  )
-              rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:40"] + __e.backtrace ) ; raise __e
-            end
-            begin
-                Syslog.log(
-                      begin
-                          Syslog::LOG_WARNING
-                        rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
-                      end                    ,
-                    "%s"                    ,
-                      callProcedure( '+',
-                          begin
-                            if @global_lisp_binding.has_key?('__PLMARK') then
-                              @__PLMARK
-                            else raise NameError.new( "Error: undefined variable __PLMARK", "__PLMARK" ) end
-                            rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
-                          end                        ,
-                          Cell.new(
-                          "Nendo: "                          ,Cell.new(
+    trampCall(
+          Proc.new { |_str| 
+              begin
+                  trampCall(Syslog).open(
+                    )
+                rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:40"] + __e.backtrace ) ; raise __e
+              end
+              begin
+                  trampCall(Syslog).log(
+                        begin
+                            trampCall(Syslog::LOG_WARNING)
+                          rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
+                        end                      ,
+                      "%s"                      ,
+                        trampCall( self.__PLMARK_METHOD(  '+',
                             begin
-                                _str
+                              if @global_lisp_binding.has_key?('__PLMARK') then
+                                trampCall(@__PLMARK)
+                              else raise NameError.new( "Error: undefined variable __PLMARK", "__PLMARK" ) end
                               rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
-                            end
-                                   )))
-                  )
-              rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
-            end
-            begin
-                Syslog.close(
-                  )
-              rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:42"] + __e.backtrace ) ; raise __e
-            end
-        }
+                            end                          ,
+                            Cell.new(
+                            "Nendo: "                            ,Cell.new(
+                              begin
+                                  trampCall(_str)
+                                rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
+                              end
+                                     ))))
+                    )
+                rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
+              end
+              begin
+                  trampCall(Syslog).close(
+                    )
+                rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:42"] + __e.backtrace ) ; raise __e
+              end
+          }
+    )
   end
+ )
 
 
 # -------------------------------------------------------

data/lib/init.nnd

@@ -124,16 +124,16 @@
 (define (negative? n) (< n 0))
 (define (abs n) (if (>= n 0) n (- n)))
 (define (max . lst)
-     (foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst)))
+     (fold-right (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst)))
 (define (min . lst)
-     (foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst)))
+     (fold-right (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst)))
 (define (succ x) (+ x 1))
 (define (pred x) (- x 1))
 (define (nth n 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)
@@ -352,7 +352,7 @@
                              (lambda (x)
                                (first x))
                              (second lst))
-                     ,(third lst))))
+                     ,@(cddr lst))))
            (,(first lst)
             ,@(map
                (lambda (x)
@@ -450,10 +450,10 @@
 ;; ----------------------------------------
 ;; List utilities imported from TinyScheme  by Kiyoka Nishiyama
 ;;  and Fixed bugs in `map' and `for-each'.
-(define (foldr f x lst)
+(define (fold-right f x lst)
      (if (null? lst)
           x
-          (foldr f (f x (car lst)) (cdr lst))))
+          (fold-right f (f x (car lst)) (cdr lst))))
 
 (define (unzip1-with-cdr . lists)
   (unzip1-with-cdr-iterative lists '() '()))
@@ -470,30 +470,57 @@
 
 
 (define (map proc . lists)
-  (if (null? lists)
-      (apply proc)
+  (letrec ((result '())
+           (map-arg1
+            (lambda (proc lst)
+              (if (null? lst)
+                  #t
+                  (begin
+                    (set! result
+                          (cons (proc (car lst))
+                                result))
+                    (map-arg1 proc (cdr lst)))))))
+    (cond
+     ((null? lists)
+      (apply proc))
+     ((eq? 1 (length lists))
+      (map-arg1 proc (car lists)) ;; tail call optimization version
+      (reverse result))
+     (else
       (if (null? (car lists))
-	  '()
-	  (let1 unz (apply unzip1-with-cdr 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)))))))))
+                        (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 (for-each-arg1 proc lst)
+    (if (null? lst)
+        #t
+        (begin
+          (proc (car 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
+   (else
+    (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 for-each (cons proc cdrs)))))))))
+
 
 (define (filter pred lst)
   (if (null? lst)
@@ -931,6 +958,21 @@
   (newline))
 
 
+;; ----------------------------------------
+;; 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)))
 
 ;; ----------------------------------------
 ;; global variables bind checker
@@ -983,7 +1025,7 @@
                         "require 'rubygems'"
                         "require 'nendo'"
                         ""
-                        "core = Nendo.new()"
+                        "core = Nendo::Core.new()"
                         "core.loadInitFile()"
                         "core.setArgv( ARGV )"
                         "core.load_compiled_code_from_string( " ,(write-to-string str) " ) "
@@ -1014,9 +1056,142 @@
                  "w")))
 
 
+;; ----------------------------------------
+;; compile phase ( it can be written in Nendo! )
+;; ----------------------------------------
+;;
+;; example:
+;;   %compile-phase-functions is ( func1 func2 func3 )
+;; then this function evals.
+;;   (func3 (func2 (func1 sexp)))
+;;
+(define (%compile-phase sexp)
+  (cond
+   ((list? sexp)
+    (for-each
+     (lambda (func)
+       (set! sexp (func sexp)))
+     %compile-phase-functions)
+    sexp)
+   (else
+    sexp)))
+
+
+;; ----------------------------------------
+;; tail-call-optimization
+;; ----------------------------------------
+(define (setup-tailcall-mark sexp)
+  (define (reserved? sym)
+    (memq sym '(quote macro begin lambda if let letrec define)))
+  
+  (define (setup-let-args args)
+    (map
+     (lambda (arg)
+       (let ((name (first  arg))
+             (body (second arg)))
+         (list name
+               (if (list? body)
+                   (if (reserved? (car body))
+                       (setup-tailcall-mark body)
+                       body)
+                   body))))
+     args))
+
+  (define (setup-proc sexp)
+    (cond
+     ((null? sexp)
+      sexp)
+     ((and (list? sexp)
+           (< 0 (length sexp)))
+      (if (reserved? (car sexp))
+          (setup-tailcall-mark sexp)
+          (if (pair? (car sexp))
+              sexp ;; e.g.  ((lambda (x) ...)
+              `(%tailcall ,sexp))))
+     (else
+      sexp)))
+
+  (define (setup-proc-body sexp)
+    (if (or (not (list? sexp))
+            (null? sexp))
+        sexp
+        (let* ((r (reverse sexp))
+               (last  (car r))
+               (other (cdr r)))
+          (if (not (pair? last))
+              sexp
+              (reverse
+               (cons
+                (if (reserved? (car last))
+                    ;; recursive
+                    (setup-tailcall-mark last)
+                    ;; this is the tailcall!
+                    `(%tailcall ,last))
+                other))))))
+
+  (cond
+   ((not (pair? sexp))
+    sexp)
+   ((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))))
+   (else
+    sexp)))
+
+
+;; definition of 'compile-phase'
+(set! %compile-phase-functions
+      (list
+       setup-tailcall-mark
+       ))
+
 ;; ----------------------------------------
 ;; global variables
 ;; ----------------------------------------
 (define *nendo-version*
-  "0.3.2"  ;;NENDO-VERSION
+  "0.3.3"  ;;NENDO-VERSION
   )