kiyoka-nendo 0.1.0

data/README

@@ -0,0 +1,10 @@
+
+
+            Nendo is a dialect of Lisp written in Ruby.
+            http://oldtype.sumibi.org/show-page/Nendo
+
+
+This software is open source, covered by a BSD-style license.
+Please read accompanying file COPYING.
+
+

data/bin/nendo

@@ -0,0 +1,26 @@
+#!/usr/local/bin/ruby -W0
+#
+# Nendo:   "Principle of Least Surprise (for Rubyist)"
+#
+#
+# How to shebang:
+#   start script file as
+#               #!/bin/sh
+#               true; #-*- mode: nendo; syntax: scheme -*-;;
+#               true; exec /usr/local/bin/nendo "$0"
+#                   .
+#                   .
+#
+require 'nendo'
+
+def main
+  core = Nendo.new()
+  core.loadInitFile
+  if 0 < ARGV.length
+    core.load( ARGV[0] )
+  else
+    core.repl
+  end
+end
+
+main

data/lib/init.nnd

@@ -0,0 +1,486 @@
+;;-*- mode: nendo; syntax: scheme -*-;;
+
+;; ----------------------------------------
+;; define
+;; ----------------------------------------
+(set! define
+      (macro (arg . body)
+        (if (not (pair? arg))
+            (cons 'set!
+                  (cons arg
+                        body))
+            (cons 'set!
+                  (cons (car arg)
+                        (list
+                         (cons 'lambda
+                               (cons  (cdr arg)
+                                      body))))))))
+
+;; ----------------------------------------
+;; car and cdr functions
+;; ----------------------------------------
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (car (cdr x)))))
+(define (caadar x) (car (car (cdr (car x)))))
+(define (caaddr x) (car (car (cdr (cdr x)))))
+(define (cadaar x) (car (cdr (car (car x)))))
+(define (cadadr x) (car (cdr (car (cdr x)))))
+(define (caddar x) (car (cdr (cdr (car x)))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (car (cdr x)))))
+(define (cdadar x) (cdr (car (cdr (car x)))))
+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (car (cdr x)))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+
+;; ----------------------------------------
+;; List Utility functions
+;; ----------------------------------------
+(define iota range)
+
+(define (append a b)
+  (define (append-reverse a b)
+    (if (pair? a)
+        (append-reverse (cdr a) (cons (car a) b))
+        b))
+  (append-reverse (reverse a) b))
+
+;; ----------------------------------------
+;; Utility functions
+;; ----------------------------------------
+(define (even? n) (= (% n 2) 0))
+(define (odd? n) (not (= (% n 2) 0)))
+(define (zero? n) (= n 0))
+(define (positive? n) (> n 0))
+(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)))
+(define (min . lst)
+     (foldr (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)
+  (define (nth-iter n index lst)
+    (if (null? lst)
+        nil
+        (if (not (pair? lst))
+            (error "Error: nth got improper list.")
+            (if (eqv? n index)
+                (car lst)
+                (nth-iter n (+ index 1) (cdr lst))))))
+  (nth-iter n 0 lst))
+(define (first lst)    (nth  0 lst))
+(define (second lst)   (nth  1 lst))
+(define (third lst)    (nth  2 lst))
+(define (fourth lst)   (nth  3 lst))
+(define (fifth lst)    (nth  4 lst))
+(define (sixth lst)    (nth  5 lst))
+(define (seventh lst)  (nth  6 lst))
+(define (eighth lst)   (nth  7 lst))
+(define (ninth lst)    (nth  8 lst))
+(define (tenth lst)    (nth  9 lst))
+
+
+;; ----------------------------------------
+;; basic forms
+;; ----------------------------------------
+(define (macroexpand sexp)
+  (let ((newsexp (macroexpand-1 sexp)))
+    (if (not (equal? sexp newsexp))
+        (macroexpand newsexp)
+        newsexp)))
+
+(define (feedto)
+  (error "=> (feedto) appeared outside cond or case."))
+
+(define cond
+  (macro lst
+    (define (case-block elem . elseblock)
+      (let ((condition (if (eq? 'else (car elem))
+                           true
+                           (car elem)))
+            (body      (cdr elem))
+            (tmpsym    (gensym)))
+        ;;(display "CONDITION") (print condition)
+        ;;(display "BODY")      (print body)
+        ;;(display "TMPSYM")    (print tmpsym)
+        (append
+         (if (eq? 'feedto (car body))
+             (cons 'if
+                   (list
+                    (list 'set! tmpsym condition)
+                    (list (cadr body) tmpsym)))
+             (cons 'if
+                   (list
+                    condition
+                    (cons 'begin body))))
+         (if (< 0 (length elseblock))
+             elseblock
+             '()))))
+
+    (define (cond-iter lst)
+      (if (eq? 0 (length lst))
+          '()
+          (if (eq? 1 (length lst))
+              (case-block (car lst) '())
+              (case-block (car lst)
+                          (cond-iter (cdr lst))))))
+    
+    (cond-iter lst)))
+
+(define let1
+  (macro (var expr . body)
+    (append
+     (list 'let (list (list var expr)))
+     body)))
+
+(define or
+  (macro lst
+    (define (or-iter lst)
+      (cond
+       ((eq? 0 (length lst))
+        false)
+       ((eq? 1 (length lst))
+        (let1 sym (gensym)
+              (list 'let1 sym (car lst)
+                    (list 'if sym sym false))))
+       (else
+        (let1 sym (gensym)
+              (list 'let1 sym (car lst)
+                    (list 'if sym sym (or-iter (cdr lst))))))))
+    (or-iter lst)))
+
+(define and
+  (macro lst
+    (define (and-iter lst)
+      (cond
+       ((eq? 0 (length lst))
+        true)
+       ((eq? 1 (length lst))
+        (car lst))
+       (else
+        (list 'if (list 'not (list 'eq? 'false (car lst)))
+              (and-iter (cdr lst))
+              'false))))
+    (and-iter lst)))
+
+(define apply
+  (macro (proc . args)
+    (define (strip-quote lst)
+      (if (eq? 'quote (car lst))
+          (cadr lst)
+          lst))
+    (define (apply-iter lst)
+      (cond
+       ((eq? 0 (length lst))
+        '())
+       ((eq? 1 (length lst))
+        (if (pair? (car lst))
+            (strip-quote (car lst))
+            (error "not a proper list")))
+       (else
+        (append (list (car lst)) (apply-iter (cdr lst))))))
+    (append (list proc) (apply-iter args))))
+
+
+;; The following quasiquote macro is due to Eric S. Tiedemann. ( Imported from TinyScheme )
+;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
+;;
+;; Subsequently modified for initialize library for nendo: Kiyoka Nishiyama
+(define quasiquote
+ (macro (l)
+   (define (mcons f l r)
+     (if (and (pair? r)
+              (eq? (car r) 'quote)
+              (eq? (car (cdr r)) (cdr f))
+              (pair? l)
+              (eq? (car l) 'quote)
+              (eq? (car (cdr l)) (car f)))
+         (if (or (procedure? f) (number? f) (string? f))
+               f
+               (list 'quote f))
+         (list 'cons l r)))
+   (define (mappend f l r)
+     (if (or (null? (cdr f))
+             (and (pair? r)
+                  (eq? (car r) 'quote)
+                  (eq? (car (cdr r)) '())))
+         l
+         (list 'append l r)))
+   (define (foo level form)
+     (cond ((not (pair? form))
+               (if (or (procedure? form) (number? form) (string? form))
+                    form
+                    (list 'quote form))
+               )
+           ((eq? 'quasiquote (car form))
+            (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
+           (else (if (zero? level)
+                   (cond ((eq? (car form) 'unquote) (car (cdr form)))
+                         ((eq? (car form) 'unquote-splicing)
+                          (error "Unquote-splicing wasn't in a list:"
+                                 form))
+                         ((and (pair? (car form))
+                               (eq? (car (car form)) 'unquote-splicing))
+                          (mappend form (car (cdr (car form)))
+                                   (foo level (cdr form))))
+                         (else (mcons form (foo level (car form))
+                                         (foo level (cdr form)))))
+                   (cond ((eq? (car form) 'unquote)
+                          (mcons form ''unquote (foo (- level 1)
+                                                     (cdr form))))
+                         ((eq? (car form) 'unquote-splicing)
+                          (mcons form ''unquote-splicing
+                                      (foo (- level 1) (cdr form))))
+                         (else (mcons form (foo level (car form))
+                                         (foo level (cdr form)))))))))
+   (foo 0 l)))
+
+(define unquote
+  (macro (lst)
+    (error "unquote appeared outside quasiquote")))
+
+(define unquote-splicing
+  (macro (lst)
+    (error "unquote-splicing appeared outside quasiquote")))
+
+
+(define when
+  (macro form
+    `(if ,(car form) (begin ,@(cdr form)))))
+  
+(define unless
+  (macro form
+    `(if (not ,(car form)) (begin ,@(cdr form)))))
+
+(define while
+  (macro form
+    (let1 sym (gensym)
+      `(begin
+	 (define ,sym
+	   (lambda ()
+	     (if ,(car form)
+		 (begin ,@(cdr form)
+			(,sym)))))
+	 (,sym)))))
+
+(define until
+  (macro form
+    `(while (not ,(car form))
+       ,@(cdr form))))
+
+
+;; ----------------------------------------
+;; List utilities imported from TinyScheme
+;; ----------------------------------------
+;; generic-member 
+(define (generic-member cmp obj lst)
+  (cond
+    ((null? lst) false)
+    ((cmp obj (car lst)) lst)
+    (else (generic-member cmp obj (cdr lst)))))
+
+(define (memq obj lst)
+     (generic-member eq? obj lst))
+(define (memv obj lst)
+     (generic-member eqv? obj lst))
+(define (member obj lst)
+     (generic-member equal? obj lst))
+
+;; generic-assoc
+(define (generic-assoc cmp obj alst)
+     (cond
+          ((null? alst) false)
+          ((cmp obj (caar alst)) (car alst))
+          (else (generic-assoc cmp obj (cdr alst)))))
+
+(define (assq obj alst)
+     (generic-assoc eq? obj alst))
+(define (assv obj alst)
+     (generic-assoc eqv? obj alst))
+(define (assoc obj alst)
+     (generic-assoc equal? obj alst))
+
+(define (acons x y z) (cons (cons x y) z))
+
+(define (assq-ref obj alst)
+  (cond  ((assq obj alst)  => cdr)
+         (else                nil)))
+(define (assv-ref obj alst)
+  (cond  ((assv obj alst)  => cdr)
+         (else                nil)))
+(define (assoc-ref obj alst)
+  (cond  ((assoc obj alst)  => cdr)
+         (else                nil)))
+
+
+;; ----------------------------------------
+;; Higher-order functions
+;; ----------------------------------------
+(define (map pred lst)
+  (if (null? lst)
+      '()
+      (cons
+       (pred (car lst))
+       (map pred (cdr lst)))))
+(define for-each map)
+
+(define (filter pred lst)
+  (if (null? lst)
+      '()
+      (let1 result (pred (car lst))
+        (if result
+            (cons
+             result
+             (filter pred (cdr lst)))
+            (filter pred (cdr lst))))))
+
+(define (filter-map pred lst)
+  (if (null? lst)
+      '()
+      (if (pred (car lst))
+          (cons
+           (car lst)
+           (filter-map pred (cdr lst)))
+          (filter-map pred (cdr lst)))))
+
+
+;; ----------------------------------------
+;; other forms
+;; ----------------------------------------
+(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? ,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))))))
+
+    (let1 sym (gensym)
+      `(let1 ,sym ,cond-exp
+         (cond
+          ,@(case-iter sym body))))))
+
+
+(define let*
+  (macro (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)))
+
+
+;; ----------------------------------------
+;; for Ruby interop
+;; ----------------------------------------
+;; dot_operator
+(define dot-operator
+  (macro lst
+    (define (dot-operator-iter lst)
+      (cond
+       ((null? lst)
+        '())
+       ((pair? lst)
+        (if (eq? 'dot-operator (car lst))
+            (intern
+             (string-join
+              (map
+               (lambda (x)
+                 (if (pair? x)
+                     (to-s (dot-operator-iter x))
+                     (if (symbol? x)
+                         (to-s x)
+                         (error (sprintf "dot-operator requires symbol, but got %s" x)))))
+               (cdr lst))
+              "."))
+            (error "dot-operator requires symbol or (. symbol symbol) form.")))
+       (else
+        lst)))
+
+    (cond
+     ((eq? 0 (length lst))
+      (error ". operator requires argument"))
+     ((and (eq? 1 (length lst))
+           (symbol? (car lst)))
+      (intern (+ "." (to-s (car lst)))))
+     (else
+      ((dot-operator-iter
+        (cons 'dot-operator lst)))))))
+
+(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))))
+
+
+;; ----------------------------------------
+;; List library functions
+;; ----------------------------------------
+(define (last-pair x)
+    (if (pair? (cdr x))
+        (last-pair (cdr x))
+        x))
+
+
+;; ----------------------------------------
+;; Utility function for testing
+;; ----------------------------------------
+;; pass through the argument value as return value.
+(define (pass x) x)
+
+;; ruby's p like function.
+(define (p x)
+  (printf "%s\n" x)
+  x)