From bc2450b4b29d6bb8ba5422fb9eb7a75d1b6b5a57 Mon Sep 17 00:00:00 2001
From: Tim Vaughan <tgvaughan@gmail.com>
Date: Wed, 1 Mar 2017 14:58:59 +1300
Subject: [PATCH] Added some port and string primitives.

---
 src/scheme-library.scm    | 10 +++----
 src/scheme-primitives.4th | 57 +++++++++++++++++++++++++++++++++++++++
 src/scheme.4th            | 25 +++--------------
 3 files changed, 66 insertions(+), 26 deletions(-)

diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index 68debca..14aa6f8 100644
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -203,7 +203,7 @@
   (define (iter a count)
     (if (null? a)
       count
-      (iter (cdr a) (+ count 1))))
+      (iter (cdr a) (fix:+ count 1))))
   (iter l 0))
 
 ; Join two lists together
@@ -330,18 +330,18 @@
 (define (sum n)
 
   (define (sum-iter total count maxcount)
-    (if (> count maxcount)
+    (if (fix:> count maxcount)
       total
-      (sum-iter (+ total count) (+ count 1) maxcount)))
+      (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
   
   (sum-iter 0 1 n))
 
 ; Recursive summation. Use this to compare with tail call
 ; optimized iterative algorithm.
 (define (sum-recurse n)
-  (if (= n 0)
+  (if (fix:= n 0)
     0
-    (+ n (sum-recurse (- n 1)))))
+    (fix:+ n (sum-recurse (fix:- n 1)))))
 
 ;; MISC
 
diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th
index ba48b9e..1ed995b 100644
--- a/src/scheme-primitives.4th
+++ b/src/scheme-primitives.4th
@@ -153,6 +153,37 @@
     charlist>symbol
 ; make-primitive string->symbol
 
+:noname ( charlist -- string )
+    2dup 1 ensure-arg-count
+
+    car nil? if
+        2drop
+        nil nil cons
+        drop string-type
+        exit
+    then
+    
+    pair-type ensure-arg-type
+
+    duplicate-charlist
+    drop string-type
+; make-primitive list->string
+
+:noname ( string -- charlist )
+    2dup 1 ensure-arg-count
+    car string-type ensure-arg-type
+
+    drop pair-type
+
+    2dup car nil? if
+        2swap 2drop
+    else
+        2drop
+        duplicate-charlist
+    then
+
+; make-primitive string->list
+
 \ }}}
 
 \ ==== Numeric types ==== {{{
@@ -432,6 +463,32 @@
 
 \ ==== Input/Output ==== {{{
 
+:noname ( -- port )
+    console-i/o-port obj@
+; 0 make-fa-primitive console-i/o-port
+
+:noname ( -- port )
+    current-input-port obj@
+; 0 make-fa-primitive current-input-port
+
+: charlist>cstr ( charlist addr -- n )
+
+    dup 2swap ( origaddr addr charlist )
+
+    begin 
+        nil? false =
+    while
+        2dup cdr 2swap car 
+        drop ( origaddr addr charlist char )
+        -rot 2swap ( origaddr charlist addr char )
+        over !
+        1+ -rot ( origaddr nextaddr charlist )
+    repeat
+
+    2drop ( origaddr finaladdr ) 
+    swap -
+;
+
 :noname ( args -- finalResult )
     drop pair-type
     pad charlist>cstr
diff --git a/src/scheme.4th b/src/scheme.4th
index 52fcbcc..7710388 100644
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@ -36,7 +36,7 @@ make-type pair-type
 make-type symbol-type
 make-type primitive-proc-type
 make-type compound-proc-type
-make-type fileport-type
+make-type port-type
 : istype? ( obj type -- obj bool )
     over = ;
 
@@ -181,7 +181,7 @@ variable nextfree
     drop ;
 
 : fid>fileport ( fid -- fileport )
-    fileport-type ;
+    port-type ;
 
 : open-input-file ( addr n -- fileport )
     r/o open-file drop fid>fileport
@@ -192,7 +192,7 @@ variable nextfree
 ;
 
 objvar console-i/o-port
-0 fileport-type console-i/o-port obj!
+0 port-type console-i/o-port obj!
 
 objvar current-input-port
 console-i/o-port obj@ current-input-port obj!
@@ -1780,6 +1780,7 @@ hide env
     primitive-proc-type istype? if printprim exit then
     compound-proc-type istype? if printcomp exit then
     none-type istype? if printnone exit then
+    port-type istype? if printport exit then
 
     recoverable-exception throw" Tried to print object with unknown type."
 ; is print
@@ -1892,24 +1893,6 @@ variable gc-stack-depth
 
 \ ---- Loading files ---- {{{
 
-: charlist>cstr ( charlist addr -- n )
-
-    dup 2swap ( origaddr addr charlist )
-
-    begin 
-        nil? false =
-    while
-        2dup cdr 2swap car 
-        drop ( origaddr addr charlist char )
-        -rot 2swap ( origaddr charlist addr char )
-        over !
-        1+ -rot ( origaddr nextaddr charlist )
-    repeat
-
-    2drop ( origaddr finaladdr ) 
-    swap -
-;
-
 : load ( addr n -- finalResult )
     open-input-file
 
-- 
2.20.1