From f79d4dec5d3094846834a7b9d5a3795374628fdb Mon Sep 17 00:00:00 2001
From: Stefano Dissegna <stefano.dissegna@gmail.com>
Date: Fri, 26 Jun 2009 16:20:01 +0200
Subject: [PATCH] able to load a (slightly modified) version of arc.arc

---
 arc/qq.arc        |  6 +++---
 compiler/boot.arc | 21 ++++++++++++---------
 compiler/comp.arc | 37 +++++++++++++++++++++++++++----------
 read.pir          | 13 ++++++++++---
 types.pir         |  4 ++++
 5 files changed, 56 insertions(+), 25 deletions(-)

diff --git a/arc/qq.arc b/arc/qq.arc
index 2cae371..9ee5b5d 100644
--- a/arc/qq.arc
+++ b/arc/qq.arc
@@ -21,10 +21,10 @@
           (eval-qq (cadr x) (- level 1))
         (is (car x) 'unquote)
           (list 'unquote (eval-qq (cadr x) (- level 1)))
-        (and (is level 1) (is (car x) 'splice))
+        (and (is level 1) (is (car x) 'unquote-splicing))
           (list '__to-splice (eval-qq (cadr x) (- level 1)))
-        (is (car x) 'splice)
-          (list 'splice (eval-qq (cadr x) (- level 1)))
+        (is (car x) 'unquote-splicing)
+          (list 'unquote-splicing (eval-qq (cadr x) (- level 1)))
         (is (car x) 'quasiquote)
           (list 'quasiquote (eval-qq (cadr x) (+ level 1)))
         (cons 'list (map1 [eval-qq _ level] x)))))
diff --git a/compiler/boot.arc b/compiler/boot.arc
index b130ed8..3ead4c6 100644
--- a/compiler/boot.arc
+++ b/compiler/boot.arc
@@ -27,7 +27,10 @@
 (def cddr (x) (cdr (cdr x)))
 
 (def map1 (f l)
-  (if l (cons (f (car l)) (map1 f (cdr l)))))
+  ((afn (l acc)
+     (if l
+       (self (cdr l) (cons (f (car l)) acc))
+       (rev acc))) l nil))
 
 (def mem (x l)
   (if (no l) l
@@ -97,21 +100,21 @@
    x nil))
 
 ; not the official some
-(def some (test l)
+(def at-least-one (test l)
   (if l
-    (or (test (car l)) (some test (cdr l)))
+    (or (test (car l)) (at-least-one test (cdr l)))
     nil))
 
 ; from arc.arc (minus string stuff)
 (def map (f . seqs)
   (if (no (cdr seqs)) 
        (map1 f (car seqs))
-      ((afn (seqs)
-        (if (some no seqs)  
-            nil
-            (cons (apply f (map1 car seqs))
-                  (self (map1 cdr seqs)))))
-       seqs)))
+      ((afn (seqs acc)
+        (if (at-least-one no seqs)  
+            (rev acc)
+            (self (map1 cdr seqs) 
+                  (cons (apply f (map1 car seqs)) acc))))
+       seqs nil)))
 
 ; from arc.arc
 (def listtab (al)
diff --git a/compiler/comp.arc b/compiler/comp.arc
index 1dcfc3d..39bba4e 100644
--- a/compiler/comp.arc
+++ b/compiler/comp.arc
@@ -76,6 +76,7 @@
       (compile-fn (empty-state) f))))
 
 (let escape-table (listtab '((#\newline "\\n")
+                             (#\return "\\r")
                              (#\\ "\\\\")
                              (#\tab "\\t")
                              (#\" "\\\"")))
@@ -163,10 +164,13 @@
     (emit-const const!expr)
     (prn "set_hll_global '" const!name "', " (c-pop cs))))
 
-(def emit-fn-head (cs name outer)
-  (if (iso outer "")
-    (prn ".sub " name)
-    (prn ".sub " name " :outer('" outer "')")))
+(def emit-fn-head (cs name dbg-name outer)
+  (pr ".sub '" (or dbg-name name) "' :nsentry('" name "')")
+  (if dbg-name
+    (pr " :subid('" name "')"))
+  (if (no (iso outer ""))
+    (pr " :outer('" outer "')"))
+  (prn))
 
 ; emit a sequence of operations
 ; if sequence is empty, emit code to return nil
@@ -193,7 +197,7 @@
           body (cdddr e))
     (unless (isa name 'sym)
       (err:string "not a symbol: " name))
-    (emit-fn-head cs name f!outer)
+    (emit-fn-head cs name f!dbg-name f!outer)
     (emit-args args)
     ; emit the body
     (reset-reg cs)
@@ -260,11 +264,15 @@
 (def a-fn (e)
   (and (acons e) (is (car e) 'fn)))
 
+(def a-fn-assign (e)
+  (and (acons e) (is (car e) 'assign) (a-fn (caddr e))))
+
 (def mk-const (name expr)
   (listtab (list (list 'name name) (list 'expr expr))))
 
-(def mk-fn (expr outer lex)
-  (listtab (list (list 'expr expr) (list 'outer outer) (list 'lex lex))))
+(def mk-fn (expr outer lex dbg-name)
+  (listtab (list (list 'expr expr) (list 'outer outer) 
+                 (list 'lex lex) (list 'dbg-name dbg-name))))
 
 (def arg-names (args)
   ; consider destructuring too
@@ -273,7 +281,8 @@
     (list args)
     (flat (map [if (is-opt _) (cadr _) _] (makeproper args)))))
 
-(def collect-fns-and-consts (expr lex outer is-seq consts)
+(def collect-fns-and-consts (expr lex outer is-seq consts (o have-name nil))
+;  (ero (string "collect: " expr))
   (if
     (in (e-type expr) 'sym 't 'nil) 
       (list nil nil expr)
@@ -282,19 +291,27 @@
         (list nil nil (consts expr))
         (let name (uniq)
           (= (consts expr) name)
+          ;(ero (string "    name: " name " -> " expr))
           (list nil (list (mk-const name expr)) name)))
+    (a-fn-assign expr)
+      (let (f c e) (collect-fns-and-consts (caddr expr) lex outer 
+                                           is-seq consts (cadr expr))
+        (list f c (list 'assign (cadr expr) e)))
     (a-fn expr)
       (withs (name (uniq)
               args expr.1
               body (cddr expr)
               new-lex (join (arg-names args) lex))
-        (let (fns consts expr) (collect-fns-and-consts body new-lex name t consts)
+        (let (fns consts expr) (collect-fns-and-consts body new-lex 
+                                                       name t consts)
           (list (cons (mk-fn (cons '$fn (cons name (cons args expr)))
-                              outer new-lex)
+                              outer new-lex have-name)
                       fns)
                 consts (list (if (iso outer "") '$function '$closure) name))))
     (let res (map [collect-fns-and-consts _ lex outer nil consts] expr)
+      ;(ero "res: " res)
       (let res (apply map list res)
+        ;(ero "  res2: " res)
         (list (apply join res.0) (apply join res.1) res.2)))))
 
 (def mac-ex (e)
diff --git a/read.pir b/read.pir
index e4a5341..802d6c1 100644
--- a/read.pir
+++ b/read.pir
@@ -52,6 +52,7 @@
    $P0["t"] = "\t"
    $P0["\\"] = "\\"
    $P0["\""] = "\""
+	 $P0["r"] = "\r"
    set_hll_global 'escape-table*', $P0
 
    ## Global character names table
@@ -59,6 +60,7 @@
    $P0["newline"] = "\n"
    $P0["space"] = " "
    $P0["tab"] = "\t"
+	 $P0["return"] = "\r"
    set_hll_global 'char-table*', $P0
    
    ## Global ssyntax table
@@ -181,7 +183,7 @@ keep_going:
    .tailcall $P0(rs)
 default:
    ## if the character isn't present in the read table, read a symbol
-   .tailcall _read_symbol(rs)
+   .tailcall _read_symbol(rs, 1)
 eof_found:      
    $P0 = new 'Eof'
    .return ($P0)
@@ -214,6 +216,8 @@ end:
 
 .sub '_read_symbol'
    .param pmc rs
+	 .param int do_ssexpand
+	 
    .local string result
 
    result = ""
@@ -235,6 +239,9 @@ end:
    if result == "t" goto ret_t
    if result == "nil" goto ret_nil
    $P0 = 'intern'(result)
+	 if do_ssexpand goto expand
+	 .return ($P0)
+expand:	
    .tailcall 'ssexpand'($P0)
 ret_t:
    $P0 = get_hll_global 't'
@@ -319,7 +326,7 @@ mk_symbol:
    rs.'get1'() # skip #
    $S0 = rs.'get1'()
    unless $S0 == "\\" goto error
-   $P0 = _read_symbol(rs)
+   $P0 = _read_symbol(rs, 0)
    $S0 = $P0.'to_string'() # get char name
    $S1 = ct[$S0]
    unless $S1 == "" goto ret_it
@@ -460,7 +467,7 @@ error:
    rs.'get1'() # skip ,
    $S0 = rs.'peek1'()
    unless $S0 == '@' goto go_on
-   type = "splice"
+   type = "unquote-splicing"
    rs.'get1'() # throw away '@'
 go_on:
    .tailcall _read_next_with_head(rs, type)
diff --git a/types.pir b/types.pir
index 60e8f8b..a3ce965 100644
--- a/types.pir
+++ b/types.pir
@@ -67,6 +67,10 @@
 	 .return ("hash")
 .end
 
+.sub 'get_bool' :vtable :method
+	 .return (1)
+.end
+
 .sub 'pr_repr' :method
 	 .return ("#hash()")
 .end