open-socket, socket-accept

STATUS

@@ -10,11 +10,11 @@ See README
 
 + if
 + fn 
-  - destructuring args
-  - optional args
+  + destructuring args
+  + optional args
   + rest arg
 + set
-- apply (it's there but doesn't work)
++ apply
 + quote
 
 * Basic macros
@@ -58,7 +58,7 @@ See README
 + writeb
 + write
 + disp
-+ read - no ssyntax
++ read
 - coerce
 - open-socket 
 - socket-accept

arc.pir

@@ -37,7 +37,7 @@
     ## default value for ***
     $P1 = get_hll_global 'nil'
     set_hll_global '***', $P1
-#    push_eh run_error
+    #push_eh run_error
 loop:
     unless iter goto end 
     $S0 = shift iter
@@ -67,15 +67,15 @@ run_error:
 eval_mode:
     $P0 = getstdin
 loop2:
-#    push_eh error # never give up
+    #push_eh error # never give up
     $S0 = $P0.'readline_interactive'( 'arc> ' )
     $P2 = _compile_and_eval($S0)
 		##print ' -> '
     'prn'($P2)
     goto loop2
 error:
     .get_results($P2)
-    say $P2
+		say $P2
     goto loop2
 the_end:        
 .end

arc/qq.arc

@@ -0,0 +1,40 @@
+; quasiquoting
+
+(set and 
+  (annotate 'mac 
+    (fn (a b)
+      (list 'if a (list 'if b t)))))
+
+(set splice 
+  (fn (l before)
+    (if (and (no (acons l)) l)
+      l
+      (if (no l)
+        before
+        (if (acons (car l))
+          (if (is (car (car l)) '__to-splice)
+            (let res (list '+ before (splice (cadr (car l)) nil))
+              (list '+ res (cons 'list (splice (cdr l) nil))))
+            (splice (cdr l) (+ before (list (splice (car l) nil)))))
+          (splice (cdr l) (+ before (list (car l)))))))))
+
+(set eval-qq 
+  (fn (x level)
+    (if (is level 0) x
+        (atom x) (list 'quote x)
+        (and (is level 1) (is (car x) 'unquote))
+          (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))
+          (list '__to-splice (eval-qq (cadr x) (- level 1)))
+        (is (car x) 'splice)
+          (list 'splice (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)))))
+
+(set quasiquote 
+  (annotate 'mac 
+    (fn (x)
+      (splice (eval-qq x 1) nil))))

arcall.pir

@@ -131,6 +131,9 @@ ret_nil:
       $P0 = "Can't call a "
       $S0 = typeof what
       $P0 .= $S0
+			$P0 .= ": "
+			$S0 = what.'to_string'()
+			$P0 .= $S0
       .tailcall 'err'($P0)
    .end
 .endm

builtins.pir

@@ -565,6 +565,56 @@ error:
    .tailcall '_open_file'(cmd, $P0, 'wp')
 .end
 
+.include 'sockets.pasm'
+
+.sub 'open-socket'
+	 .param pmc port
+
+	 $I0 = port
+	 $P0 = new 'ArcSocket'
+	 $P1 = new 'Socket'
+	 setattribute $P0, 'stream', $P1
+
+	 .local pmc addr
+	 $P1.'socket'(.AF_INET, .SOCK_STREAM, .IPPROTO_TCP)
+	 addr = $P1.'sockaddr'('localhost', port)
+	 $P1.'bind'(addr)
+	 $P1.'listen'(1024) # randomly choosen
+
+	 .return ($P0)
+.end
+
+.sub 'socket-accept'
+	 .param pmc sock
+
+	 .local pmc in
+	 .local pmc out
+	 .local pmc ip
+
+	 $P0 = getattribute sock, 'stream'
+	 $P0 = $P0.'accept'()
+	 ## !! in & out share the same filehandle
+	 ## !! will create problems with close()
+	 in = new 'Inport'
+	 setattribute in, 'stream', $P0
+	 out = new 'Outport'
+	 setattribute out, 'stream', $P0
+	 ip = new 'ArcStr'
+	 ip = "" # TODO: implement
+	 $P0 = get_hll_global 'nil'
+	 $P0 = 'cons'(ip, $P0)
+	 $P0 = 'cons'(out, $P0)
+	 $P0 = 'cons'(in, $P0)
+
+	 .return ($P0)
+.end
+
+.sub 'client-ip'
+	 .param pmc sock
+	 ## TODO
+	 .return ("")
+.end
+
 .sub 'close'
    .param pmc port
    $P0 = getattribute port, 'stream'   
@@ -691,7 +741,7 @@ do:
 loop:
    $P1 = 'read'($P0)
    $S0 = typeof $P1
-   if $S0 == 'Eof' goto end
+   if $S0 == 'eof' goto end
    $P2 = 'eval'($P1)
    goto loop
 end:

compiler/boot.arc

@@ -2,8 +2,6 @@
 
 ; functions needed to run compiled pbc compiler
 
-; quasiquoting
-
 ; helper fns
 
 (set sig (table))
@@ -31,40 +29,6 @@
 (def map1 (f l)
   (if l (cons (f (car l)) (map1 f (cdr l)))))
 
-(set splice 
-  (fn (l before)
-    (if (and (no (acons l)) l)
-      l
-      (if (no l)
-        before
-        (if (acons (car l))
-          (if (is (car (car l)) '__to-splice)
-            (let res (list '+ before (splice (cadr (car l)) nil))
-              (list '+ res (cons 'list (splice (cdr l) nil))))
-            (splice (cdr l) (+ before (list (splice (car l) nil)))))
-          (splice (cdr l) (+ before (list (car l)))))))))
-
-(set eval-qq 
-  (fn (x level)
-    (if (is level 0) x
-        (atom x) (list 'quote x)
-        (and (is level 1) (is (car x) 'unquote))
-          (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))
-          (list '__to-splice (eval-qq (cadr x) (- level 1)))
-        (is (car x) 'splice)
-          (list 'splice (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)))))
-
-;(set quasiquote 
-;  (annotate 'mac 
-;    (fn (x)
-;      (splice (eval-qq x 1) nil))))
-
 (def mem (x l)
   (if (no l) l
     (is (car l) x) x

types.pir

@@ -52,8 +52,8 @@
 
    $P0 = newclass 'Eof'
 
-   $P0 = newclass 'Socketport'
-   addattribute $P0, 'fd'
+   $P0 = newclass 'ArcSocket'
+	 addattribute $P0, 'stream' 
 
    ## threading
 
@@ -197,6 +197,14 @@ end:
 
 .namespace ['Eof']
 
+.sub 'name' :vtable :method
+	 .return ("eof")
+.end
+
+.sub 'get_bool' :vtable :method
+	 .return (1)
+.end
+
 .sub 'pr_repr' :method
    .return ("#<eof>")
 .end
@@ -205,7 +213,11 @@ end:
    .return ("#<eof>")
 .end
 
-.namespace ['Socketport']
+.namespace ['ArcSocket']
+
+.sub 'name' :vtable :method
+	 .return ("socket")
+.end
 
 .sub 'pr_repr' :method
    .return ("#<socket>")