nendo 0.5.0 → 0.5.1

data/emacs/nendo-mode.el

@@ -150,6 +150,8 @@ Editing commands are similar to those of 'scheme-mode'."
 	(let-match . 2)
 	(let-optionals* . 2)
 	(let-values . 1)
+	(let-syntax . 1)
+	(letrec-syntax . 1)
 	(let1 . 2)
 	(let/cc . 1)
 	(make . 1)

data/lib/init.nnd

@@ -61,8 +61,8 @@
 
 (define %expand-define-form
   (lambda (arg-and-body)
-    (let ((arg  (car arg-and-body))
-          (body (cdr 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)
@@ -168,15 +168,20 @@
   (lambda str-lst
     (string-join str-lst "")))
 
+(define (string=? a b)
+  (eq? a b))
 
 ;; ----------------------------------------
 ;; basic forms
 ;; ----------------------------------------
 (define (macroexpand sexp)
-  (let ((newsexp (macroexpand-1 sexp)))
-    (if (not (equal? sexp newsexp))
-        (macroexpand newsexp)
-        newsexp)))
+  (%let ((newsexp (macroexpand-1 sexp)))
+     (if (not (equal? sexp newsexp))
+         (macroexpand newsexp)
+         (strip-let-syntax-keyword
+          (strip-syntax-quote
+           newsexp)))))
+         
 
 (define (feedto)
   (error "=> (feedto) appeared outside cond or case."))
@@ -185,9 +190,9 @@
   (macro lst
     (letrec ((case-block
               (lambda (elem . elseblock)
-                (let ((condition (if (eq? 'else (car elem))
-                                     true
-                                     (car elem)))
+                (%let ((condition (if (eq? 'else (car elem))
+                                      true
+                                      (car elem)))
                       (body      (if (null? (cdr elem))
                                      '(#t)
                                      (cdr elem)))
@@ -221,7 +226,7 @@
 (define let1
   (macro (var expr . body)
     (append
-     (list 'let (list (list var expr)))
+     (list '%let (list (list var expr)))
      body)))
 
 (define or
@@ -375,8 +380,8 @@
                  (second x))
                (second lst))))
            
-        ;; don't touch
-        `(let ,@lst))))
+        ;; trasform to internal let syntax (%let)
+        `(%let ,@lst))))
 
 (define if-let1
   (macro (var _expr _then . _else)
@@ -384,6 +389,10 @@
        (if ,var ,_then ,@_else))))
 
 
+(define push!
+  (macro (_lst _val)
+    `(set! ,_lst (append (list ,_val) ,_lst))))
+
 ;; ----------------------------------------
 ;; errorf
 ;; ----------------------------------------
@@ -541,9 +550,9 @@
 (define (%internal-define-to-letrec _sym _src)
   (if (not (list? (cadr _src)))
       `(,_sym ,@_src)
-      (let ((body (cdr _src))
-            (defs '())
-            (rest '()))
+      (%let ((body (cdr _src))
+             (defs '())
+             (rest '()))
         (if (not (list? (car body)))
             `(,_sym ,@_src)
             (begin
@@ -554,8 +563,8 @@
                      (set! defs (cons (%expand-define-form (cdr x)) defs))
                      (set! rest (cons x rest))))
                body)
-              (let ((defs (reverse defs))
-                    (rest (reverse rest)))
+              (%let ((defs (reverse defs))
+                     (rest (reverse rest)))
                 (if (< 0 (length defs))
                     `(,_sym
                       ,(car _src)
@@ -872,7 +881,7 @@
 (define (cons* arg . args)
   (if (null? args)
       arg
-      (cons arg (apply list* args))))
+      (cons arg (apply cons* args))))
 (define list* cons*)
 
 
@@ -1304,11 +1313,11 @@
 
 
 ;; ----------------------------------------
-;; tail-call-optimization
+;; tail call optimization
 ;; ----------------------------------------
-(define (setup-tailcall-mark sexp)
+(define (%setup-%tailcall-mark sexp)
   (define (reserved? sym)
-    (let* ([reserved-orig '(quote syntax-quote macro %syntax begin lambda if let letrec define define-syntax)]
+    (let* ([reserved-orig '(quote syntax-quote macro %syntax begin lambda if %let letrec define define-syntax)]
            [reserved (append reserved-orig
                              (map
                               (lambda (orig)
@@ -1324,7 +1333,7 @@
          (list name
                (if (list? body)
                    (if (reserved? (car body))
-                       (setup-tailcall-mark body)
+                       (%setup-%tailcall-mark body)
                        body)
                    body))))
      args))
@@ -1336,7 +1345,7 @@
      ((and (list? sexp)
            (< 0 (length sexp)))
       (if (reserved? (car sexp))
-          (setup-tailcall-mark sexp)
+          (%setup-%tailcall-mark sexp)
           (if (pair? (car sexp))
               sexp ;; e.g.  ((lambda (x) ...)
               `(%tailcall ,sexp))))
@@ -1356,7 +1365,7 @@
                (cons
                 (if (reserved? (car last))
                     ;; recursive
-                    (setup-tailcall-mark last)
+                    (%setup-%tailcall-mark last)
                     ;; this is the tailcall!
                     `(%tailcall ,last))
                 other))))))
@@ -1395,7 +1404,7 @@
               ,(second sexp)
               ,(setup-proc     (third sexp))
               ,(setup-proc     (fourth sexp))))))
-        ((let /nendo/core/let)
+        ((%let /nendo/core/%let)
          `(,_car
            ,(setup-let-args (second sexp))
            ,@(setup-proc-body (cddr sexp))))
@@ -1410,7 +1419,7 @@
               ,(if (and (list? val)
                         (not (null? val))
                         (reserved? (car val)))
-                   (setup-tailcall-mark val)
+                   (%setup-%tailcall-mark val)
                    val))))
         ((set! /nendo/core/set!)
          (let1 val (third sexp)
@@ -1419,7 +1428,7 @@
              ,(if (and (list? val)
                        (not (null? val))
                        (reserved? (car val)))
-                  (setup-tailcall-mark val)
+                  (%setup-%tailcall-mark val)
                   val))))
         (else
          (if (symbol? (car sexp))
@@ -1429,29 +1438,29 @@
     sexp)))
 
 
+
 ;; definition of 'compile-phase'
 (set! %compile-phase-functions
       (list
-       setup-tailcall-mark
+       %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))
 
+(define (identifier->symbol id)
+  (when (not (symbol? id))
+    (error "Error: identifier->symbol requires only symbol"))
+  id)
 
 ;; readable code for nendo. (original code is chibi-scheme-0.3)
 (define er-macro-transformer
@@ -1469,7 +1478,6 @@
                    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
@@ -1483,6 +1491,12 @@
 (define-syntax syntax-rules
   (er-macro-transformer
    (lambda (expr rename compare)
+     (when (not (pair? (cdr expr)))
+       (error "syntax-rules requires: (syntax-rules (ellipses...) ..patterns..) form (1). but got: " expr))
+     (when (not (or (null? (cadr expr)) (list? (cadr expr))))
+       (error "syntax-rules requires: (syntax-rules (ellipses...) ..patterns..) form (2). but got: " expr))
+     (when (> 3 (length expr))
+       (error "syntax-rules requires: (syntax-rules (ellipses...) ..patterns..) form (3). but got: " expr))
      (let ((ellipse-specified? (identifier? (cadr expr)))
            (count 0)
            (_er-macro-transformer (rename 'er-macro-transformer))
@@ -1502,7 +1516,8 @@
            (_- (rename '-))   (_>= (rename '>=))   (_error (rename 'error))
            (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
            (_vector->list (rename 'vector->list))
-           (_list->vector (rename 'list->vector)))
+           (_list->vector (rename 'list->vector))
+           (_list (rename 'list)))
        (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)))
@@ -1689,5 +1704,6 @@
                 (list (list _error "no expansion for"
                             (list (rename 'strip-syntactic-closures) _expr)))))))))))
 
+(define-syntax %syntax-rules syntax-rules)
 
 ;;[EOS]