Merge branch 'develop' into feature/all-integers-are-bignums

.gitignore

@@ -32,3 +32,9 @@ log*
 utils_src/readprintwc/out
 
 *.dump
+
+*.bak
+
+src/io/fopen
+
+hi\.*

Makefile

@@ -16,7 +16,7 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \
 -npsl -nsc -nsob -nss -nut -prs -l79 -ts2
 
 CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG
-LDFLAGS := -lm
+LDFLAGS := -lm -lcurl
 
 all: $(TARGET)
 

lisp/slurp.lisp

@@ -0,0 +1 @@
+(slurp (set! f (open "http://www.journeyman.cc/")))

src/arith/integer.c

@@ -12,12 +12,6 @@
 #include <math.h>
 #include <stdio.h>
 #include <stdlib.h>
-/* safe_iop, as available in the Ubuntu repository, is this one:
- * https://code.google.com/archive/p/safe-iop/wikis/README.wiki
- * which is installed as `libsafe-iop-dev`. There is an alternate
- * implementation here: https://github.com/redpig/safe-iop/
- * which shares the same version number but is not compatible. */
-#include <safe_iop.h>
 /*
  * wide characters
  */
@@ -76,20 +70,16 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
  * \see add_integers
  */
 __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) {
-    long int val = nilp( c ) ?
+    long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value;
-      0 :
-      pointer2cell( c ).payload.integer.value;
 
     long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 );
 
     __int128_t result = ( __int128_t ) integerp( c ) ?
-        ( val == 0 ) ?
+        ( val == 0 ) ? carry : val : op == '*' ? 1 : 0;
-          carry :
-          val :
-         op == '*' ? 1 : 0;
     debug_printf( DEBUG_ARITH,
                   L"cell_value: raw value is %ld, is_first_cell = %s; %4.4s; returning ",
-                  val, is_first_cell ? "true" : "false", pointer2cell(c).tag.bytes);
+                  val, is_first_cell ? "true" : "false",
+                  pointer2cell( c ).tag.bytes );
     debug_print_128bit( result, DEBUG_ARITH );
     debug_println( DEBUG_ARITH );
 
@@ -110,8 +100,7 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) {
  */
 __int128_t int128_to_integer( __int128_t val,
                               struct cons_pointer less_significant,
-                                      struct cons_pointer new)
+                              struct cons_pointer new ) {
-{
     struct cons_pointer cursor = NIL;
     __int128_t carry = 0;
 
@@ -145,7 +134,9 @@ struct cons_pointer make_integer_128(__int128_t val,
         if ( MAX_INTEGER >= val ) {
             result = make_integer( ( long int ) val, less_significant );
         } else {
-            less_significant = make_integer( (long int)val & MAX_INTEGER, less_significant);
+            less_significant =
+                make_integer( ( long int ) val & MAX_INTEGER,
+                              less_significant );
             val = val >> 60;
         }
 
@@ -285,7 +276,8 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
                     partial = add_integers( partial, new );
                 }
 
-            d = integerp(d) ? pointer2cell( d ).payload.integer.more : NIL;
+                d = integerp( d ) ? pointer2cell( d ).payload.integer.
+                    more : NIL;
                 is_first_d = false;
             }
 
@@ -314,7 +306,6 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
  */
 struct cons_pointer integer_to_string_add_digit( int digit, int digits,
                                                  struct cons_pointer tail ) {
-    digits++;
     wint_t character = btowc( hex_digits[digit] );
     return ( digits % 3 == 0 ) ?
         make_string( L',', make_string( character,
@@ -352,10 +343,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
         while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) {
             if ( !nilp( integer.payload.integer.more ) ) {
                 integer = pointer2cell( integer.payload.integer.more );
-                accumulator += integer.payload.integer.value == 0 ?
+                accumulator += integer.payload.integer.value;
-                    MAX_INTEGER :
-                    ( llabs( integer.payload.integer.value ) *
-                      ( MAX_INTEGER + 1 ) );
                 debug_print
                     ( L"integer_to_string: crossing cell boundary, accumulator is: ",
                       DEBUG_IO );
@@ -369,10 +357,12 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
                               L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ",
                               offset, hex_digits[offset] );
                 debug_print_128bit( accumulator, DEBUG_IO );
+                debug_print( L"; result is: ", DEBUG_IO );
+                debug_print_object( result, DEBUG_IO );
                 debug_println( DEBUG_IO );
 
                 result =
-                    integer_to_string_add_digit( offset, digits++, result );
+                    integer_to_string_add_digit( offset, ++digits, result );
                 accumulator = accumulator / base;
             } while ( accumulator > base );
         }

src/arith/peano.c

@@ -47,7 +47,8 @@ bool zerop( struct cons_pointer arg ) {
                 do {
                     debug_print( L"zerop: ", DEBUG_ARITH );
                     debug_dump_object( arg, DEBUG_ARITH );
-                    result = (pointer2cell( arg ).payload.integer.value == 0);
+                    result =
+                        ( pointer2cell( arg ).payload.integer.value == 0 );
                     arg = pointer2cell( arg ).payload.integer.more;
                 } while ( result && integerp( arg ) );
             }
@@ -85,18 +86,22 @@ bool is_negative( struct cons_pointer arg) {
     return result;
 }
 
-struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg) {
+struct cons_pointer absolute( struct cons_pointer frame_pointer,
+                              struct cons_pointer arg ) {
     struct cons_pointer result = NIL;
     struct cons_space_object cell = pointer2cell( arg );
 
     if ( is_negative( arg ) ) {
         switch ( cell.tag.value ) {
             case INTEGERTV:
-            result = make_integer(llabs(cell.payload.integer.value), cell.payload.integer.more);
+                result =
+                    make_integer( llabs( cell.payload.integer.value ),
+                                  cell.payload.integer.more );
                 break;
             case RATIOTV:
                 result = make_ratio( frame_pointer,
-                                absolute(frame_pointer, cell.payload.ratio.dividend),
+                                     absolute( frame_pointer,
+                                               cell.payload.ratio.dividend ),
                                      cell.payload.ratio.divisor );
                 break;
             case REALTV:
@@ -388,8 +393,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
                                        to_long_double( arg2 ) );
                         break;
                     default:
-                        result = throw_exception( make_cons(
+                        result =
-                          c_string_to_lisp_string( L"Cannot multiply: argument 2 is not a number: " ),
+                            throw_exception( make_cons
+                                             ( c_string_to_lisp_string
+                                               ( L"Cannot multiply: argument 2 is not a number: " ),
                                                c_type( arg2 ) ),
                                              frame_pointer );
                         break;
@@ -415,8 +422,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
                                        to_long_double( arg2 ) );
                         break;
                     default:
-                        result = throw_exception(
+                        result =
-                          make_cons(c_string_to_lisp_string
+                            throw_exception( make_cons
+                                             ( c_string_to_lisp_string
                                                ( L"Cannot multiply: argument 2 is not a number" ),
                                                c_type( arg2 ) ),
                                              frame_pointer );
@@ -428,8 +436,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
                                to_long_double( arg2 ) );
                 break;
             default:
-                        result = throw_exception(
+                result = throw_exception( make_cons( c_string_to_lisp_string
-                          make_cons(c_string_to_lisp_string
                                                      ( L"Cannot multiply: argument 1 is not a number" ),
                                                      c_type( arg1 ) ),
                                           frame_pointer );
@@ -460,11 +467,8 @@ struct cons_pointer lisp_multiply( struct
     struct cons_pointer result = make_integer( 1, NIL );
     struct cons_pointer tmp;
 
-    for ( int i = 0;
+    for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
-         i < args_in_frame
+          && !exceptionp( result ); i++ ) {
-           && !nilp( frame->arg[i] )
-           && !exceptionp( result );
-         i++ ) {
         debug_print( L"lisp_multiply: accumulator = ", DEBUG_ARITH );
         debug_print_object( result, DEBUG_ARITH );
         debug_print( L"; arg = ", DEBUG_ARITH );
@@ -538,7 +542,8 @@ struct cons_pointer negative( struct cons_pointer frame,
  * was not.
  */
 struct cons_pointer lisp_is_negative( struct stack_frame
-                              *frame, struct cons_pointer frame_pointer, struct
+                                      *frame,
+                                      struct cons_pointer frame_pointer, struct
                                       cons_pointer env ) {
     return is_negative( frame->arg[0] ) ? TRUE : NIL;
 }

src/arith/peano.h

@@ -24,7 +24,8 @@ struct cons_pointer negative( struct cons_pointer frame,
 
 bool is_negative( struct cons_pointer arg );
 
-struct cons_pointer absolute( struct cons_pointer frame_pointer, struct cons_pointer arg);
+struct cons_pointer absolute( struct cons_pointer frame_pointer,
+                              struct cons_pointer arg );
 
 long double to_long_double( struct cons_pointer arg );
 
@@ -37,7 +38,8 @@ lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer,
           struct cons_pointer env );
 
 struct cons_pointer lisp_is_negative( struct stack_frame
-                              *frame, struct cons_pointer frame_pointer, struct
+                                      *frame,
+                                      struct cons_pointer frame_pointer, struct
                                       cons_pointer env );
 
 struct cons_pointer

src/arith/ratio.c

@@ -55,10 +55,10 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
 
     if ( ratiop( arg ) ) {
         int64_t ddrv =
-            pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload.
+            pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
-            integer.value, drrv =
+            payload.integer.value, drrv =
-            pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload.
+            pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
-            integer.value, gcd = greatest_common_divisor( ddrv, drrv );
+            payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
 
         if ( gcd > 1 ) {
             if ( drrv / gcd == 1 ) {
@@ -199,10 +199,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
                                         struct cons_pointer arg1,
                                         struct cons_pointer arg2 ) {
     struct cons_pointer i = make_ratio( frame_pointer,
-                                        pointer2cell( arg2 ).payload.ratio.
+                                        pointer2cell( arg2 ).payload.
-                                        divisor,
+                                        ratio.divisor,
-                                        pointer2cell( arg2 ).payload.ratio.
+                                        pointer2cell( arg2 ).payload.
-                                        dividend ), result =
+                                        ratio.dividend ), result =
         multiply_ratio_ratio( frame_pointer, arg1, i );
 
     dec_ref( i );

src/debug.c

@@ -21,6 +21,7 @@
 #include "consspaceobject.h"
 #include "debug.h"
 #include "dump.h"
+#include "io.h"
 #include "print.h"
 
 /**
@@ -104,8 +105,10 @@ void debug_printf( int level, wchar_t *format, ... ) {
 void debug_print_object( struct cons_pointer pointer, int level ) {
 #ifdef DEBUG
     if ( level & verbosity ) {
+        URL_FILE *ustderr = file_to_url_file( stderr );
         fwide( stderr, 1 );
-        print( stderr, pointer );
+        print( ustderr, pointer );
+        free( ustderr );
     }
 #endif
 }
@@ -116,8 +119,10 @@ void debug_print_object( struct cons_pointer pointer, int level ) {
 void debug_dump_object( struct cons_pointer pointer, int level ) {
 #ifdef DEBUG
     if ( level & verbosity ) {
+        URL_FILE *ustderr = file_to_url_file( stderr );
         fwide( stderr, 1 );
-        dump_object( stderr, pointer );
+        dump_object( ustderr, pointer );
+        free( ustderr );
     }
 #endif
 }

src/init.c

@@ -9,21 +9,29 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#include <locale.h>
 #include <stdbool.h>
 #include <stdio.h>
 #include <stdlib.h>
 #include <unistd.h>
 #include <wchar.h>
 
+/* libcurl, used for io */
+#include <curl/curl.h>
+
 #include "version.h"
 #include "conspage.h"
 #include "consspaceobject.h"
 #include "debug.h"
 #include "intern.h"
+#include "io.h"
 #include "lispops.h"
+#include "map.h"
+#include "meta.h"
 #include "peano.h"
 #include "print.h"
 #include "repl.h"
+#include "psse_time.h"
 
 // extern char *optarg; /* defined in unistd.h */
 
@@ -38,11 +46,13 @@ void bind_function( wchar_t *name, struct cons_pointer ( *executable )
                      ( struct stack_frame *,
                        struct cons_pointer, struct cons_pointer ) ) {
     struct cons_pointer n = c_string_to_lisp_symbol( name );
-    inc_ref( n );
+    struct cons_pointer meta =
+        make_cons( make_cons( c_string_to_lisp_keyword( L"primitive" ), TRUE ),
+                   make_cons( make_cons( c_string_to_lisp_keyword( L"name" ),
+                                         n ),
+                              NIL ) );
 
-    deep_bind( n, make_function( NIL, executable ) );
+    deep_bind( n, make_function( meta, executable ) );
-
-    dec_ref( n );
 }
 
 /**
@@ -53,11 +63,13 @@ void bind_special( wchar_t *name, struct cons_pointer ( *executable )
                     ( struct stack_frame *,
                       struct cons_pointer, struct cons_pointer ) ) {
     struct cons_pointer n = c_string_to_lisp_symbol( name );
-    inc_ref( n );
+    struct cons_pointer meta =
+        make_cons( make_cons( c_string_to_lisp_keyword( L"primitive" ), TRUE ),
+                   make_cons( make_cons( c_string_to_lisp_keyword( L"name" ),
+                                         n ),
+                              NIL ) );
 
-    deep_bind( n, make_special( NIL, executable ) );
+    deep_bind( n, make_special( meta, executable ) );
-
-    dec_ref( n );
 }
 
 /**
@@ -81,11 +93,14 @@ int main( int argc, char *argv[] ) {
     bool dump_at_end = false;
     bool show_prompt = false;
 
-    while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) {
+    setlocale( LC_ALL, "" );
+    if ( io_init(  ) != 0 ) {
+        fputs( "Failed to initialise I/O subsystem\n", stderr );
+        exit( 1 );
+    }
+
+    while ( ( option = getopt( argc, argv, "pdv:" ) ) != -1 ) {
         switch ( option ) {
-            case 'c':
-                print_use_colours = true;
-                break;
             case 'd':
                 dump_at_end = true;
                 break;
@@ -123,22 +138,45 @@ int main( int argc, char *argv[] ) {
      * standard input, output, error and sink streams
      * attempt to set wide character acceptance on all streams
      */
-    FILE *sink = fopen( "/dev/null", "w" );
+    URL_FILE *sink = url_fopen( "/dev/null", "w" );
     fwide( stdin, 1 );
     fwide( stdout, 1 );
     fwide( stderr, 1 );
-    fwide( sink, 1 );
+    fwide( sink->handle.file, 1 );
-    bind_value( L"*in*", make_read_stream( stdin ) );
+    bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ),
-    bind_value( L"*out*", make_write_stream( stdout ) );
+                                           make_cons( make_cons
-    bind_value( L"*log*", make_write_stream( stderr ) );
+                                                      ( c_string_to_lisp_keyword
-    bind_value( L"*sink*", make_write_stream( sink ) );
+                                                        ( L"url" ),
-
+                                                        c_string_to_lisp_string
+                                                        ( L"system:standard input" ) ),
+                                                      NIL ) ) );
+    bind_value( L"*out*",
+                make_write_stream( file_to_url_file( stdout ),
+                                   make_cons( make_cons
+                                              ( c_string_to_lisp_keyword
+                                                ( L"url" ),
+                                                c_string_to_lisp_string
+                                                ( L"system:standard output]" ) ),
+                                              NIL ) ) );
+    bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ),
+                                             make_cons( make_cons
+                                                        ( c_string_to_lisp_keyword
+                                                          ( L"url" ),
+                                                          c_string_to_lisp_string
+                                                          ( L"system:standard log" ) ),
+                                                        NIL ) ) );
+    bind_value( L"*sink*", make_write_stream( sink,
+                                              make_cons( make_cons
+                                                         ( c_string_to_lisp_keyword
+                                                           ( L"url" ),
+                                                           c_string_to_lisp_string
+                                                           ( L"system:standard sink" ) ),
+                                                         NIL ) ) );
     /*
      * the default prompt
      */
     bind_value( L"*prompt*",
                 show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL );
-
     /*
      * primitive function operations
      */
@@ -148,6 +186,7 @@ int main( int argc, char *argv[] ) {
     bind_function( L"assoc", &lisp_assoc );
     bind_function( L"car", &lisp_car );
     bind_function( L"cdr", &lisp_cdr );
+    bind_function( L"close", &lisp_close );
     bind_function( L"cons", &lisp_cons );
     bind_function( L"divide", &lisp_divide );
     bind_function( L"eq", &lisp_eq );
@@ -155,50 +194,52 @@ int main( int argc, char *argv[] ) {
     bind_function( L"eval", &lisp_eval );
     bind_function( L"exception", &lisp_exception );
     bind_function( L"inspect", &lisp_inspect );
+    bind_function( L"make-map", &lisp_make_map);
+    bind_function( L"meta", &lisp_metadata );
+    bind_function( L"metadata", &lisp_metadata );
     bind_function( L"multiply", &lisp_multiply );
     bind_function( L"negative?", &lisp_is_negative );
-    bind_function( L"read", &lisp_read );
-    bind_function( L"repl", &lisp_repl );
     bind_function( L"oblist", &lisp_oblist );
+    bind_function( L"open", &lisp_open );
     bind_function( L"print", &lisp_print );
     bind_function( L"progn", &lisp_progn );
+    bind_function( L"read", &lisp_read );
+    bind_function( L"read-char", &lisp_read_char );
+    bind_function( L"repl", &lisp_repl );
     bind_function( L"reverse", &lisp_reverse );
     bind_function( L"set", &lisp_set );
+    bind_function( L"slurp", &lisp_slurp );
     bind_function( L"source", &lisp_source );
     bind_function( L"subtract", &lisp_subtract );
     bind_function( L"throw", &lisp_exception );
+    bind_function( L"time", &lisp_time );
     bind_function( L"type", &lisp_type );
-
     bind_function( L"+", &lisp_add );
     bind_function( L"*", &lisp_multiply );
     bind_function( L"-", &lisp_subtract );
     bind_function( L"/", &lisp_divide );
     bind_function( L"=", &lisp_equal );
-
     /*
      * primitive special forms
      */
     bind_special( L"cond", &lisp_cond );
     bind_special( L"lambda", &lisp_lambda );
-    // bind_special( L"λ", &lisp_lambda );
+    bind_special( L"\u03bb", &lisp_lambda );  // λ
     bind_special( L"nlambda", &lisp_nlambda );
-    // bind_special( L"nλ", &lisp_nlambda );
+    bind_special( L"n\u03bb", &lisp_nlambda );
     bind_special( L"progn", &lisp_progn );
     bind_special( L"quote", &lisp_quote );
     bind_special( L"set!", &lisp_set_shriek );
-
     debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
     debug_dump_object( oblist, DEBUG_BOOTSTRAP );
-
     repl( show_prompt );
-
     debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
     dec_ref( oblist );
     debug_dump_object( oblist, DEBUG_BOOTSTRAP );
-
     if ( dump_at_end ) {
-        dump_pages( stdout );
+        dump_pages( file_to_url_file( stdout ) );
     }
 
+    curl_global_cleanup(  );
     return ( 0 );
 }

src/io/fopen.c

@@ -0,0 +1,526 @@
+/*
+ * fopen.c
+ *
+ * adapted from https://curl.haxx.se/libcurl/c/fopen.html.
+ *
+ * Modifications to read/write wide character streams by
+ * Simon Brooke.
+ *
+ * NOTE THAT: for my purposes, I'm only interested in wide characters,
+ * and I always read them one character at a time.
+ *
+ * Copyright (c) 2003, 2017 Simtec Electronics
+ * Some portions (c) 2019 Simon Brooke <simon@journeyman.cc>
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ *    notice, this list of conditions and the following disclaimer in the
+ *    documentation and/or other materials provided with the distribution.
+ * 3. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+ * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ * This example requires libcurl 7.9.7 or later.
+ */
+
+#include <stdio.h>
+#include <string.h>
+#ifndef WIN32
+#include <sys/time.h>
+#endif
+#include <stdlib.h>
+#include <errno.h>
+
+#include <curl/curl.h>
+
+#include "fopen.h"
+#ifdef FOPEN_STANDALONE
+CURLSH *io_share;
+#else
+#include "consspaceobject.h"
+#include "io.h"
+#include "utils.h"
+#endif
+
+
+/* exported functions */
+URL_FILE *url_fopen( const char *url, const char *operation );
+int url_fclose( URL_FILE * file );
+int url_feof( URL_FILE * file );
+size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file );
+char *url_fgets( char *ptr, size_t size, URL_FILE * file );
+void url_rewind( URL_FILE * file );
+
+/* we use a global one for convenience */
+static CURLM *multi_handle;
+
+/* curl calls this routine to get more data */
+static size_t write_callback( char *buffer,
+                              size_t size, size_t nitems, void *userp ) {
+    char *newbuff;
+    size_t rembuff;
+
+    URL_FILE *url = ( URL_FILE * ) userp;
+    size *= nitems;
+
+    rembuff = url->buffer_len - url->buffer_pos;  /* remaining space in buffer */
+
+    if ( size > rembuff ) {
+        /* not enough space in buffer */
+        newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) );
+        if ( newbuff == NULL ) {
+            fprintf( stderr, "callback buffer grow failed\n" );
+            size = rembuff;
+        } else {
+            /* realloc succeeded increase buffer size */
+            url->buffer_len += size - rembuff;
+            url->buffer = newbuff;
+        }
+    }
+
+    memcpy( &url->buffer[url->buffer_pos], buffer, size );
+    url->buffer_pos += size;
+
+    return size;
+}
+
+/* use to attempt to fill the read buffer up to requested number of bytes */
+static int fill_buffer( URL_FILE * file, size_t want ) {
+    fd_set fdread;
+    fd_set fdwrite;
+    fd_set fdexcep;
+    struct timeval timeout;
+    int rc;
+    CURLMcode mc;               /* curl_multi_fdset() return code */
+
+    /* only attempt to fill buffer if transactions still running and buffer
+     * doesn't exceed required size already
+     */
+    if ( ( !file->still_running ) || ( file->buffer_pos > want ) )
+        return 0;
+
+    /* attempt to fill buffer */
+    do {
+        int maxfd = -1;
+        long curl_timeo = -1;
+
+        FD_ZERO( &fdread );
+        FD_ZERO( &fdwrite );
+        FD_ZERO( &fdexcep );
+
+        /* set a suitable timeout to fail on */
+        timeout.tv_sec = 60;    /* 1 minute */
+        timeout.tv_usec = 0;
+
+        curl_multi_timeout( multi_handle, &curl_timeo );
+        if ( curl_timeo >= 0 ) {
+            timeout.tv_sec = curl_timeo / 1000;
+            if ( timeout.tv_sec > 1 )
+                timeout.tv_sec = 1;
+            else
+                timeout.tv_usec = ( curl_timeo % 1000 ) * 1000;
+        }
+
+        /* get file descriptors from the transfers */
+        mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep,
+                               &maxfd );
+
+        if ( mc != CURLM_OK ) {
+            fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc );
+            break;
+        }
+
+        /* On success the value of maxfd is guaranteed to be >= -1. We call
+           select(maxfd + 1, ...); specially in case of (maxfd == -1) there are
+           no fds ready yet so we call select(0, ...) --or Sleep() on Windows--
+           to sleep 100ms, which is the minimum suggested value in the
+           curl_multi_fdset() doc. */
+
+        if ( maxfd == -1 ) {
+#ifdef _WIN32
+            Sleep( 100 );
+            rc = 0;
+#else
+            /* Portable sleep for platforms other than Windows. */
+            struct timeval wait = { 0, 100 * 1000 };  /* 100ms */
+            rc = select( 0, NULL, NULL, NULL, &wait );
+#endif
+        } else {
+            /* Note that on some platforms 'timeout' may be modified by select().
+               If you need access to the original value save a copy beforehand. */
+            rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout );
+        }
+
+        switch ( rc ) {
+            case -1:
+                /* select error */
+                break;
+
+            case 0:
+            default:
+                /* timeout or readable/writable sockets */
+                curl_multi_perform( multi_handle, &file->still_running );
+                break;
+        }
+    } while ( file->still_running && ( file->buffer_pos < want ) );
+    return 1;
+}
+
+/* use to remove want bytes from the front of a files buffer */
+static int use_buffer( URL_FILE * file, size_t want ) {
+    /* sort out buffer */
+    if ( ( file->buffer_pos - want ) <= 0 ) {
+        /* ditch buffer - write will recreate */
+        free( file->buffer );
+        file->buffer = NULL;
+        file->buffer_pos = 0;
+        file->buffer_len = 0;
+    } else {
+        /* move rest down make it available for later */
+        memmove( file->buffer,
+                 &file->buffer[want], ( file->buffer_pos - want ) );
+
+        file->buffer_pos -= want;
+    }
+    return 0;
+}
+
+URL_FILE *url_fopen( const char *url, const char *operation ) {
+    /* this code could check for URLs or types in the 'url' and
+       basically use the real fopen() for standard files */
+
+    URL_FILE *file;
+    ( void ) operation;
+
+    file = calloc( 1, sizeof( URL_FILE ) );
+    if ( !file )
+        return NULL;
+
+    file->handle.file = fopen( url, operation );
+    if ( file->handle.file ) {
+        file->type = CFTYPE_FILE; /* marked as file */
+    } else if ( index_of(':', url ) > -1 ) {
+        file->type = CFTYPE_CURL; /* marked as URL */
+        file->handle.curl = curl_easy_init(  );
+
+        curl_easy_setopt( file->handle.curl, CURLOPT_URL, url );
+        curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file );
+        curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L );
+        curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION,
+                          write_callback );
+        /* use the share object */
+        curl_easy_setopt( file->handle.curl, CURLOPT_SHARE, io_share );
+
+
+        if ( !multi_handle )
+            multi_handle = curl_multi_init(  );
+
+        curl_multi_add_handle( multi_handle, file->handle.curl );
+
+        /* lets start the fetch */
+        curl_multi_perform( multi_handle, &file->still_running );
+
+        if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) {
+            /* if still_running is 0 now, we should return NULL */
+
+            /* make sure the easy handle is not in the multi handle anymore */
+            curl_multi_remove_handle( multi_handle, file->handle.curl );
+
+            /* cleanup */
+            curl_easy_cleanup( file->handle.curl );
+
+            free( file );
+
+            file = NULL;
+        }
+    } else {
+        file->type = CFTYPE_NONE;
+        /* not a file, and doesn't look like a URL. */
+    }
+
+    return file;
+}
+
+int url_fclose( URL_FILE * file ) {
+    int ret = 0;                /* default is good return */
+
+    switch ( file->type ) {
+        case CFTYPE_FILE:
+            ret = fclose( file->handle.file );  /* passthrough */
+            break;
+
+        case CFTYPE_CURL:
+            /* make sure the easy handle is not in the multi handle anymore */
+            curl_multi_remove_handle( multi_handle, file->handle.curl );
+
+            /* cleanup */
+            curl_easy_cleanup( file->handle.curl );
+            break;
+
+        default:               /* unknown or supported type - oh dear */
+            ret = EOF;
+            errno = EBADF;
+            break;
+    }
+
+    free( file->buffer );       /* free any allocated buffer space */
+    free( file );
+
+    return ret;
+}
+
+int url_feof( URL_FILE * file ) {
+    int ret = 0;
+
+    switch ( file->type ) {
+        case CFTYPE_FILE:
+            ret = feof( file->handle.file );
+            break;
+
+        case CFTYPE_CURL:
+            if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) )
+                ret = 1;
+            break;
+
+        default:               /* unknown or supported type - oh dear */
+            ret = -1;
+            errno = EBADF;
+            break;
+    }
+    return ret;
+}
+
+size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) {
+    size_t want;
+
+    switch ( file->type ) {
+        case CFTYPE_FILE:
+            want = fread( ptr, size, nmemb, file->handle.file );
+            break;
+
+        case CFTYPE_CURL:
+            want = nmemb * size;
+
+            fill_buffer( file, want );
+
+            /* check if there's data in the buffer - if not fill_buffer()
+             * either errored or EOF */
+            if ( !file->buffer_pos )
+                return 0;
+
+            /* ensure only available data is considered */
+            if ( file->buffer_pos < want )
+                want = file->buffer_pos;
+
+            /* xfer data to caller */
+            memcpy( ptr, file->buffer, want );
+
+            use_buffer( file, want );
+
+            want = want / size; /* number of items */
+            break;
+
+        default:               /* unknown or supported type - oh dear */
+            want = 0;
+            errno = EBADF;
+            break;
+
+    }
+    return want;
+}
+
+char *url_fgets( char *ptr, size_t size, URL_FILE * file ) {
+    size_t want = size - 1;     /* always need to leave room for zero termination */
+    size_t loop;
+
+    switch ( file->type ) {
+        case CFTYPE_FILE:
+            ptr = fgets( ptr, ( int ) size, file->handle.file );
+            break;
+
+        case CFTYPE_CURL:
+            fill_buffer( file, want );
+
+            /* check if there's data in the buffer - if not fill either errored or
+             * EOF */
+            if ( !file->buffer_pos )
+                return NULL;
+
+            /* ensure only available data is considered */
+            if ( file->buffer_pos < want )
+                want = file->buffer_pos;
+
+            /*buffer contains data */
+            /* look for newline or eof */
+            for ( loop = 0; loop < want; loop++ ) {
+                if ( file->buffer[loop] == '\n' ) {
+                    want = loop + 1;  /* include newline */
+                    break;
+                }
+            }
+
+            /* xfer data to caller */
+            memcpy( ptr, file->buffer, want );
+            ptr[want] = 0;      /* always null terminate */
+
+            use_buffer( file, want );
+
+            break;
+
+        default:               /* unknown or supported type - oh dear */
+            ptr = NULL;
+            errno = EBADF;
+            break;
+    }
+
+    return ptr;                 /*success */
+}
+
+void url_rewind( URL_FILE * file ) {
+    switch ( file->type ) {
+        case CFTYPE_FILE:
+            rewind( file->handle.file );  /* passthrough */
+            break;
+
+        case CFTYPE_CURL:
+            /* halt transaction */
+            curl_multi_remove_handle( multi_handle, file->handle.curl );
+
+            /* restart */
+            curl_multi_add_handle( multi_handle, file->handle.curl );
+
+            /* ditch buffer - write will recreate - resets stream pos */
+            free( file->buffer );
+            file->buffer = NULL;
+            file->buffer_pos = 0;
+            file->buffer_len = 0;
+
+            break;
+
+        default:               /* unknown or supported type - oh dear */
+            break;
+    }
+}
+
+#ifdef FOPEN_STANDALONE
+#define FGETSFILE "fgets.test"
+#define FREADFILE "fread.test"
+#define REWINDFILE "rewind.test"
+
+/* Small main program to retrieve from a url using fgets and fread saving the
+ * output to two test files (note the fgets method will corrupt binary files if
+ * they contain 0 chars */
+int main( int argc, char *argv[] ) {
+    URL_FILE *handle;
+    FILE *outf;
+
+    size_t nread;
+    char buffer[256];
+    const char *url;
+
+    CURL *curl;
+    CURLcode res;
+
+    curl_global_init( CURL_GLOBAL_DEFAULT );
+
+    curl = curl_easy_init(  );
+
+
+    if ( argc < 2 )
+        url = "http://192.168.7.3/testfile";  /* default to testurl */
+    else
+        url = argv[1];          /* use passed url */
+
+    /* copy from url line by line with fgets */
+    outf = fopen( FGETSFILE, "wb+" );
+    if ( !outf ) {
+        perror( "couldn't open fgets output file\n" );
+        return 1;
+    }
+
+    handle = url_fopen( url, "r" );
+    if ( !handle ) {
+        printf( "couldn't url_fopen() %s\n", url );
+        fclose( outf );
+        return 2;
+    }
+
+    while ( !url_feof( handle ) ) {
+        url_fgets( buffer, sizeof( buffer ), handle );
+        fwrite( buffer, 1, strlen( buffer ), outf );
+    }
+
+    url_fclose( handle );
+
+    fclose( outf );
+
+
+    /* Copy from url with fread */
+    outf = fopen( FREADFILE, "wb+" );
+    if ( !outf ) {
+        perror( "couldn't open fread output file\n" );
+        return 1;
+    }
+
+    handle = url_fopen( "testfile", "r" );
+    if ( !handle ) {
+        printf( "couldn't url_fopen() testfile\n" );
+        fclose( outf );
+        return 2;
+    }
+
+    do {
+        nread = url_fread( buffer, 1, sizeof( buffer ), handle );
+        fwrite( buffer, 1, nread, outf );
+    } while ( nread );
+
+    url_fclose( handle );
+
+    fclose( outf );
+
+
+    /* Test rewind */
+    outf = fopen( REWINDFILE, "wb+" );
+    if ( !outf ) {
+        perror( "couldn't open fread output file\n" );
+        return 1;
+    }
+
+    handle = url_fopen( "testfile", "r" );
+    if ( !handle ) {
+        printf( "couldn't url_fopen() testfile\n" );
+        fclose( outf );
+        return 2;
+    }
+
+    nread = url_fread( buffer, 1, sizeof( buffer ), handle );
+    fwrite( buffer, 1, nread, outf );
+    url_rewind( handle );
+
+    buffer[0] = '\n';
+    fwrite( buffer, 1, 1, outf );
+
+    nread = url_fread( buffer, 1, sizeof( buffer ), handle );
+    fwrite( buffer, 1, nread, outf );
+
+    url_fclose( handle );
+
+    fclose( outf );
+
+    return 0;                   /* all done */
+}
+#endif

src/io/fopen.h

@@ -0,0 +1,83 @@
+/*
+ * fopen.h
+ *
+ * adapted from https://curl.haxx.se/libcurl/c/fopen.html.
+ *
+ *
+ * Modifications to read/write wide character streams by
+ * Simon Brooke.
+ *
+ * NOTE THAT: for my purposes, I'm only interested in wide characters,
+ * and I always read them one character at a time.
+ *
+ * Copyright (c) 2003, 2017 Simtec Electronics
+ * Some portions (c) 2019 Simon Brooke <simon@journeyman.cc>
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ *    notice, this list of conditions and the following disclaimer in the
+ *    documentation and/or other materials provided with the distribution.
+ * 3. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+ * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ * This example requires libcurl 7.9.7 or later.
+ */
+
+#ifndef __fopen_h
+#define __fopen_h
+#include <curl/curl.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#define url_fwprintf(f, ...) ((f->type = CFTYPE_FILE) ? fwprintf( f->handle.file, __VA_ARGS__) : -1)
+#define url_fputws(ws, f) ((f->type = CFTYPE_FILE) ?  fputws(ws, f->handle.file) : 0)
+#define url_fputwc(wc, f) ((f->type = CFTYPE_FILE) ?  fputwc(wc, f->handle.file) : 0)
+
+enum fcurl_type_e {
+    CFTYPE_NONE = 0,
+    CFTYPE_FILE = 1,
+    CFTYPE_CURL = 2
+};
+
+struct fcurl_data {
+    enum fcurl_type_e type;     /* type of handle */
+    union {
+        CURL *curl;
+        FILE *file;
+    } handle;                   /* handle */
+
+    char *buffer;               /* buffer to store cached data */
+    size_t buffer_len;          /* currently allocated buffer's length */
+    size_t buffer_pos;          /* cursor into in buffer */
+    int still_running;          /* Is background url fetch still in progress */
+};
+
+typedef struct fcurl_data URL_FILE;
+
+/* exported functions */
+URL_FILE *url_fopen( const char *url, const char *operation );
+int url_fclose( URL_FILE * file );
+int url_feof( URL_FILE * file );
+size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file );
+char *url_fgets( char *ptr, size_t size, URL_FILE * file );
+void url_rewind( URL_FILE * file );
+
+#endif

src/io/io.c

@@ -0,0 +1,530 @@
+/*
+ * io.c
+ *
+ * Communication between PSSE and the outside world, via libcurl. NOTE
+ * that this file destructively changes metadata on URL connections,
+ * because the metadata is not available until the stream has been read
+ * from. It would be better to find a workaround!
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <grp.h>
+#include <langinfo.h>
+#include <pwd.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <unistd.h>
+#include <uuid/uuid.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#include <curl/curl.h>
+
+#include "conspage.h"
+#include "consspaceobject.h"
+#include "debug.h"
+#include "fopen.h"
+#include "integer.h"
+#include "intern.h"
+#include "lispops.h"
+#include "utils.h"
+
+/**
+ * The sharing hub for all connections. TODO: Ultimately this probably doesn't
+ * work for a multi-user environment and we will need one sharing hub for each
+ * user, or else we will need to not share at least cookies and ssl sessions.
+ */
+CURLSH *io_share;
+
+/**
+ * Allow a one-character unget facility. This may not be enough - we may need
+ * to allocate a buffer.
+ */
+wint_t ungotten = 0;
+
+/**
+ * Initialise the I/O subsystem.
+ *
+ * @return 0 on success; any other value means failure.
+ */
+int io_init(  ) {
+    CURL *curl;
+    CURLcode res;
+    int result = curl_global_init( CURL_GLOBAL_SSL );
+
+    io_share = curl_share_init(  );
+
+    if ( result == 0 ) {
+        curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT );
+        curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE );
+        curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS );
+        curl_share_setopt( io_share, CURLSHOPT_SHARE,
+                           CURL_LOCK_DATA_SSL_SESSION );
+        curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL );
+    }
+
+    return result;
+}
+
+/**
+ * Convert this lisp string-like-thing (also works for symbols, and, later
+ * keywords) into a UTF-8 string. NOTE that the returned value has been
+ * malloced and must be freed. TODO: candidate to moving into a utilities
+ * file.
+ *
+ * @param s the lisp string or symbol;
+ * @return the c string.
+ */
+char *lisp_string_to_c_string( struct cons_pointer s ) {
+    char *result = NULL;
+
+    if ( stringp( s ) || symbolp( s ) ) {
+        int len = 0;
+
+        for ( struct cons_pointer c = s; !nilp( c );
+              c = pointer2cell( c ).payload.string.cdr ) {
+            len++;
+        }
+
+        wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) );
+        /* worst case, one wide char = four utf bytes */
+        result = calloc( ( len * 4 ) + 1, sizeof( char ) );
+
+        int i = 0;
+        for ( struct cons_pointer c = s; !nilp( c );
+              c = pointer2cell( c ).payload.string.cdr ) {
+            buffer[i++] = pointer2cell( c ).payload.string.character;
+        }
+
+        wcstombs( result, buffer, len );
+        free( buffer );
+    }
+
+    debug_print( L"lisp_string_to_c_string( ", DEBUG_IO );
+    debug_print_object( s, DEBUG_IO );
+    debug_printf( DEBUG_IO, L") => '%s'\n", result );
+
+    return result;
+}
+
+
+/**
+ * given this file handle f, return a new url_file handle wrapping it.
+ *
+ * @param f the file to be wrapped;
+ * @return the new handle, or null if no such handle could be allocated.
+ */
+URL_FILE *file_to_url_file( FILE * f ) {
+    URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) );
+
+    if ( result != NULL ) {
+        result->type = CFTYPE_FILE, result->handle.file = f;
+    }
+
+    return result;
+}
+
+
+/**
+ * get one wide character from the buffer.
+ *
+ * @param file the stream to read from;
+ * @return the next wide character on the stream, or zero if no more.
+ */
+wint_t url_fgetwc( URL_FILE * input ) {
+    wint_t result = -1;
+
+    if ( ungotten != 0 ) {
+        /* TODO: not thread safe */
+        result = ungotten;
+        ungotten = 0;
+    } else {
+        switch ( input->type ) {
+            case CFTYPE_FILE:
+                fwide( input->handle.file, 1 ); /* wide characters */
+                result = fgetwc( input->handle.file );  /* passthrough */
+                break;
+
+            case CFTYPE_CURL:{
+                    char *cbuff =
+                        calloc( sizeof( wchar_t ) + 2, sizeof( char ) );
+                    wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) );
+
+                    size_t count = 0;
+
+                    debug_print( L"url_fgetwc: about to call url_fgets\n",
+                                 DEBUG_IO );
+                    url_fgets( cbuff, 2, input );
+                    debug_print( L"url_fgetwc: back from url_fgets\n",
+                                 DEBUG_IO );
+                    int c = ( int ) cbuff[0];
+                    debug_printf( DEBUG_IO,
+                                  L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n",
+                                  cbuff, c, c & 0xf7 );
+                    /* The value of each individual byte indicates its UTF-8 function, as follows:
+                     *
+                     * 00 to 7F hex (0 to 127): first and only byte of a sequence.
+                     * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence.
+                     * C2 to DF hex (194 to 223): first byte of a two-byte sequence.
+                     * E0 to EF hex (224 to 239): first byte of a three-byte sequence.
+                     * F0 to FF hex (240 to 255): first byte of a four-byte sequence.
+                     */
+                    if ( c <= 0x07 ) {
+                        count = 1;
+                    } else if ( c >= '0xc2' && c <= '0xdf' ) {
+                        count = 2;
+                    } else if ( c >= '0xe0' && c <= '0xef' ) {
+                        count = 3;
+                    } else if ( c >= '0xf0' && c <= '0xff' ) {
+                        count = 4;
+                    }
+
+                    if ( count > 1 ) {
+                        url_fgets( ( char * ) &cbuff[1], count, input );
+                    }
+                    mbstowcs( wbuff, cbuff, 2 );  //(char *)(&input->buffer[input->buffer_pos]), 1 );
+                    result = wbuff[0];
+
+                    free( wbuff );
+                    free( cbuff );
+                }
+                break;
+            case CFTYPE_NONE:
+                break;
+        }
+    }
+
+    debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result,
+                  result );
+    return result;
+}
+
+wint_t url_ungetwc( wint_t wc, URL_FILE * input ) {
+    wint_t result = -1;
+
+    switch ( input->type ) {
+        case CFTYPE_FILE:
+            fwide( input->handle.file, 1 ); /* wide characters */
+            result = ungetwc( wc, input->handle.file ); /* passthrough */
+            break;
+
+        case CFTYPE_CURL:{
+                ungotten = wc;
+                break;
+        case CFTYPE_NONE:
+                break;
+            }
+    }
+
+    return result;
+}
+
+
+/**
+ * Function, sort-of: close the file indicated by my first arg, and return
+ * nil. If the first arg is not a stream, does nothing. All other args are
+ * ignored.
+ *
+ * * (close stream)
+ *
+ * @param frame my stack_frame.
+ * @param frame_pointer a pointer to my stack_frame.
+ * @param env my environment.
+ * @return T if the stream was successfully closed, else NIL.
+ */
+struct cons_pointer
+lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+
+    if ( readp( frame->arg[0] ) || writep( frame->arg[0] ) ) {
+        if ( url_fclose( pointer2cell( frame->arg[0] ).payload.stream.stream )
+             == 0 ) {
+            result = TRUE;
+        }
+    }
+
+    return result;
+}
+
+struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key,
+                                      long int value ) {
+    return
+        make_cons( make_cons
+                   ( c_string_to_lisp_keyword( key ),
+                     make_integer( value, NIL ) ), meta );
+}
+
+struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key,
+                                     char *value ) {
+    value = trim( value);
+    wchar_t buffer[strlen( value ) + 1];
+    mbstowcs( buffer, value, strlen( value ) + 1 );
+
+    return make_cons( make_cons( c_string_to_lisp_keyword( key ),
+                                 c_string_to_lisp_string( buffer ) ), meta );
+}
+
+struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key,
+                                   time_t * value ) {
+    /* I don't yet have a concept of a date-time object, which is a
+     * bit of an oversight! */
+    char datestring[256];
+
+    strftime( datestring,
+             sizeof( datestring ),
+             nl_langinfo( D_T_FMT ),
+             localtime( value ) );
+
+    return add_meta_string( meta, key, datestring );
+}
+
+/**
+ * Callback to assemble metadata for a URL stream. This is naughty because
+ * it modifies data, but it's really the only way to create metadata.
+ */
+static size_t write_meta_callback( char *string, size_t size, size_t nmemb,
+                                   struct cons_pointer stream ) {
+    struct cons_space_object *cell = &pointer2cell( stream );
+
+    /* make a copy of the string that we can destructively change */
+    char *s = calloc( strlen( string ), sizeof( char ) );
+
+    strcpy( s, string );
+
+    if ( strncmp( &cell->tag.bytes[0], READTAG, 4 ) ||
+         strncmp( &cell->tag.bytes[0], WRITETAG, 4 ) ) {
+        int offset = index_of( ':', s );
+
+        if ( offset != -1 ) {
+            s[offset] = ( char ) 0;
+            char *name = trim( s );
+            char *value = trim( &s[++offset] );
+            wchar_t wname[strlen( name )];
+
+            mbstowcs( wname, name, strlen( name ) + 1 );
+
+            cell->payload.stream.meta =
+                add_meta_string( cell->payload.stream.meta, wname, value );
+
+            debug_printf( DEBUG_IO,
+                          L"write_meta_callback: added header '%s': value '%s'\n",
+                          name, value );
+        } else if ( strncmp( "HTTP", s, 4 ) == 0 ) {
+            int offset = index_of( ' ', s );
+            char *value = trim( &s[offset] );
+
+            cell->payload.stream.meta =
+                add_meta_integer( add_meta_string
+                                  ( cell->payload.stream.meta, L"status",
+                                    value ), L"status-code", strtol( value,
+                                                                     NULL,
+                                                                     10 ) );
+
+            debug_printf( DEBUG_IO,
+                          L"write_meta_callback: added header 'status': value '%s'\n",
+                          value );
+        } else {
+            debug_printf( DEBUG_IO,
+                          L"write_meta_callback: header passed with no colon: '%s'\n",
+                          s );
+        }
+    } else {
+        debug_print
+            ( L"Pointer passed to write_meta_callback did not point to a stream: ",
+              DEBUG_IO );
+        debug_dump_object( stream, DEBUG_IO );
+    }
+
+    free( s );
+    return strlen( string );
+}
+
+void collect_meta( struct cons_pointer stream, char *url ) {
+    struct cons_space_object *cell = &pointer2cell( stream );
+    URL_FILE *s = pointer2cell( stream ).payload.stream.stream;
+    struct cons_pointer meta =
+        add_meta_string( cell->payload.stream.meta, L"url", url );
+    struct stat statbuf;
+    int result = stat( url, &statbuf );
+    struct passwd *pwd;
+    struct group *grp;
+
+    switch ( s->type ) {
+        case CFTYPE_NONE:
+            break;
+        case CFTYPE_FILE:
+            if ( result == 0 ) {
+                if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) {
+                    meta = add_meta_string( meta, L"owner", pwd->pw_name );
+                } else {
+                    meta = add_meta_integer( meta, L"owner", statbuf.st_uid );
+                }
+
+                if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) {
+                    meta = add_meta_string( meta, L"group", grp->gr_name );
+                } else {
+                    meta = add_meta_integer( meta, L"group", statbuf.st_gid );
+                }
+
+                meta =
+                    add_meta_integer( meta, L"size",
+                                      ( intmax_t ) statbuf.st_size );
+
+                meta = add_meta_time( meta, L"modified", &statbuf.st_mtime );
+            }
+            break;
+        case CFTYPE_CURL:
+            curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L );
+            curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION,
+                              write_meta_callback );
+            curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream );
+            break;
+    }
+
+    /* this is destructive change before the cell is released into the
+                   * wild, and consequently permissible, just. */
+    cell->payload.stream.meta = meta;
+}
+
+
+/**
+ * Function: return a stream open on the URL indicated by the first argument;
+ * if a second argument is present and is non-nil, open it for reading. At
+ * present, further arguments are ignored and there is no mechanism to open
+ * to append, or error if the URL is faulty or indicates an unavailable
+ * resource.
+ *
+ * * (read-char stream)
+ *
+ * @param frame my stack_frame.
+ * @param frame_pointer a pointer to my stack_frame.
+ * @param env my environment.
+ * @return a string of one character, namely the next available character
+ * on my stream, if any, else NIL.
+ */
+struct cons_pointer
+lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+
+    if ( stringp( frame->arg[0] ) ) {
+        char *url = lisp_string_to_c_string( frame->arg[0] );
+
+        if ( nilp( frame->arg[1] ) ) {
+            URL_FILE *stream = url_fopen( url, "r" );
+
+            debug_printf( DEBUG_IO,
+                         L"lisp_open: stream @ %d, stream type = %d, stream handle = %d\n",
+                         (int) &stream, (int)stream->type, (int)stream->handle.file);
+
+            switch (stream->type) {
+                case CFTYPE_NONE:
+                    return make_exception(
+                        c_string_to_lisp_string( L"Could not open stream"),
+                        frame_pointer);
+                    break;
+                case CFTYPE_FILE:
+                    if (stream->handle.file == NULL) {
+                      return make_exception(
+                          c_string_to_lisp_string( L"Could not open file"),
+                          frame_pointer);
+                    }
+                    break;
+                case CFTYPE_CURL:
+                    /* can't tell whether a URL is bad without reading it */
+                    break;
+            }
+
+            result = make_read_stream( stream, NIL );
+        } else {
+            // TODO: anything more complex is a problem for another day.
+            URL_FILE *stream = url_fopen( url, "w" );
+            result = make_write_stream( stream, NIL );
+        }
+
+        if ( pointer2cell( result ).payload.stream.stream == NULL ) {
+            result = NIL;
+        } else {
+            collect_meta( result, url );
+        }
+
+        free( url );
+    }
+
+    return result;
+}
+
+/**
+ * Function: return the next character from the stream indicated by arg 0;
+ * further arguments are ignored.
+ *
+ * * (read-char stream)
+ *
+ * @param frame my stack_frame.
+ * @param frame_pointer a pointer to my stack_frame.
+ * @param env my environment.
+ * @return a string of one character, namely the next available character
+ * on my stream, if any, else NIL.
+ */
+struct cons_pointer
+lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
+                struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+
+    if ( readp( frame->arg[0] ) ) {
+        result =
+            make_string( url_fgetwc
+                         ( pointer2cell( frame->arg[0] ).payload.
+                           stream.stream ), NIL );
+    }
+
+    return result;
+}
+
+/**
+ * Function: return a string representing all characters from the stream
+ * indicated by arg 0; further arguments are ignored.
+ *
+ * * (slurp stream)
+ *
+ * @param frame my stack_frame.
+ * @param frame_pointer a pointer to my stack_frame.
+ * @param env my environment.
+ * @return a string of one character, namely the next available character
+ * on my stream, if any, else NIL.
+ */
+struct cons_pointer
+lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env ) {
+    struct cons_pointer result = NIL;
+
+    if ( readp( frame->arg[0] ) ) {
+        URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream;
+        struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL );
+        result = cursor;
+
+        for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0;
+              c = url_fgetwc( stream ) ) {
+            debug_print( L"slurp: cursor is: ", DEBUG_IO );
+            debug_dump_object( cursor, DEBUG_IO );
+            debug_print( L"; result is: ", DEBUG_IO );
+            debug_dump_object( result, DEBUG_IO );
+            debug_println( DEBUG_IO );
+
+            struct cons_space_object *cell = &pointer2cell( cursor );
+            cursor = make_string( ( wchar_t ) c, NIL );
+            cell->payload.string.cdr = cursor;
+        }
+    }
+
+    return result;
+}

src/io/io.h

@@ -0,0 +1,38 @@
+
+/*
+ * io.h
+ *
+ * Communication between PSSE and the outside world, via libcurl.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#ifndef __psse_io_h
+#define __psse_io_h
+#include <curl/curl.h>
+#include "consspaceobject.h"
+
+extern CURLSH *io_share;
+
+int io_init(  );
+
+URL_FILE *file_to_url_file( FILE * f );
+wint_t url_fgetwc( URL_FILE * input );
+wint_t url_ungetwc( wint_t wc, URL_FILE * input );
+
+struct cons_pointer
+lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env );
+struct cons_pointer
+lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env );
+struct cons_pointer
+lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
+                struct cons_pointer env );
+struct cons_pointer
+lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env );
+
+
+#endif

src/io/print.c

@@ -20,27 +20,25 @@
 #include "conspage.h"
 #include "consspaceobject.h"
 #include "integer.h"
+#include "intern.h"
+#include "map.h"
 #include "stack.h"
 #include "print.h"
-
+#include "psse_time.h"
-/**
+#include "vectorspace.h"
- * Whether or not we colorise output.
- * \todo this should be a Lisp symbol binding, not a C variable.
- */
-int print_use_colours = 0;
 
 /**
  * print all the characters in the symbol or string indicated by `pointer`
  * onto this `output`; if `pointer` does not indicate a string or symbol,
  * don't print anything but just return.
  */
-void print_string_contents( FILE * output, struct cons_pointer pointer ) {
+void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) {
-    while ( stringp( pointer ) || symbolp( pointer ) ) {
+    while ( stringp( pointer ) || symbolp( pointer ) || keywordp( pointer ) ) {
         struct cons_space_object *cell = &pointer2cell( pointer );
         wchar_t c = cell->payload.string.character;
 
         if ( c != '\0' ) {
-            fputwc( c, output );
+            url_fputwc( c, output );
         }
         pointer = cell->payload.string.cdr;
     }
@@ -51,10 +49,10 @@ void print_string_contents( FILE * output, struct cons_pointer pointer ) {
  * the stream at this `output`, prepending and appending double quote
  * characters.
  */
-void print_string( FILE * output, struct cons_pointer pointer ) {
+void print_string( URL_FILE * output, struct cons_pointer pointer ) {
-    fputwc( btowc( '"' ), output );
+    url_fputwc( btowc( '"' ), output );
     print_string_contents( output, pointer );
-    fputwc( btowc( '"' ), output );
+    url_fputwc( btowc( '"' ), output );
 }
 
 /**
@@ -63,14 +61,14 @@ void print_string( FILE * output, struct cons_pointer pointer ) {
  * a space character.
  */
 void
-print_list_contents( FILE * output, struct cons_pointer pointer,
+print_list_contents( URL_FILE * output, struct cons_pointer pointer,
                      bool initial_space ) {
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     switch ( cell->tag.value ) {
         case CONSTV:
             if ( initial_space ) {
-                fputwc( btowc( ' ' ), output );
+                url_fputwc( btowc( ' ' ), output );
             }
             print( output, cell->payload.cons.car );
 
@@ -79,32 +77,80 @@ print_list_contents( FILE * output, struct cons_pointer pointer,
         case NILTV:
             break;
         default:
-            fwprintf( output, L" . " );
+            url_fwprintf( output, L" . " );
             print( output, pointer );
     }
 }
 
-void print_list( FILE * output, struct cons_pointer pointer ) {
+void print_list( URL_FILE * output, struct cons_pointer pointer ) {
-    if ( print_use_colours ) {
+    url_fputws( L"(", output );
-        fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" );
-    } else {
-        fputws( L"(", output );
-    };
-
     print_list_contents( output, pointer, false );
-    if ( print_use_colours ) {
+    url_fputws( L")", output );
-        fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" );
-    } else {
-        fputws( L")", output );
 }
 
+
+void print_map( URL_FILE * output, struct cons_pointer map) {
+    if ( vectorpointp( map)) {
+        struct vector_space_object *vso = pointer_to_vso( map);
+
+        if ( mapp( vso ) ) {
+            url_fputwc( btowc( '{' ), output );
+
+            for ( struct cons_pointer ks = keys( map);
+                 !nilp( ks); ks = c_cdr( ks)) {
+                print( output, c_car( ks));
+                url_fputwc( btowc( ' ' ), output );
+                print( output, c_assoc( c_car( ks), map));
+
+                if ( !nilp( c_cdr( ks))) {
+                    url_fputws( L", ", output );
                 }
+            }
+
+            url_fputwc( btowc( '}' ), output );
+        }
+    }
+}
+
+
+void print_vso( URL_FILE * output, struct cons_pointer pointer) {
+    struct vector_space_object *vso =
+        pointer2cell( pointer ).payload.vectorp.address;
+
+    switch ( vso->header.tag.value) {
+        case MAPTV:
+            print_map( output, pointer);
+            break;
+        // \todo: others.
+    }
+}
+
+/**
+ * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc
+ */
+void print_128bit( URL_FILE * output, __int128_t n ) {
+    if ( n == 0 ) {
+        fwprintf( stderr, L"0" );
+    } else {
+        char str[40] = { 0 }; // log10(1 << 128) + '\0'
+        char *s = str + sizeof( str ) - 1;  // start at the end
+        while ( n != 0 ) {
+            if ( s == str )
+                return;     // never happens
+
+            *--s = "0123456789"[n % 10];  // save last digit
+            n /= 10;        // drop it
+        }
+        url_fwprintf( output, L"%s", s );
+    }
+}
+
 
 /**
  * Print the cons-space object indicated by `pointer` to the stream indicated
  * by `output`.
  */
-struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
+struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     char *buffer;
 
@@ -117,23 +163,25 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
             print_list( output, pointer );
             break;
         case EXCEPTIONTV:
-            fwprintf( output, L"\n%sException: ",
+            url_fwuts( L"\nException: ", output );
-                      print_use_colours ? "\x1B[31m" : "" );
             dump_stack_trace( output, pointer );
             break;
         case FUNCTIONTV:
-            fwprintf( output, L"<Function>" );
+            url_fputws( L"<Function: ", output);
+            print( output, cell.payload.function.meta);
+            url_fputwc( L'>', output);
             break;
         case INTEGERTV:{
                 struct cons_pointer s = integer_to_string( pointer, 10 );
                 inc_ref( s );
-                if ( print_use_colours ) {
-                    fputws( L"\x1B[34m", output );
-                }
                 print_string_contents( output, s );
                 dec_ref( s );
             }
             break;
+        case KEYTV:
+            url_fputws( L":", output );
+            print_string_contents( output, pointer );
+            break;
         case LAMBDATV:{
                 struct cons_pointer to_print =
                     make_cons( c_string_to_lisp_symbol( L"lambda" ),
@@ -147,7 +195,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
             }
             break;
         case NILTV:
-            fwprintf( output, L"nil" );
+            url_fwprintf( output, L"nil" );
             break;
         case NLAMBDATV:{
                 struct cons_pointer to_print =
@@ -163,11 +211,13 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
             break;
         case RATIOTV:
             print( output, cell.payload.ratio.dividend );
-            fputws( L"/", output );
+            url_fputws( L"/", output );
             print( output, cell.payload.ratio.divisor );
             break;
         case READTV:
-            fwprintf( output, L"<Input stream>" );
+            url_fwprintf( output, L"<Input stream: " );
+            print( output, cell.payload.stream.meta);
+            url_fputwc( L'>', output);
             break;
         case REALTV:
             /* \todo using the C heap is a bad plan because it will fragment.
@@ -182,49 +232,48 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
                     buffer[i] = '\0';
                 }
             }
-            if ( print_use_colours ) {
+            url_fwprintf( output, L"%s", buffer );
-                fputws( L"\x1B[34m", output );
-            }
-            fwprintf( output, L"%s", buffer );
             free( buffer );
             break;
         case STRINGTV:
-            if ( print_use_colours ) {
-                fputws( L"\x1B[36m", output );
-            }
             print_string( output, pointer );
             break;
         case SYMBOLTV:
-            if ( print_use_colours ) {
-                fputws( L"\x1B[1;33m", output );
-            }
             print_string_contents( output, pointer );
             break;
         case SPECIALTV:
-            fwprintf( output, L"<Special form>" );
+            url_fwprintf( output, L"<Special form: " );
+            print( output, cell.payload.special.meta);
+            url_fputwc( L'>', output);
+            break;
+        case TIMETV:
+            url_fwprintf( output, L"<Time: " );
+            print_string( output, time_to_string( pointer));
+            url_fputws( L"; ", output);
+            print_128bit( output, pointer2cell(pointer).payload.time.value);
+            url_fputwc( L'>', output);
             break;
         case TRUETV:
-            fwprintf( output, L"t" );
+            url_fwprintf( output, L"t" );
+            break;
+        case VECTORPOINTTV:
+            print_vso( output, pointer);
             break;
         case WRITETV:
-            fwprintf( output, L"<Output stream>" );
+            url_fwprintf( output, L"<Output stream: " );
+            print( output, cell.payload.stream.meta);
+            url_fputwc( L'>', output);
             break;
         default:
             fwprintf( stderr,
-                      L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
+                      L"Error: Unrecognised tag value %d (%4.4s)\n",
-                      print_use_colours ? "\x1B[31m" : "",
+                      cell.tag.value, &cell.tag.bytes[0] );
-                      cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1],
-                      cell.tag.bytes[2], cell.tag.bytes[3] );
             break;
     }
 
-    if ( print_use_colours ) {
-        fputws( L"\x1B[39m", output );
-    }
-
     return pointer;
 }
 
-void println( FILE * output ) {
+void println( URL_FILE * output ) {
-    fputws( L"\n", output );
+    url_fputws( L"\n", output );
 }

src/io/print.h

@@ -14,8 +14,7 @@
 #ifndef __print_h
 #define __print_h
 
-struct cons_pointer print( FILE * output, struct cons_pointer pointer );
+struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer );
-void println( FILE * output );
+void println( URL_FILE * output );
-extern int print_use_colours;
 
 #endif

src/io/read.c

@@ -22,7 +22,9 @@
 #include "dump.h"
 #include "integer.h"
 #include "intern.h"
+#include "io.h"
 #include "lispops.h"
+#include "map.h"
 #include "peano.h"
 #include "print.h"
 #include "ratio.h"
@@ -38,13 +40,17 @@
 
 struct cons_pointer read_number( struct stack_frame *frame,
                                  struct cons_pointer frame_pointer,
-                                 FILE * input, wint_t initial,
+                                 URL_FILE * input, wint_t initial,
                                  bool seen_period );
 struct cons_pointer read_list( struct stack_frame *frame,
-                               struct cons_pointer frame_pointer, FILE * input,
+                               struct cons_pointer frame_pointer,
+                               URL_FILE * input, wint_t initial );
+struct cons_pointer read_map( struct stack_frame *frame,
+                               struct cons_pointer frame_pointer,
+                               URL_FILE * input, wint_t initial );
+struct cons_pointer read_string( URL_FILE * input, wint_t initial );
+struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag,
                                         wint_t initial );
-struct cons_pointer read_string( FILE * input, wint_t initial );
-struct cons_pointer read_symbol( FILE * input, wint_t initial );
 
 /**
  * quote reader macro in C (!)
@@ -61,23 +67,25 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
  */
 struct cons_pointer read_continuation( struct stack_frame *frame,
                                        struct cons_pointer frame_pointer,
-                                       FILE * input, wint_t initial ) {
+                                       URL_FILE * input, wint_t initial ) {
     debug_print( L"entering read_continuation\n", DEBUG_IO );
     struct cons_pointer result = NIL;
 
     wint_t c;
 
     for ( c = initial;
-          c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) );
+          c == '\0' || iswblank( c ) || iswcntrl( c );
+          c = url_fgetwc( input ) );
 
-    if ( feof( input ) ) {
+    if ( url_feof( input ) ) {
         result =
             throw_exception( c_string_to_lisp_string
                              ( L"End of file while reading" ), frame_pointer );
     } else {
         switch ( c ) {
             case ';':
-                for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) );
+                for ( c = url_fgetwc( input ); c != '\n';
+                      c = url_fgetwc( input ) );
                 /* skip all characters from semi-colon to the end of the line */
                 break;
             case EOF:
@@ -89,52 +97,62 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
                 result =
                     c_quote( read_continuation
                              ( frame, frame_pointer, input,
-                               fgetwc( input ) ) );
+                               url_fgetwc( input ) ) );
                 break;
             case '(':
                 result =
-                    read_list( frame, frame_pointer, input, fgetwc( input ) );
+                    read_list( frame, frame_pointer, input,
+                               url_fgetwc( input ) );
+                break;
+            case '{':
+                result = read_map( frame, frame_pointer, input,
+                               url_fgetwc( input ) );
                 break;
             case '"':
-                result = read_string( input, fgetwc( input ) );
+                result = read_string( input, url_fgetwc( input ) );
                 break;
             case '-':{
-                    wint_t next = fgetwc( input );
+                    wint_t next = url_fgetwc( input );
-                    ungetwc( next, input );
+                    url_ungetwc( next, input );
                     if ( iswdigit( next ) ) {
                         result =
                             read_number( frame, frame_pointer, input, c,
                                          false );
                     } else {
-                        result = read_symbol( input, c );
+                        result = read_symbol_or_key( input, SYMBOLTAG, c );
                     }
                 }
                 break;
             case '.':
                 {
-                    wint_t next = fgetwc( input );
+                    wint_t next = url_fgetwc( input );
                     if ( iswdigit( next ) ) {
-                        ungetwc( next, input );
+                        url_ungetwc( next, input );
                         result =
                             read_number( frame, frame_pointer, input, c,
                                          true );
                     } else if ( iswblank( next ) ) {
                         /* dotted pair. \todo this isn't right, we
                          * really need to backtrack up a level. */
-                        result =
+                        result = read_continuation( frame, frame_pointer, input,
-                            read_continuation( frame, frame_pointer, input,
+                                               url_fgetwc( input ) );
-                                               fgetwc( input ) );
+                        debug_print( L"read_continuation: dotted pair; read cdr ",
+                                    DEBUG_IO);
                     } else {
-                        read_symbol( input, c );
+                        read_symbol_or_key( input, SYMBOLTAG, c );
                     }
                 }
                 break;
+            case ':':
+                result =
+                    read_symbol_or_key( input, KEYTAG, url_fgetwc( input ) );
+                break;
             default:
                 if ( iswdigit( c ) ) {
                     result =
                         read_number( frame, frame_pointer, input, c, false );
                 } else if ( iswprint( c ) ) {
-                    result = read_symbol( input, c );
+                    result = read_symbol_or_key( input, SYMBOLTAG, c );
                 } else {
                     result =
                         throw_exception( make_cons( c_string_to_lisp_string
@@ -158,7 +176,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
  */
 struct cons_pointer read_number( struct stack_frame *frame,
                                  struct cons_pointer frame_pointer,
-                                 FILE * input,
+                                 URL_FILE * input,
                                  wint_t initial, bool seen_period ) {
     debug_print( L"entering read_number\n", DEBUG_IO );
 
@@ -172,14 +190,14 @@ struct cons_pointer read_number( struct stack_frame *frame,
     bool neg = initial == btowc( '-' );
 
     if ( neg ) {
-        initial = fgetwc( input );
+        initial = url_fgetwc( input );
     }
 
     debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial,
                   initial );
 
     for ( c = initial; iswdigit( c )
-          || c == L'.' || c == L'/' || c == L','; c = fgetwc( input ) ) {
+          || c == L'.' || c == L'/' || c == L','; c = url_fgetwc( input ) ) {
         switch ( c ) {
             case L'.':
                 if ( seen_period || !nilp( dividend ) ) {
@@ -228,7 +246,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
     /*
      * push back the character read which was not a digit
      */
-    ungetwc( c, input );
+    url_ungetwc( c, input );
 
     if ( seen_period ) {
         debug_print( L"read_number: converting result to real\n", DEBUG_IO );
@@ -267,18 +285,37 @@ struct cons_pointer read_number( struct stack_frame *frame,
  */
 struct cons_pointer read_list( struct stack_frame *frame,
                               struct cons_pointer frame_pointer,
-                               FILE * input, wint_t initial ) {
+                              URL_FILE * input, wint_t initial ) {
     struct cons_pointer result = NIL;
+    wint_t c;
+
     if ( initial != ')' ) {
         debug_printf( DEBUG_IO,
                      L"read_list starting '%C' (%d)\n", initial, initial );
         struct cons_pointer car =
             read_continuation( frame, frame_pointer, input,
                               initial );
+
+        /* skip whitespace */
+        for (c = url_fgetwc( input );
+             iswblank( c ) || iswcntrl( c );
+             c = url_fgetwc( input ));
+
+        if ( c == L'.') {
+            /* might be a dotted pair; indeed, if we rule out numbers with
+             * initial periods, it must be a dotted pair. \todo Ought to check,
+             * howerver, that there's only one form after the period. */
             result =
                 make_cons( car,
-                       read_list( frame, frame_pointer, input,
+                          c_car( read_list( frame,
-                                  fgetwc( input ) ) );
+                                           frame_pointer,
+                                           input,
+                                           url_fgetwc( input ) ) ) );
+        } else {
+            result =
+                make_cons( car,
+                          read_list( frame, frame_pointer, input, c ) );
+        }
     } else {
         debug_print( L"End of list detected\n", DEBUG_IO );
     }
@@ -286,6 +323,37 @@ struct cons_pointer read_list( struct stack_frame *frame,
     return result;
 }
 
+
+struct cons_pointer read_map( struct stack_frame *frame,
+                               struct cons_pointer frame_pointer,
+                             URL_FILE * input, wint_t initial ) {
+    struct cons_pointer result = make_empty_map( NIL);
+    wint_t c = initial;
+
+    while ( c != L'}' ) {
+        struct cons_pointer key =
+            read_continuation( frame, frame_pointer, input, c );
+
+        /* skip whitespace */
+        for (c = url_fgetwc( input );
+             iswblank( c ) || iswcntrl( c );
+             c = url_fgetwc( input ));
+
+        struct cons_pointer value =
+            read_continuation( frame, frame_pointer, input, c );
+
+        /* skip commaa and whitespace at this point. */
+        for (c = url_fgetwc( input );
+             c == L',' || iswblank( c ) || iswcntrl( c );
+             c = url_fgetwc( input ));
+
+        result = merge_into_map( result, make_cons( make_cons( key, value), NIL));
+    }
+
+    return result;
+}
+
+
 /**
  * Read a string. This means either a string delimited by double quotes
  * (is_quoted == true), in which case it may contain whitespace but may
@@ -293,7 +361,7 @@ struct cons_pointer read_list( struct stack_frame *frame,
  * so delimited in which case it may not contain whitespace (unless escaped)
  * but may contain a double quote character (probably not a good idea!)
  */
-struct cons_pointer read_string( FILE * input, wint_t initial ) {
+struct cons_pointer read_string( URL_FILE * input, wint_t initial ) {
     struct cons_pointer cdr = NIL;
     struct cons_pointer result;
     switch ( initial ) {
@@ -308,54 +376,57 @@ struct cons_pointer read_string( FILE * input, wint_t initial ) {
             break;
         default:
             result =
-                make_string( initial, read_string( input, fgetwc( input ) ) );
+                make_string( initial,
+                             read_string( input, url_fgetwc( input ) ) );
             break;
     }
 
     return result;
 }
 
-struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
+struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag,
+                                        wint_t initial ) {
     struct cons_pointer cdr = NIL;
     struct cons_pointer result;
     switch ( initial ) {
         case '\0':
-            result = make_symbol( initial, NIL );
+            result = make_symbol_or_key( initial, NIL, tag );
             break;
         case '"':
-            /*
+        case '\'':
-             * THIS IS NOT A GOOD IDEA, but is legal
+            /* unwise to allow embedded quotation marks in symbols */
-             */
-            result =
-                make_symbol( initial, read_symbol( input, fgetwc( input ) ) );
-            break;
         case ')':
+        case ':':
             /*
-             * symbols may not include right-parenthesis
+             * symbols and keywords may not include right-parenthesis
+             * or colons.
              */
             result = NIL;
             /*
              * push back the character read
              */
-            ungetwc( initial, input );
+            url_ungetwc( initial, input );
             break;
         default:
             if ( iswprint( initial )
                  && !iswblank( initial ) ) {
                 result =
-                    make_symbol( initial,
+                    make_symbol_or_key( initial,
-                                 read_symbol( input, fgetwc( input ) ) );
+                                        read_symbol_or_key( input,
+                                                            tag,
+                                                            url_fgetwc
+                                                            ( input ) ), tag );
             } else {
                 result = NIL;
                 /*
                  * push back the character read
                  */
-                ungetwc( initial, input );
+                url_ungetwc( initial, input );
             }
             break;
     }
 
-    debug_print( L"read_symbol returning\n", DEBUG_IO );
+    debug_print( L"read_symbol_or_key returning\n", DEBUG_IO );
     debug_dump_object( result, DEBUG_IO );
 
     return result;
@@ -367,6 +438,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
 struct cons_pointer read( struct
                           stack_frame
                           *frame, struct cons_pointer frame_pointer,
-                          FILE * input ) {
+                          URL_FILE * input ) {
-    return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
+    return read_continuation( frame, frame_pointer, input,
+                              url_fgetwc( input ) );
 }

src/io/read.h

@@ -15,6 +15,7 @@
  * read the next object on this input stream and return a cons_pointer to it.
  */
 struct cons_pointer read( struct stack_frame *frame,
-                          struct cons_pointer frame_pointer, FILE * input );
+                          struct cons_pointer frame_pointer,
+                          URL_FILE * input );
 
 #endif

src/memory/conspage.c

@@ -115,9 +115,9 @@ void make_cons_page(  ) {
 /**
  * dump the allocated pages to this `output` stream.
  */
-void dump_pages( FILE * output ) {
+void dump_pages( URL_FILE * output ) {
     for ( int i = 0; i < initialised_cons_pages; i++ ) {
-        fwprintf( output, L"\nDUMPING PAGE %d\n", i );
+        url_fwprintf( output, L"\nDUMPING PAGE %d\n", i );
 
         for ( int j = 0; j < CONSPAGESIZE; j++ ) {
             dump_object( output, ( struct cons_pointer ) {
@@ -152,7 +152,7 @@ void free_cell( struct cons_pointer pointer ) {
                     dec_ref( cell->payload.exception.frame );
                     break;
                 case FUNCTIONTV:
-                    dec_ref( cell->payload.function.source );
+                    dec_ref( cell->payload.function.meta );
                     break;
                 case INTEGERTV:
                     dec_ref( cell->payload.integer.more );
@@ -166,8 +166,13 @@ void free_cell( struct cons_pointer pointer ) {
                     dec_ref( cell->payload.ratio.dividend );
                     dec_ref( cell->payload.ratio.divisor );
                     break;
+                case READTV:
+                case WRITETV:
+                    dec_ref( cell->payload.stream.meta );
+                    url_fclose( cell->payload.stream.stream );
+                    break;
                 case SPECIALTV:
-                    dec_ref( cell->payload.special.source );
+                    dec_ref( cell->payload.special.meta );
                     break;
                 case STRINGTV:
                 case SYMBOLTV:

src/memory/conspage.h

@@ -1,7 +1,19 @@
-#include "consspaceobject.h"
+/*
+ * conspage.h
+ *
+ * Setup and tear down cons pages, and (FOR NOW) do primitive
+ * allocation/deallocation of cells.
+ * NOTE THAT before we go multi-threaded, these functions must be
+ * aggressively
+ * thread safe.
+ *
+ * (c) 2017 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+#ifndef __psse_conspage_h
+#define __psse_conspage_h
 
-#ifndef __conspage_h
+#include "consspaceobject.h"
-#define __conspage_h
 
 /**
  * the number of cons cells on a cons page. The maximum value this can
@@ -47,6 +59,6 @@ struct cons_pointer allocate_cell( char *tag );
 
 void initialise_cons_pages(  );
 
-void dump_pages( FILE * output );
+void dump_pages( URL_FILE * output );
 
 #endif

src/memory/consspaceobject.c

@@ -21,6 +21,7 @@
 #include "conspage.h"
 #include "consspaceobject.h"
 #include "debug.h"
+#include "intern.h"
 #include "print.h"
 #include "stack.h"
 
@@ -65,6 +66,71 @@ void dec_ref( struct cons_pointer pointer ) {
 }
 
 
+/**
+ * Get the Lisp type of the single argument.
+ * @param pointer a pointer to the object whose type is requested.
+ * @return As a Lisp string, the tag of the object which is at that pointer.
+ */
+struct cons_pointer c_type( struct cons_pointer pointer ) {
+    struct cons_pointer result = NIL;
+    struct cons_space_object cell = pointer2cell( pointer );
+
+    for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
+        result = make_string( ( wchar_t ) cell.tag.bytes[i], result );
+    }
+
+    return result;
+}
+
+/**
+ * Implementation of car in C. If arg is not a cons, does not error but returns nil.
+ */
+struct cons_pointer c_car( struct cons_pointer arg ) {
+    struct cons_pointer result = NIL;
+
+    if ( consp( arg ) ) {
+        result = pointer2cell( arg ).payload.cons.car;
+    }
+
+    return result;
+}
+
+/**
+ * Implementation of cdr in C. If arg is not a sequence, does not error but returns nil.
+ */
+struct cons_pointer c_cdr( struct cons_pointer arg ) {
+    struct cons_pointer result = NIL;
+
+    struct cons_space_object cell = pointer2cell( arg );
+
+    switch (cell.tag.value) {
+        case CONSTV:
+        result = pointer2cell( arg ).payload.cons.cdr;
+        break;
+        case KEYTV:
+        case STRINGTV:
+        case SYMBOLTV:
+        result = pointer2cell( arg ).payload.string.cdr;
+        break;
+    }
+
+    return result;
+}
+
+/**
+ * Implementation of `length` in C. If arg is not a cons, does not error but returns 0.
+ */
+int c_length( struct cons_pointer arg) {
+    int result = 0;
+
+    for (struct cons_pointer c = arg; !nilp(c); c = c_cdr(c)) {
+        result ++;
+    }
+
+    return result;
+}
+
+
 /**
  * Construct a cons cell from this pair of pointers.
  */
@@ -95,8 +161,6 @@ struct cons_pointer make_exception( struct cons_pointer message,
     struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
-//    inc_ref( pointer );         /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */
-
     inc_ref( message );
     inc_ref( frame_pointer );
     cell->payload.exception.message = message;
@@ -109,16 +173,17 @@ struct cons_pointer make_exception( struct cons_pointer message,
 
 
 /**
- * Construct a cell which points to an executable Lisp special form.
+ * Construct a cell which points to an executable Lisp function.
  */
 struct cons_pointer
-make_function( struct cons_pointer src, struct cons_pointer ( *executable )
+make_function( struct cons_pointer meta, struct cons_pointer ( *executable )
                 ( struct stack_frame *,
                   struct cons_pointer, struct cons_pointer ) ) {
     struct cons_pointer pointer = allocate_cell( FUNCTIONTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
+    inc_ref( meta );
 
-    cell->payload.function.source = src;
+    cell->payload.function.meta = meta;
     cell->payload.function.executable = executable;
 
     return pointer;
@@ -205,27 +270,42 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
 }
 
 /**
- * Construct a symbol from the character `c` and this `tail`. A symbol is
+ * Construct a symbol or keyword from the character `c` and this `tail`.
- * internally identical to a string except for having a different tag.
+ * Each is internally identical to a string except for having a different tag.
  *
  * @param c the character to add (prepend);
  * @param tail the symbol which is being built.
+ * @param tag the tag to use: expected to be "SYMB" or "KEYW"
  */
-struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
+struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
-    return make_string_like_thing( c, tail, SYMBOLTAG );
+                                        char *tag ) {
+    struct cons_pointer result = make_string_like_thing( c, tail, tag );
+
+    if ( strncmp( tag, KEYTAG, 4 ) == 0 ) {
+        struct cons_pointer r = internedp( result, oblist );
+
+        if ( nilp( r ) ) {
+            intern( result, oblist );
+        } else {
+            result = r;
+        }
+    }
+
+    return result;
 }
 
 /**
  * Construct a cell which points to an executable Lisp special form.
  */
 struct cons_pointer
-make_special( struct cons_pointer src, struct cons_pointer ( *executable )
+make_special( struct cons_pointer meta, struct cons_pointer ( *executable )
                ( struct stack_frame * frame,
                  struct cons_pointer, struct cons_pointer env ) ) {
     struct cons_pointer pointer = allocate_cell( SPECIALTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
+    inc_ref( meta );
 
-    cell->payload.special.source = src;
+    cell->payload.special.meta = meta;
     cell->payload.special.executable = executable;
 
     return pointer;
@@ -234,12 +314,16 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable )
 /**
  * Construct a cell which points to a stream open for reading.
  * @param input the C stream to wrap.
+ * @param metadata a pointer to an associaton containing metadata on the stream.
+ * @return a pointer to the new read stream.
  */
-struct cons_pointer make_read_stream( FILE * input ) {
+struct cons_pointer make_read_stream( URL_FILE * input,
+                                      struct cons_pointer metadata ) {
     struct cons_pointer pointer = allocate_cell( READTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     cell->payload.stream.stream = input;
+    cell->payload.stream.meta = metadata;
 
     return pointer;
 }
@@ -247,24 +331,48 @@ struct cons_pointer make_read_stream( FILE * input ) {
 /**
  * Construct a cell which points to a stream open for writing.
  * @param output the C stream to wrap.
+ * @param metadata a pointer to an associaton containing metadata on the stream.
+ * @return a pointer to the new read stream.
  */
-struct cons_pointer make_write_stream( FILE * output ) {
+struct cons_pointer make_write_stream( URL_FILE * output,
+                                       struct cons_pointer metadata ) {
     struct cons_pointer pointer = allocate_cell( WRITETAG );
     struct cons_space_object *cell = &pointer2cell( pointer );
 
     cell->payload.stream.stream = output;
+    cell->payload.stream.meta = metadata;
 
     return pointer;
 }
 
+/**
+ * Return a lisp keyword representation of this wide character string. In keywords,
+ * I am accepting only lower case characters and numbers.
+ */
+struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) {
+    struct cons_pointer result = NIL;
+
+    for ( int i = wcslen( symbol ) -1; i >= 0; i-- ) {
+      wchar_t c = towlower(symbol[i]);
+
+      if (iswalnum(c) || c == L'-') {
+        result = make_keyword( c, result );
+      }
+    }
+
+    return result;
+}
+
 /**
  * Return a lisp string representation of this wide character string.
  */
 struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
     struct cons_pointer result = NIL;
 
-    for ( int i = wcslen( string ); i > 0; i-- ) {
+    for ( int i = wcslen( string ) - 1; i >= 0; i-- ) {
-        result = make_string( string[i - 1], result );
+      if (iswprint(string[i]) && string[i] != '"') {
+        result = make_string( string[i], result );
+      }
     }
 
     return result;

src/memory/consspaceobject.h

@@ -8,6 +8,9 @@
  *  Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#ifndef __psse_consspaceobject_h
+#define __psse_consspaceobject_h
+
 #include <stdbool.h>
 #include <stdint.h>
 #include <stdio.h>
@@ -17,8 +20,8 @@
 #include <wchar.h>
 #include <wctype.h>
 
-#ifndef __consspaceobject_h
+#include "fopen.h"
-#define __consspaceobject_h
+
 
 /**
  * The length of a tag, in bytes.
@@ -37,6 +40,7 @@
 
 /**
  * The string `CONS`, considered as an `unsigned int`.
+ * @todo tag values should be collected into an enum.
  */
 #define CONSTV      1397641027
 
@@ -83,6 +87,16 @@
  */
 #define INTEGERTV   1381256777
 
+/**
+ * A keyword - an interned, self-evaluating string.
+ */
+#define KEYTAG	    "KEYW"
+
+/**
+ * The string `KEYW`, considered as an `unsigned int`.
+ */
+#define KEYTV       1465468235
+
 /**
  * A lambda cell. Lambdas are the interpretable (source) versions of functions.
  * \see FUNCTIONTAG.
@@ -179,6 +193,16 @@
  */
 #define SYMBOLTV    1112365395
 
+/**
+ * A time stamp.
+ */
+#define TIMETAG     "TIME"
+
+/**
+ * The string `TIME`, considered as an `unsigned int`.
+ */
+#define TIMETV      1162692948
+
 /**
  * The special cons cell at address {0,1} which is canonically different
  * from NIL.
@@ -256,6 +280,11 @@
  */
 #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG))
 
+/**
+ * true if `conspoint` points to a keyword, else false
+ */
+#define keywordp(conspoint) (check_tag(conspoint,KEYTAG))
+
 /**
  * true if `conspoint` points to a special Lambda cell, else false
  */
@@ -318,18 +347,25 @@
  */
 #define writep(conspoint) (check_tag(conspoint,WRITETAG))
 
+#define streamp(conspoint) (check_tag(conspoint,READTAG)||check_tag(conspoint,WRITETAG))
+
 /**
  * true if `conspoint` points to a true cell, else false
  * (there should only be one of these so it's slightly redundant).
  * Also note that anything that is not NIL is truthy.
  */
-#define tp(conspoint) (checktag(conspoint,TRUETAG))
+#define tp(conspoint) (check_tag(conspoint,TRUETAG))
+
+/**
+ * true if `conspoint` points to a time cell, else false.
+ */
+#define timep(conspoint) (check_tag(conspoint,TIMETAG))
 
 /**
  * true if `conspoint` points to something that is truthy, i.e.
  * anything but NIL.
  */
-#define truep(conspoint) (!checktag(conspoint,NILTAG))
+#define truep(conspoint) (!check_tag(conspoint,NILTAG))
 
 /**
  * An indirect pointer to a cons cell
@@ -395,10 +431,9 @@ struct exception_payload {
  */
 struct function_payload {
     /**
-     * pointer to the source from which the function was compiled, or NIL
+     * pointer to metadata (e.g. the source from which the function was compiled).
-     * if it is a primitive.
      */
-    struct cons_pointer source;
+    struct cons_pointer meta;
     /**  pointer to a function which takes a cons pointer (representing
      * its argument list) and a cons pointer (representing its environment) and a
      * stack frame (representing the previous stack frame) as arguments and returns
@@ -473,7 +508,7 @@ struct special_payload {
      * pointer to the source from which the special form was compiled, or NIL
      * if it is a primitive.
      */
-    struct cons_pointer source;
+    struct cons_pointer meta;
     /**  pointer to a function which takes a cons pointer (representing
      * its argument list) and a cons pointer (representing its environment) and a
      * stack frame (representing the previous stack frame) as arguments and returns
@@ -488,14 +523,19 @@ struct special_payload {
  */
 struct stream_payload {
     /** the stream to read from or write to. */
-    FILE *stream;
+    URL_FILE *stream;
+    /** metadata on the stream (e.g. its file attributes if a file, its HTTP
+     * headers if a URL, etc). Expected to be an association, or nil. Not yet
+     * implemented. */
+    struct cons_pointer meta;
 };
 
 /**
  * payload of a string cell. At least at first, only one UTF character will
  * be stored in each cell. The doctrine that 'a symbol is just a string'
- * didn't work; however, the payload of a symbol cell is identical to the
+ * didn't work; however, the payload of a symbol or keyword cell is identical
- * payload of a string cell.
+ * to the payload of a string cell, except that a keyword may store a hash
+ * of its own value in the padding.
  */
 struct string_payload {
     /** the actual character stored in this cell */
@@ -506,6 +546,15 @@ struct string_payload {
     struct cons_pointer cdr;
 };
 
+/**
+ * The payload of a time cell: an unsigned 128 bit value representing micro-
+ * seconds since the estimated date of the Big Bang (actually, for
+ * convenience, 14Bn years before 1st Jan 1970 (the UNIX epoch))
+ */
+struct time_payload {
+    unsigned __int128 value;
+};
+
 /**
  * payload of a vector pointer cell.
  */
@@ -591,6 +640,10 @@ struct cons_space_object {
          * if tag == STRINGTAG || tag == SYMBOLTAG
          */
         struct string_payload string;
+        /**
+         * if tag == TIMETAG
+         */
+        struct time_payload time;
         /**
          * if tag == TRUETAG; we'll treat the special cell T as just a cons
          */
@@ -608,6 +661,14 @@ void inc_ref( struct cons_pointer pointer );
 
 void dec_ref( struct cons_pointer pointer );
 
+struct cons_pointer c_type( struct cons_pointer pointer );
+
+struct cons_pointer c_car( struct cons_pointer arg );
+
+struct cons_pointer c_cdr( struct cons_pointer arg );
+
+int c_length( struct cons_pointer arg);
+
 struct cons_pointer make_cons( struct cons_pointer car,
                                struct cons_pointer cdr );
 
@@ -620,6 +681,8 @@ struct cons_pointer make_function( struct cons_pointer src,
                                       struct cons_pointer,
                                       struct cons_pointer ) );
 
+struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol );
+
 struct cons_pointer make_lambda( struct cons_pointer args,
                                  struct cons_pointer body );
 
@@ -634,11 +697,18 @@ struct cons_pointer make_special( struct cons_pointer src,
 
 struct cons_pointer make_string( wint_t c, struct cons_pointer tail );
 
-struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail );
+struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
+                                        char *tag );
 
-struct cons_pointer make_read_stream( FILE * input );
+#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTAG))
 
-struct cons_pointer make_write_stream( FILE * output );
+#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTAG))
+
+struct cons_pointer make_read_stream( URL_FILE * input,
+                                      struct cons_pointer metadata );
+
+struct cons_pointer make_write_stream( URL_FILE * output,
+                                       struct cons_pointer metadata );
 
 struct cons_pointer c_string_to_lisp_string( wchar_t *string );
 

src/memory/dump.c

@@ -21,102 +21,107 @@
 #include "conspage.h"
 #include "consspaceobject.h"
 #include "debug.h"
+#include "intern.h"
+#include "map.h"
 #include "print.h"
 #include "stack.h"
 #include "vectorspace.h"
 
 
-void dump_string_cell( FILE * output, wchar_t *prefix,
+void dump_string_cell( URL_FILE * output, wchar_t *prefix,
                        struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
     if ( cell.payload.string.character == 0 ) {
-        fwprintf( output,
+        url_fwprintf( output,
                       L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
                       prefix,
-                  cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
+                      cell.payload.string.cdr.page,
-                  cell.count );
+                      cell.payload.string.cdr.offset, cell.count );
     } else {
-        fwprintf( output,
+        url_fwprintf( output,
                       L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
                       prefix,
                       ( wint_t ) cell.payload.string.character,
                       cell.payload.string.character,
                       cell.payload.string.cdr.page,
                       cell.payload.string.cdr.offset, cell.count );
-        fwprintf( output, L"\t\t value: " );
+        url_fwprintf( output, L"\t\t value: " );
         print( output, pointer );
-        fwprintf( output, L"\n" );
+        url_fwprintf( output, L"\n" );
     }
 }
 
 /**
  * dump the object at this cons_pointer to this output stream.
  */
-void dump_object( FILE * output, struct cons_pointer pointer ) {
+void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
     struct cons_space_object cell = pointer2cell( pointer );
-    fwprintf( output,
+    url_fwprintf( output,
                   L"\t%4.4s (%d) at page %d, offset %d count %u\n",
                   cell.tag.bytes,
                   cell.tag.value, pointer.page, pointer.offset, cell.count );
 
     switch ( cell.tag.value ) {
         case CONSTV:
-            fwprintf( output,
+            url_fwprintf( output,
                           L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :",
                           cell.payload.cons.car.page,
                           cell.payload.cons.car.offset,
                           cell.payload.cons.cdr.page,
                           cell.payload.cons.cdr.offset, cell.count );
             print( output, pointer );
-            fputws( L"\n", output );
+            url_fputws( L"\n", output );
             break;
         case EXCEPTIONTV:
-            fwprintf( output, L"\t\tException cell: " );
+            url_fwprintf( output, L"\t\tException cell: " );
             dump_stack_trace( output, pointer );
             break;
         case FREETV:
-            fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
+            url_fwprintf( output,
+                          L"\t\tFree cell: next at page %d offset %d\n",
                           cell.payload.cons.cdr.page,
                           cell.payload.cons.cdr.offset );
             break;
         case INTEGERTV:
-            fwprintf( output,
+            url_fwprintf( output,
                           L"\t\tInteger cell: value %ld, count %u\n",
                           cell.payload.integer.value, cell.count );
             if ( !nilp( cell.payload.integer.more ) ) {
-                fputws( L"\t\tBIGNUM! More at:\n", output );
+                url_fputws( L"\t\tBIGNUM! More at:\n", output );
                 dump_object( output, cell.payload.integer.more );
             }
             break;
         case LAMBDATV:
-            fwprintf( output, L"\t\tLambda cell;\n\t\t args: " );
+            url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " );
             print( output, cell.payload.lambda.args );
-            fwprintf( output, L";\n\t\t\tbody: " );
+            url_fwprintf( output, L";\n\t\t\tbody: " );
             print( output, cell.payload.lambda.body );
-            fputws( L"\n", output );
+            url_fputws( L"\n", output );
             break;
         case NILTV:
             break;
         case NLAMBDATV:
-            fwprintf( output, L"\t\tNlambda cell; \n\t\targs: " );
+            url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " );
             print( output, cell.payload.lambda.args );
-            fwprintf( output, L";\n\t\t\tbody: " );
+            url_fwprintf( output, L";\n\t\t\tbody: " );
             print( output, cell.payload.lambda.body );
-            fputws( L"\n", output );
+            url_fputws( L"\n", output );
             break;
         case RATIOTV:
-            fwprintf( output,
+            url_fwprintf( output,
                           L"\t\tRational cell: value %ld/%ld, count %u\n",
-                      pointer2cell( cell.payload.ratio.dividend ).payload.
+                          pointer2cell( cell.payload.ratio.dividend ).
-                      integer.value,
+                          payload.integer.value,
-                      pointer2cell( cell.payload.ratio.divisor ).payload.
+                          pointer2cell( cell.payload.ratio.divisor ).
-                      integer.value, cell.count );
+                          payload.integer.value, cell.count );
             break;
         case READTV:
-            fwprintf( output, L"\t\tInput stream\n" );
+            url_fputws( L"\t\tInput stream; metadata: ", output );
+            print( output, cell.payload.stream.meta );
+            url_fputws( L"\n", output );
             break;
         case REALTV:
-            fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
+            url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
                           cell.payload.real.value, cell.count );
             break;
         case STRINGTV:
@@ -128,11 +133,11 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
         case TRUETV:
             break;
         case VECTORPOINTTV:{
-                fwprintf( output,
+                url_fwprintf( output,
                               L"\t\tPointer to vector-space object at %p\n",
                               cell.payload.vectorp.address );
                 struct vector_space_object *vso = cell.payload.vectorp.address;
-                fwprintf( output,
+                url_fwprintf( output,
                               L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n",
                               &vso->header.tag.bytes, vso->header.tag.value,
                               vso->header.size );
@@ -143,11 +148,16 @@ void dump_object( FILE * output, struct cons_pointer pointer ) {
                     case STACKFRAMETV:
                         dump_frame( output, pointer );
                         break;
+                    case MAPTV:
+                        dump_map( output, pointer);
+                        break;
                 }
             }
             break;
         case WRITETV:
-            fwprintf( output, L"\t\tOutput stream\n" );
+            url_fputws( L"\t\tOutput stream; metadata: ", output );
+            print( output, cell.payload.stream.meta );
+            url_fputws( L"\n", output );
             break;
     }
 }

src/memory/dump.h

@@ -20,6 +20,6 @@
 #define __dump_h
 
 
-void dump_object( FILE * output, struct cons_pointer pointer );
+void dump_object( URL_FILE * output, struct cons_pointer pointer );
 
 #endif

src/memory/lookup3.h

@@ -0,0 +1,19 @@
+/**
+ * lookup3.h
+ *
+ * Minimal header file wrapping Bob Jenkins' lookup3.c
+ *
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Public domain.
+ */
+
+#ifndef __lookup3_h
+#define __lookup3_h
+
+uint32_t hashword(
+const uint32_t *k,
+size_t          length,
+uint32_t        initval);
+
+#endif

src/memory/map.c

@@ -0,0 +1,289 @@
+/*
+ * map.c
+ *
+ * An immutable hashmap in vector space.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdlib.h>
+
+#include "consspaceobject.h"
+#include "conspage.h"
+#include "debug.h"
+#include "dump.h"
+#include "fopen.h"
+#include "intern.h"
+#include "io.h"
+#include "lookup3.h"
+#include "map.h"
+#include "print.h"
+#include "vectorspace.h"
+
+/* \todo: a lot of this will be inherited by namespaces, regularities and
+ * homogeneities. Exactly how I don't yet know. */
+
+/**
+ * Get a hash value for this key.
+ */
+uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) {
+    uint32_t result = 0;
+    int l =  c_length(key);
+
+    if (keywordp(key) || stringp(key) || symbolp( key)) {
+        if ( l > 0) {
+            uint32_t buffer[l];
+
+            if (!nilp(f)) {
+                fputws(L"Custom hashing functions are not yet implemented.\n", stderr);
+            }
+            for (int i = 0; i < l; i++) {
+                buffer[i] = (uint32_t)pointer2cell(key).payload.string.character;
+            }
+
+            result = hashword( buffer, l, 0);
+        }
+    } else {
+        fputws(L"Hashing is thus far implemented only for keys, strings and symbols.\n", stderr);
+    }
+
+    return result;
+}
+
+/**
+ * get the actual map object from this `pointer`, or NULL if
+ * `pointer` is not a map pointer.
+ */
+struct map_payload *get_map_payload( struct cons_pointer pointer ) {
+    struct map_payload *result = NULL;
+    struct vector_space_object *vso =
+        pointer2cell( pointer ).payload.vectorp.address;
+
+    if (vectorpointp(pointer) && mapp( vso ) ) {
+        result = ( struct map_payload * ) &( vso->payload );
+        debug_printf( DEBUG_BIND,
+                      L"get_map_payload: all good, returning %p\n", result );
+    } else {
+        debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND );
+    }
+
+    return result;
+}
+
+
+/**
+ * Make an empty immutable map, and return it.
+ *
+ * @param hash_function a pointer to a function of one argument, which
+ * returns an integer; or (more usually) `nil`.
+ * @return the new map, or NULL if memory is exhausted.
+ */
+struct cons_pointer make_empty_map( struct cons_pointer hash_function ) {
+    debug_print( L"Entering make_empty_map\n", DEBUG_BIND );
+    struct cons_pointer result =
+        make_vso( MAPTAG, sizeof( struct map_payload ) );
+
+    if ( !nilp( result ) ) {
+        struct map_payload *payload = get_map_payload( result );
+
+        payload->hash_function = functionp( hash_function) ? hash_function : NIL;
+        inc_ref(hash_function);
+
+        for ( int i = 0; i < BUCKETSINMAP; i++) {
+            payload->buckets[i] = NIL;
+        }
+    }
+
+    debug_print( L"Leaving make_empty_map\n", DEBUG_BIND );
+    return result;
+}
+
+
+struct cons_pointer make_duplicate_map( struct cons_pointer parent) {
+    struct cons_pointer result = NIL;
+    struct map_payload * parent_payload = get_map_payload(parent);
+
+    if (parent_payload != NULL) {
+        result =
+            make_vso( MAPTAG, sizeof( struct map_payload ) );
+
+        if ( !nilp( result ) ) {
+            struct map_payload *payload = get_map_payload( result );
+
+            payload->hash_function = parent_payload->hash_function;
+            inc_ref(payload->hash_function);
+
+            for ( int i = 0; i < BUCKETSINMAP; i++) {
+                payload->buckets[i] = parent_payload->buckets[i];
+                inc_ref(payload->buckets[i]);
+            }
+        }
+    }
+
+    return result;
+}
+
+
+struct cons_pointer bind_in_map( struct cons_pointer parent,
+                                struct cons_pointer key,
+                                struct cons_pointer value) {
+    struct cons_pointer result = make_duplicate_map(parent);
+
+    if ( !nilp( result)) {
+        struct map_payload * payload = get_map_payload( result );
+        int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
+
+        payload->buckets[bucket] = make_cons(
+            make_cons(key, value), payload->buckets[bucket]);
+
+        inc_ref(payload->buckets[bucket]);
+    }
+
+    return result;
+}
+
+
+struct cons_pointer keys( struct cons_pointer store) {
+    debug_print( L"Entering keys\n", DEBUG_BIND );
+    struct cons_pointer result = NIL;
+
+    struct cons_space_object cell = pointer2cell( store );
+
+    switch (pointer2cell( store ).tag.value) {
+        case CONSTV:
+        for (struct cons_pointer c = store; !nilp(c); c = c_cdr(c)) {
+            result = make_cons( c_car( c_car( c)), result);
+        }
+        break;
+        case VECTORPOINTTV: {
+            struct vector_space_object *vso =
+                pointer2cell( store ).payload.vectorp.address;
+
+            if ( mapp( vso ) ) {
+                struct map_payload * payload = get_map_payload( store );
+
+                for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) {
+                    for (struct cons_pointer c = payload->buckets[bucket];
+                         !nilp(c); c = c_cdr(c)) {
+                        debug_print( L"keys: c is ", DEBUG_BIND);
+                        debug_print_object( c, DEBUG_BIND);
+
+                        result = make_cons( c_car( c_car( c)), result);
+                        debug_print( L"; result is ", DEBUG_BIND);
+                        debug_print_object( result, DEBUG_BIND);
+                        debug_println( DEBUG_BIND);
+                    }
+                }
+            }
+        }
+        break;
+    }
+    debug_print( L"keys returning ", DEBUG_BIND );
+    debug_print_object( result, DEBUG_BIND );
+    debug_println( DEBUG_BIND);
+
+    return result;
+}
+
+/**
+ * Return a new map which represents the merger of `to_merge` into
+ * `parent`. `parent` must be a map, but `to_merge` may be a map or
+ * an assoc list.
+ *
+ * @param parent a map;
+ * @param to_merge an association from which key/value pairs will be merged.
+ * @result a new map, containing all key/value pairs from `to_merge`
+ * together with those key/value pairs from `parent` whose keys did not
+ * collide.
+ */
+struct cons_pointer merge_into_map( struct cons_pointer parent,
+                                   struct cons_pointer to_merge) {
+    debug_print( L"Entering merge_into_map\n", DEBUG_BIND );
+    struct cons_pointer result = make_duplicate_map(parent);
+
+    if (!nilp(result)) {
+        struct map_payload *payload = get_map_payload( result );
+        for (struct cons_pointer c = keys(to_merge);
+             !nilp(c); c = c_cdr(c)) {
+            struct cons_pointer key = c_car( c);
+            int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
+
+            payload->buckets[bucket] = make_cons(
+                make_cons( key, c_assoc( key, to_merge)),
+                payload->buckets[bucket]);
+        }
+    }
+
+    debug_print( L"Leaving merge_into_map\n", DEBUG_BIND );
+
+    return result;
+}
+
+
+struct cons_pointer assoc_in_map( struct cons_pointer key,
+                                  struct cons_pointer map) {
+    debug_print( L"Entering assoc_in_map\n", DEBUG_BIND );
+    struct cons_pointer result = NIL;
+    struct map_payload *payload = get_map_payload( map );
+
+    if (payload != NULL) {
+        int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP;
+        result = c_assoc(key, payload->buckets[bucket]);
+    }
+
+    debug_print( L"assoc_in_map returning ", DEBUG_BIND );
+    debug_print_object( result, DEBUG_BIND);
+    debug_println( DEBUG_BIND);
+
+    return result;
+}
+
+
+/**
+ * Function: create a map initialised with key/value pairs from my
+ * first argument.
+ *
+ * * (make-map)
+ * * (make-map store)
+ *
+ * @param frame the stack frame in which the expression is to be interpreted;
+ * @param frame_pointer a pointer to my stack_frame.
+ * @param env the environment in which it is to be intepreted.
+ * @return a new containing all the key/value pairs from store.
+ */
+struct cons_pointer
+lisp_make_map( struct stack_frame *frame, struct cons_pointer frame_pointer,
+             struct cons_pointer env ) {
+    return merge_into_map( make_empty_map( NIL), frame->arg[0]);
+}
+
+/**
+ * Dump a map to this stream for debugging
+ * @param output the stream
+ * @param map_pointer the pointer to the frame
+ */
+void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) {
+    struct vector_space_object *vso =
+        pointer2cell( map_pointer ).payload.vectorp.address;
+
+    if (vectorpointp(map_pointer) && mapp( vso ) ) {
+        struct map_payload *payload = get_map_payload( map_pointer );
+
+        if ( payload != NULL ) {
+            url_fputws( L"Immutable map; hash function: ", output );
+
+            if (nilp(payload->hash_function)) {
+                url_fputws( L"default", output);
+            } else {
+                dump_object( output, payload->hash_function);
+            }
+
+            for (int i = 0; i < BUCKETSINMAP; i++) {
+                url_fwprintf(output, L"\n\tBucket %d: ", i);
+                print( output, payload->buckets[i]);
+            }
+        }
+    }
+}
+

src/memory/map.h

@@ -0,0 +1,96 @@
+/*
+ * map.h
+ *
+ * An immutable hashmap in vector space.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#ifndef __psse_map_h
+#define __psse_map_h
+
+#include "consspaceobject.h"
+#include "conspage.h"
+
+/**
+ * macros for the tag of a mutable map.
+ */
+#define MAPTAG "IMAP"
+#define MAPTV 1346456905
+
+/**
+ * Number of buckets in a single tier map.
+ */
+#define BUCKETSINMAP 256
+
+/**
+ * Maximum number of entries in an association-list bucket.
+ */
+#define MAXENTRIESINASSOC 16
+
+/**
+ * true if this vector_space_object is a map, else false.
+ */
+#define mapp( vso) (((struct vector_space_object *)vso)->header.tag.value == MAPTV)
+
+/**
+ * The vector-space payload of a map object. Essentially a vector of
+ * `BUCKETSINMAP` + 1 `cons_pointer`s, but the first one is considered
+ * special.
+ */
+struct map_payload {
+    /**
+     * There is a default hash function, which is used if `hash_function` is
+     * `nil` (which it normally should be); and keywords will probably carry
+     * their own hash values. But it will be possible to override the hash
+     * function by putting a function of one argument returning an integer
+     * here. */
+    struct cons_pointer hash_function;
+
+    /**
+     * Obviously the number of buckets in a map is a trade off, and this may need
+     * tuning - or it may even be necessary to have different sized base maps. The
+     * idea here is that the value of a bucket is
+     *
+     * 1. `nil`; or
+     * 2. an association list; or
+     * 3. a map.
+     *
+     * All buckets are initially `nil`. Adding a value to a `nil` bucket returns
+     * a map with a new bucket in the form of an assoc list. Subsequent additions
+     * cons new key/value pairs onto the assoc list, until there are
+     * `MAXENTRIESINASSOC` pairs, at which point if a further value is added to
+     * the same bucket the bucket returned will be in the form of a second level
+     * map. My plan is that buckets the first level map will be indexed on the
+     * first sixteen bits of the hash value, those in the second on the second
+     * sixteen, and, potentially, so on.
+     */
+    struct cons_pointer buckets[BUCKETSINMAP];
+};
+
+uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key);
+
+struct map_payload *get_map_payload( struct cons_pointer pointer );
+
+struct cons_pointer make_empty_map( struct cons_pointer hash_function );
+
+struct cons_pointer bind_in_map( struct cons_pointer parent,
+                                struct cons_pointer key,
+                                struct cons_pointer value);
+
+struct cons_pointer keys( struct cons_pointer store);
+
+struct cons_pointer merge_into_map( struct cons_pointer parent,
+                                   struct cons_pointer to_merge);
+
+struct cons_pointer assoc_in_map( struct cons_pointer key,
+                                  struct cons_pointer map);
+
+struct cons_pointer lisp_make_map( struct stack_frame *frame,
+                                  struct cons_pointer frame_pointer,
+                                  struct cons_pointer env );
+
+void dump_map( URL_FILE * output, struct cons_pointer map_pointer );
+
+#endif

src/memory/stack.c

@@ -241,34 +241,34 @@ void free_stack_frame( struct stack_frame *frame ) {
  * @param output the stream
  * @param frame_pointer the pointer to the frame
  */
-void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
+void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) {
     struct stack_frame *frame = get_stack_frame( frame_pointer );
 
     if ( frame != NULL ) {
-        fwprintf( output, L"Stack frame with %d arguments:\n", frame->args );
+        url_fwprintf( output, L"Stack frame with %d arguments:\n",
+                      frame->args );
         for ( int arg = 0; arg < frame->args; arg++ ) {
             struct cons_space_object cell = pointer2cell( frame->arg[arg] );
 
-            fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
+            url_fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ",
-                      cell.tag.bytes[0],
+                          arg, cell.tag.bytes[0], cell.tag.bytes[1],
-                      cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
+                          cell.tag.bytes[2], cell.tag.bytes[3], cell.count );
-                      cell.count );
 
             print( output, frame->arg[arg] );
-            fputws( L"\n", output );
+            url_fputws( L"\n", output );
         }
         if ( !nilp( frame->more ) ) {
-            fputws( L"More: \t", output );
+            url_fputws( L"More: \t", output );
             print( output, frame->more );
-            fputws( L"\n", output );
+            url_fputws( L"\n", output );
         }
     }
 }
 
-void dump_stack_trace( FILE * output, struct cons_pointer pointer ) {
+void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) {
     if ( exceptionp( pointer ) ) {
         print( output, pointer2cell( pointer ).payload.exception.message );
-        fputws( L"\n", output );
+        url_fputws( L"\n", output );
         dump_stack_trace( output,
                           pointer2cell( pointer ).payload.exception.frame );
     } else {

src/memory/stack.h

@@ -18,12 +18,12 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#ifndef __psse_stack_h
+#define __psse_stack_h
+
 #include "consspaceobject.h"
 #include "conspage.h"
 
-#ifndef __stack_h
-#define __stack_h
-
 /**
  * macros for the tag of a stack frame.
  */
@@ -47,9 +47,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
 
 void free_stack_frame( struct stack_frame *frame );
 
-void dump_frame( FILE * output, struct cons_pointer pointer );
+void dump_frame( URL_FILE * output, struct cons_pointer pointer );
 
-void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer );
+void dump_stack_trace( URL_FILE * output, struct cons_pointer frame_pointer );
 
 struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
 

src/memory/vectorspace.c

@@ -36,7 +36,8 @@
  * @return a cons_pointer to the object, or NIL if the object could not be
  * allocated due to memory exhaustion.
  */
-struct cons_pointer make_vec_pointer( struct vector_space_object *address, char *tag ) {
+struct cons_pointer make_vec_pointer( struct vector_space_object *address,
+                                      char *tag ) {
     debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
     struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
     struct cons_space_object *cell = &pointer2cell( pointer );

src/ops/equal.c

@@ -67,6 +67,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
                     && equal( cell_a->payload.cons.cdr,
                               cell_b->payload.cons.cdr );
                 break;
+            case KEYTV:
             case STRINGTV:
             case SYMBOLTV:
                 /*

src/ops/intern.c

@@ -24,6 +24,7 @@
 #include "debug.h"
 #include "equal.h"
 #include "lispops.h"
+#include "map.h"
 #include "print.h"
 
 /**
@@ -51,7 +52,7 @@ struct cons_pointer
 internedp( struct cons_pointer key, struct cons_pointer store ) {
     struct cons_pointer result = NIL;
 
-    if ( symbolp( key ) ) {
+    if ( symbolp( key ) || keywordp( key ) ) {
         for ( struct cons_pointer next = store;
               nilp( result ) && consp( next );
               next = pointer2cell( next ).payload.cons.cdr ) {
@@ -73,7 +74,7 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
         debug_print_object( key, DEBUG_BIND );
         debug_print( L"` is a ", DEBUG_BIND );
         debug_print_object( c_type( key ), DEBUG_BIND );
-        debug_print( L", not a SYMB", DEBUG_BIND );
+        debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
     }
 
     return result;
@@ -91,6 +92,11 @@ struct cons_pointer c_assoc( struct cons_pointer key,
                             struct cons_pointer store ) {
     struct cons_pointer result = NIL;
 
+    debug_print( L"c_assoc; key is `", DEBUG_BIND);
+    debug_print_object( key, DEBUG_BIND);
+    debug_print( L"`\n", DEBUG_BIND);
+
+    if (consp(store)) {
         for ( struct cons_pointer next = store;
              consp( next ); next = pointer2cell( next ).payload.cons.cdr ) {
             struct cons_space_object entry =
@@ -101,6 +107,13 @@ struct cons_pointer c_assoc( struct cons_pointer key,
                 break;
             }
         }
+    } else if (vectorpointp( store)) {
+        result = assoc_in_map( key, store);
+    }
+
+    debug_print( L"c_assoc returning ", DEBUG_BIND);
+    debug_print_object( result, DEBUG_BIND);
+    debug_println( DEBUG_BIND);
 
     return result;
 }
@@ -110,15 +123,29 @@ struct cons_pointer c_assoc( struct cons_pointer key,
  * with this key/value pair added to the front.
  */
 struct cons_pointer
-bind( struct cons_pointer key, struct cons_pointer value,
+    set( struct cons_pointer key, struct cons_pointer value,
         struct cons_pointer store ) {
-    debug_print( L"Binding ", DEBUG_BIND );
+    struct cons_pointer result = NIL;
+
+    debug_print( L"set: binding `", DEBUG_BIND );
     debug_print_object( key, DEBUG_BIND );
-    debug_print( L" to ", DEBUG_BIND );
+    debug_print( L"` to `", DEBUG_BIND );
     debug_print_object( value, DEBUG_BIND );
+    debug_print( L"` in store ", DEBUG_BIND );
+    debug_dump_object( store, DEBUG_BIND);
     debug_println( DEBUG_BIND );
 
-    return make_cons( make_cons( key, value ), store );
+    if (nilp( store) || consp(store)) {
+        result = make_cons( make_cons( key, value ), store );
+    } else if (vectorpointp( store)) {
+        result = bind_in_map( store, key, value);
+    }
+
+    debug_print( L"set returning ", DEBUG_BIND);
+    debug_print_object( result, DEBUG_BIND);
+    debug_println( DEBUG_BIND);
+
+    return result;
 }
 
 /**
@@ -131,11 +158,19 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) {
     debug_print( L"Entering deep_bind\n", DEBUG_BIND );
     struct cons_pointer old = oblist;
 
-    oblist = bind( key, value, oblist );
+    debug_print( L"deep_bind: binding `", DEBUG_BIND );
+    debug_print_object( key, DEBUG_BIND );
+    debug_print( L"` to ", DEBUG_BIND );
+    debug_print_object( value, DEBUG_BIND );
+    debug_println( DEBUG_BIND );
+
+    oblist = set( key, value, oblist );
     inc_ref( oblist );
     dec_ref( old );
 
-    debug_print( L"Leaving deep_bind\n", DEBUG_BIND );
+    debug_print( L"deep_bind returning ", DEBUG_BIND );
+    debug_print_object( oblist, DEBUG_BIND );
+    debug_println( DEBUG_BIND );
 
     return oblist;
 }
@@ -153,7 +188,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
         /*
          * not currently bound
          */
-        result = bind( key, NIL, environment );
+        result = set( key, NIL, environment );
     }
 
     return result;

src/ops/intern.h

@@ -28,7 +28,7 @@ struct cons_pointer c_assoc( struct cons_pointer key,
 struct cons_pointer internedp( struct cons_pointer key,
                                struct cons_pointer environment );
 
-struct cons_pointer bind( struct cons_pointer key,
+struct cons_pointer set( struct cons_pointer key,
                          struct cons_pointer value,
                          struct cons_pointer store );
 

src/ops/lispops.c

@@ -31,10 +31,13 @@
 #include "equal.h"
 #include "integer.h"
 #include "intern.h"
+#include "io.h"
 #include "lispops.h"
+#include "map.h"
 #include "print.h"
 #include "read.h"
 #include "stack.h"
+#include "vectorspace.h"
 
 /*
  * also to create in this section:
@@ -46,32 +49,6 @@
  * and others I haven't thought of yet.
  */
 
-/**
- * Implementation of car in C. If arg is not a cons, does not error but returns nil.
- */
-struct cons_pointer c_car( struct cons_pointer arg ) {
-    struct cons_pointer result = NIL;
-
-    if ( consp( arg ) ) {
-        result = pointer2cell( arg ).payload.cons.car;
-    }
-
-    return result;
-}
-
-/**
- * Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
- */
-struct cons_pointer c_cdr( struct cons_pointer arg ) {
-    struct cons_pointer result = NIL;
-
-    if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) {
-        result = pointer2cell( arg ).payload.cons.cdr;
-    }
-
-    return result;
-}
-
 
 /**
  * Useful building block; evaluate this single form in the context of this
@@ -231,7 +208,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
             struct cons_pointer name = c_car( names );
             struct cons_pointer val = frame->arg[i];
 
-            new_env = bind( name, val, new_env );
+            new_env = set( name, val, new_env );
             log_binding( name, val );
 
             names = c_cdr( names );
@@ -256,7 +233,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
             }
         }
 
-        new_env = bind( names, vals, new_env );
+        new_env = set( names, vals, new_env );
         inc_ref( new_env );
     }
 
@@ -313,6 +290,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
             /* just pass exceptions straight back */
             result = fn_pointer;
             break;
+
             case FUNCTIONTV:
             {
                 struct cons_pointer exep = NIL;
@@ -333,6 +311,15 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 }
             }
             break;
+
+            case KEYTV:
+            result = c_assoc( fn_pointer,
+                             eval_form(frame,
+                                       frame_pointer,
+                                       c_car( c_cdr( frame->arg[0])),
+                                       env));
+            break;
+
             case LAMBDATV:
             {
                 struct cons_pointer exep = NIL;
@@ -352,6 +339,20 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 }
             }
             break;
+
+            case VECTORPOINTTV:
+            switch ( pointer_to_vso(fn_pointer)->header.tag.value) {
+                case MAPTV:
+                /* \todo: if arg[0] is a CONS, treat it as a path */
+                result = c_assoc( eval_form(frame,
+                                            frame_pointer,
+                                            c_car( c_cdr( frame->arg[0])),
+                                            env),
+                                 fn_pointer);
+                break;
+            }
+            break;
+
             case NLAMBDATV:
             {
                 struct cons_pointer next_pointer =
@@ -368,6 +369,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 }
             }
             break;
+
             case SPECIALTV:
             {
                 struct cons_pointer next_pointer =
@@ -377,9 +379,8 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                     result = next_pointer;
                 } else {
                     result =
-                            ( *fn_cell.payload.
+                        ( *fn_cell.payload.special.
-                              special.executable ) ( get_stack_frame
+                         executable ) ( get_stack_frame( next_pointer ),
-                                                     ( next_pointer ),
                                        next_pointer, env );
                     debug_print( L"Special form returning: ", DEBUG_EVAL );
                     debug_print_object( result, DEBUG_EVAL );
@@ -388,6 +389,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
                 }
             }
             break;
+
             default:
             {
                 int bs = sizeof( wchar_t ) * 1024;
@@ -411,24 +413,6 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
     return result;
 }
 
-
-/**
- * Get the Lisp type of the single argument.
- * @param pointer a pointer to the object whose type is requested.
- * @return As a Lisp string, the tag of the object which is at that pointer.
- */
-struct cons_pointer c_type( struct cons_pointer pointer ) {
-    struct cons_pointer result = NIL;
-    struct cons_space_object cell = pointer2cell( pointer );
-
-    for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
-        result = make_string( ( wchar_t ) cell.tag.bytes[i], result );
-    }
-
-    return result;
-}
-
-
 /**
  * Function; evaluate the expression which is the first argument in the frame;
  * further arguments are ignored.
@@ -460,9 +444,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
 
     switch ( cell.tag.value ) {
         case CONSTV:
-            {
                 result = c_apply( frame, frame_pointer, env );
-            }
             break;
 
         case SYMBOLTV:
@@ -690,11 +672,12 @@ lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer,
         case CONSTV:
             result = cell.payload.cons.car;
             break;
-        case READTV:
-            result = make_string( fgetwc( cell.payload.stream.stream ), NIL );
-            break;
         case NILTV:
             break;
+        case READTV:
+            result =
+                make_string( url_fgetwc( cell.payload.stream.stream ), NIL );
+            break;
         case STRINGTV:
             result = make_string( cell.payload.string.character, NIL );
             break;
@@ -733,15 +716,15 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
         case CONSTV:
             result = cell.payload.cons.cdr;
             break;
+        case NILTV:
+            break;
         case READTV:
-            fgetwc( cell.payload.stream.stream );
+            url_fgetwc( cell.payload.stream.stream );
             result = frame->arg[0];
             break;
         case STRINGTV:
             result = cell.payload.string.cdr;
             break;
-        case NILTV:
-            break;
         default:
             result =
                 throw_exception( c_string_to_lisp_string
@@ -752,6 +735,22 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer,
     return result;
 }
 
+/**
+ * Function: return, as an integer, the length of the sequence indicated by
+ * the first argument, or zero if it is not a sequence.
+ *
+ * * (length any)
+ *
+ * @param frame my stack_frame.
+ * @param frame_pointer a pointer to my stack_frame.
+ * @param env my environment (ignored).
+ * @return the length of `any`, if it is a sequence, or zero otherwise.
+ */
+struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer frame_pointer,
+            struct cons_pointer env ) {
+    return make_integer( c_length( frame->arg[0]), NIL);
+}
+
 /**
  * Function; look up the value of a `key` in a `store`.
  *
@@ -839,7 +838,8 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
 #ifdef DEBUG
     debug_print( L"entering lisp_read\n", DEBUG_IO );
 #endif
-    FILE *input = stdin;
+    URL_FILE *input;
+
     struct cons_pointer in_stream = readp( frame->arg[0] ) ?
         frame->arg[0] : get_default_stream( true, env );
 
@@ -848,6 +848,8 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
         debug_dump_object( in_stream, DEBUG_IO );
         input = pointer2cell( in_stream ).payload.stream.stream;
         inc_ref( in_stream );
+    } else {
+        input = file_to_url_file( stdin );
     }
 
     struct cons_pointer result = read( frame, frame_pointer, input );
@@ -856,8 +858,11 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
 
     if ( readp( in_stream ) ) {
         dec_ref( in_stream );
+    } else {
+        free( input );
     }
 
+
     return result;
 }
 
@@ -878,7 +883,9 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) {
                 result = make_string( o.payload.string.character, result );
                 break;
             case SYMBOLTV:
-                result = make_symbol( o.payload.string.character, result );
+                result =
+                    make_symbol_or_key( o.payload.string.character, result,
+                                        SYMBOLTAG );
                 break;
         }
     }
@@ -922,7 +929,7 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
             struct cons_pointer env ) {
     debug_print( L"Entering print\n", DEBUG_IO );
     struct cons_pointer result = NIL;
-    FILE *output = stdout;
+    URL_FILE *output;
     struct cons_pointer out_stream = writep( frame->arg[1] ) ?
         frame->arg[1] : get_default_stream( false, env );
 
@@ -931,6 +938,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
         debug_dump_object( out_stream, DEBUG_IO );
         output = pointer2cell( out_stream ).payload.stream.stream;
         inc_ref( out_stream );
+    } else {
+        output = file_to_url_file( stderr );
     }
 
     debug_print( L"lisp_print: about to print\n", DEBUG_IO );
@@ -943,6 +952,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer,
 
     if ( writep( out_stream ) ) {
         dec_ref( out_stream );
+    } else {
+        free( output );
     }
 
     return result;
@@ -1148,7 +1159,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
 
     struct cons_pointer input = get_default_stream( true, env );
     struct cons_pointer output = get_default_stream( false, env );
-    FILE *os = pointer2cell( output ).payload.stream.stream;
+    URL_FILE *os = pointer2cell( output ).payload.stream.stream;
     struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" );
     struct cons_pointer old_oblist = oblist;
     struct cons_pointer new_env = env;
@@ -1165,7 +1176,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
      * print as parent.
      */
     while ( readp( input ) && writep( output )
-            && !feof( pointer2cell( input ).payload.stream.stream ) ) {
+            && !url_feof( pointer2cell( input ).payload.stream.stream ) ) {
         /* OK, here's a really subtle problem: because lists are immutable, anything
          * bound in the oblist subsequent to this function being invoked isn't in the
          * environment. So, for example, changes to *prompt* or *log* made in the oblist
@@ -1203,7 +1214,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
         inc_ref( expr );
 
         if ( exceptionp( expr )
-             && feof( pointer2cell( input ).payload.stream.stream ) ) {
+             && url_feof( pointer2cell( input ).payload.stream.stream ) ) {
             /* suppress printing end of stream exception */
             break;
         }
@@ -1240,13 +1251,13 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
                                  struct cons_pointer env ) {
     struct cons_pointer result = NIL;
     struct cons_space_object cell = pointer2cell( frame->arg[0] );
-
+    struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" );
     switch ( cell.tag.value ) {
         case FUNCTIONTV:
-            result = cell.payload.function.source;
+            result = c_assoc( source_key, cell.payload.function.meta );
             break;
         case SPECIALTV:
-            result = cell.payload.special.source;
+            result = c_assoc( source_key, cell.payload.special.meta );
             break;
         case LAMBDATV:
             result = make_cons( c_string_to_lisp_symbol( L"lambda" ),
@@ -1282,7 +1293,7 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
                                   struct cons_pointer frame_pointer,
                                   struct cons_pointer env ) {
     debug_print( L"Entering print\n", DEBUG_IO );
-    FILE *output = stdout;
+    URL_FILE *output;
     struct cons_pointer out_stream = writep( frame->arg[1] ) ?
         frame->arg[1] : get_default_stream( false, env );
 
@@ -1291,11 +1302,17 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
         debug_dump_object( out_stream, DEBUG_IO );
         output = pointer2cell( out_stream ).payload.stream.stream;
         inc_ref( out_stream );
+    } else {
+        output = file_to_url_file( stdout );
     }
+
     dump_object( output, frame->arg[0] );
+    url_fputws( L"\n", output );
 
     if ( writep( out_stream ) ) {
         dec_ref( out_stream );
+    } else {
+        free( output );
     }
 
     return frame->arg[0];

src/ops/lispops.h

@@ -19,26 +19,13 @@
  * Licensed under GPL version 2.0, or, at your option, any later version.
  */
 
+#ifndef __psse_lispops_h
+#define __psse_lispops_h
+
 /*
  * utilities
  */
 
-/**
- * Get the Lisp type of the single argument.
- * @param pointer a pointer to the object whose type is requested.
- * @return As a Lisp string, the tag of the object which is at that pointer.
- */
-struct cons_pointer c_type( struct cons_pointer pointer );
-
-/**
- * Implementation of car in C. If arg is not a cons, does not error but returns nil.
- */
-struct cons_pointer c_car( struct cons_pointer arg );
-
-/**
- * Implementation of cdr in C. If arg is not a cons, does not error but returns nil.
- */
-struct cons_pointer c_cdr( struct cons_pointer arg );
 
 struct cons_pointer c_reverse( struct cons_pointer arg );
 
@@ -98,7 +85,9 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
 struct cons_pointer lisp_lambda( struct stack_frame *frame,
                                  struct cons_pointer frame_pointer,
                                  struct cons_pointer env );
-
+struct cons_pointer lisp_length( struct stack_frame *frame,
+                                struct cons_pointer frame_pointer,
+            struct cons_pointer env );
 /**
  * Construct an interpretable special form.
  *
@@ -205,3 +194,5 @@ struct cons_pointer lisp_source( struct stack_frame *frame,
 struct cons_pointer lisp_inspect( struct stack_frame *frame,
                                   struct cons_pointer frame_pointer,
                                   struct cons_pointer env );
+
+#endif

src/ops/meta.c

@@ -0,0 +1,45 @@
+/*
+ * meta.c
+ *
+ * Get metadata from a cell which has it.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include "conspage.h"
+#include "debug.h"
+
+/**
+ * Function: get metadata describing my first argument.
+ *
+ * * (metadata any)
+ *
+ * @return a pointer to the metadata of my first argument, or nil if none.
+ */
+struct cons_pointer lisp_metadata( struct stack_frame *frame,
+                                   struct cons_pointer frame_pointer,
+                                   struct cons_pointer env ) {
+    debug_print( L"lisp_metadata: entered\n", DEBUG_EVAL );
+    debug_dump_object( frame->arg[0], DEBUG_EVAL );
+    struct cons_pointer result = NIL;
+    struct cons_space_object cell = pointer2cell( frame->arg[0] );
+
+    switch ( cell.tag.value ) {
+        case FUNCTIONTV:
+            result = cell.payload.function.meta;
+            break;
+        case SPECIALTV:
+            result = cell.payload.special.meta;
+            break;
+        case READTV:
+        case WRITETV:
+            result = cell.payload.stream.meta;
+            break;
+    }
+
+    return make_cons( make_cons( c_string_to_lisp_keyword( L"type" ),
+                                 c_type( frame->arg[0] ) ), result );
+
+//  return result;
+}

src/ops/meta.h

@@ -0,0 +1,18 @@
+/*
+ * meta.h
+ *
+ * Get metadata from a cell which has it.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#ifndef __psse_meta_h
+#define __psse_meta_h
+
+
+struct cons_pointer lisp_metadata( struct stack_frame *frame,
+                                   struct cons_pointer frame_pointer,
+                                   struct cons_pointer env );
+
+#endif

src/time/psse_time.c

@@ -0,0 +1,107 @@
+/*
+ * psse_time.c
+ *
+ * Bare bones of PSSE time. See issue #16.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+/*
+ * wide characters
+ */
+#include <wchar.h>
+#include <wctype.h>
+
+#include "conspage.h"
+#include "consspaceobject.h"
+#include "integer.h"
+#include "psse_time.h"
+#define _GNU_SOURCE
+
+#define seconds_per_year 31557600L
+
+/**
+ * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before
+ * the UNIX epoch; the value in microseconds will break the C reader.
+ */
+unsigned __int128 epoch_offset = ((__int128)(seconds_per_year * 1000000000L) *
+                                  (__int128)(14L * 1000000000L));
+
+/**
+ * Return the UNIX time value which represents this time, if it falls within
+ * the period representable in UNIX time, or zero otherwise.
+ */
+long int lisp_time_to_unix_time(struct cons_pointer t) {
+    long int result = 0;
+
+    if (timep( t)) {
+        unsigned __int128 value = pointer2cell(t).payload.time.value;
+
+        if (value > epoch_offset) { // \todo && value < UNIX time rollover
+            result = ((value - epoch_offset) / 1000000000);
+        }
+    }
+
+    return result;
+}
+
+unsigned __int128 unix_time_to_lisp_time( time_t t) {
+    unsigned __int128 result = epoch_offset + (t * 1000000000);
+
+    return result;
+}
+
+struct cons_pointer make_time( struct cons_pointer integer_or_nil) {
+    struct cons_pointer pointer = allocate_cell( TIMETAG );
+    struct cons_space_object *cell = &pointer2cell( pointer );
+
+    if (integerp(integer_or_nil)) {
+        cell->payload.time.value = pointer2cell(integer_or_nil).payload.integer.value;
+        // \todo: if integer is a bignum, deal with it.
+    } else {
+        cell->payload.time.value = unix_time_to_lisp_time( time(NULL));
+    }
+
+    return pointer;
+}
+
+/**
+ * Function; return a time representation of the first argument in the frame;
+ * further arguments are ignored.
+ *
+ * * (time integer_or_nil)
+ *
+ * @param frame my stack_frame.
+ * @param frame_pointer a pointer to my stack_frame.
+ * @param env my environment.
+ * @return a lisp time; if `integer_or_nil` is an integer, return a time which
+ * is that number of microseconds after the notional big bang; else the current
+ * time.
+ */
+struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env ) {
+    return make_time( frame->arg[0]);
+}
+
+/**
+ * This is temporary, for bootstrapping.
+ */
+struct cons_pointer time_to_string( struct cons_pointer pointer) {
+    struct cons_pointer result = NIL;
+    long int t = lisp_time_to_unix_time(pointer);
+
+    if ( t != 0) {
+        char * bytes = ctime(&t);
+        int l = strlen(bytes) + 1;
+        wchar_t buffer[ l];
+
+        mbstowcs( buffer, bytes, l);
+        result = c_string_to_lisp_string( buffer);
+    }
+
+    return result;
+}

src/time/psse_time.h

@@ -0,0 +1,20 @@
+/*
+ * psse_time.h
+ *
+ * Bare bones of PSSE time. See issue #16.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#ifndef __psse_time_h
+#define __psse_time_h
+
+#define _GNU_SOURCE
+#include "consspaceobject.h"
+
+struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer,
+           struct cons_pointer env );
+struct cons_pointer time_to_string( struct cons_pointer pointer);
+
+#endif

src/utils.c

@@ -0,0 +1,33 @@
+/*
+ * utils.c
+ *
+ * little generally useful functions which aren't in any way special to PSSE.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#include <ctype.h>
+#include <stdlib.h>
+#include <string.h>
+
+
+int index_of( char c, const char *s ) {
+    int i;
+
+    for ( i = 0; s[i] != c && s[i] != 0; i++ );
+
+    return s[i] == c ? i : -1;
+}
+
+char *trim( char *s ) {
+    int i;
+
+    for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0;
+          i-- ) {
+        s[i] = '\0';
+    }
+    for ( i = 0; s[i] != '\0' && ( isblank( s[i] ) || iscntrl( s[i] ) ); i++ );
+
+    return ( char * ) &s[i];
+}

src/utils.h

@@ -0,0 +1,17 @@
+/*
+ * utils.h
+ *
+ * little generally useful functions which aren't in any way special to PSSE.
+ *
+ * (c) 2019 Simon Brooke <simon@journeyman.cc>
+ * Licensed under GPL version 2.0, or, at your option, any later version.
+ */
+
+#ifndef __psse_utils_h
+#define __psse_utils_h
+
+int index_of( char c, const char *s );
+
+char *trim( char *s );
+
+#endif

unit-tests/bignum-print.sh

@@ -18,17 +18,6 @@ else
     exit 1
 fi
 
-echo -n "checking no bignum was created: "
-grep -v 'BIGNUM!' psse.log > /dev/null
-if [ $? -eq "0" ]
-then
-    echo "OK"
-else
-    echo "Fail"
-    exit 1
-fi
-
-
 
 #####################################################################
 # right on the boundary
@@ -48,17 +37,6 @@ else
     exit 1
 fi
 
-echo -n "checking no bignum was created: "
-grep -v 'BIGNUM!' psse.log > /dev/null
-if [ $? -eq "0" ]
-then
-    echo "OK"
-else
-    echo "Fail"
-    exit 1
-fi
-
-
 
 #####################################################################
 # definitely a bignum
@@ -79,16 +57,10 @@ else
 fi
 
 
-echo -n "checking a bignum was created: "
+# Currently failing from here on, but it's failing in read because of
-grep 'BIGNUM!' psse.log > /dev/null
+# the multiply bug. We know printing blows up at the 3 cell boundary
-if [ $? -eq "0" ]
+# because `lisp/scratchpad2.lisp` constructs a 3 cell bignum by
-then
+# repeated addition.
-    echo "OK"
-else
-    echo "Fail"
-    exit 1
-fi
-
 #####################################################################
 # Just on the three cell boundary
 expected='1329227995784915872903807060280344576'
@@ -103,7 +75,7 @@ if [ "${expected}" = "${actual}" ]
 then
     echo "OK"
 else
-    echo "Fail: expected '${expected}', got '${actual}'"
+    echo "Fail: expected '${expected}', \n           got '${actual}'"
     exit 1
 fi
 

unit-tests/eval-quote-symbol.sh

@@ -1,6 +1,6 @@
 #!/bin/bash
 
-expected='<Special form>'
+expected='<Special form: ((:primitive . t) (:name . cond))>'
 actual=`echo "(eval 'cond)" | target/psse | tail -1`
 
 if [ "${expected}" = "${actual}" ]

unit-tests/map.sh

@@ -0,0 +1,89 @@
+#!/bin/bash
+
+#####################################################################
+# Create an empty map using map notation
+expected='{}'
+actual=`echo "$expected" | target/psse | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+#####################################################################
+# Create an empty map using make-map
+expected='{}'
+actual=`echo "(make-map)" | target/psse | tail -1`
+
+echo -n "Empty map using (make-map): "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+#####################################################################
+# Create a map using map notation: order of keys in output is not
+# significant at this stage, but in the long term should be sorted
+# alphanumerically
+expected='{:two 2, :one 1, :three 3}'
+actual=`echo "{:one 1 :two 2 :three 3}" | target/psse | tail -1`
+
+echo -n "Map using map notation: "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+#####################################################################
+# Create a map using make-map: order of keys in output is not
+# significant at this stage, but in the long term should be sorted
+# alphanumerically
+expected='{:two 2, :one 1, :three 3}'
+actual=`echo "(make-map '((:one . 1)(:two . 2)(:three . 3)))" | target/psse | tail -1`
+
+echo -n "Map using (make-map): "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+#####################################################################
+# Keyword in function position
+expected='2'
+actual=`echo "(:two {:one 1 :two 2 :three 3})" | target/psse | tail -1`
+
+echo -n "Keyword in function position: "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi
+
+
+#####################################################################
+# Map in function position
+expected='2'
+actual=`echo "({:one 1 :two 2 :three 3} :two)" | target/psse | tail -1`
+
+echo -n "Map in function position: "
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

unit-tests/slurp.sh

@@ -0,0 +1,16 @@
+#!/bin/bash
+
+tmp=hi.$$
+echo "Hello, there." > ${tmp}
+expected='"Hello, there.'
+actual=`echo "(slurp (open \"${tmp}\"))" | target/psse | tail -2 | head -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+    rm ${tmp}
+    exit 0
+else
+    echo "Fail: expected '$expected', got '$actual'"
+    exit 1
+fi

unit-tests/wide-character.sh

@@ -0,0 +1,12 @@
+#!/bin/bash
+
+expected='"λάμ(β)δα"'
+actual=`echo $expected | target/psse | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+    echo "OK"
+else
+    echo "Fail: expected '${expected}', got '${actual}'"
+    exit 1
+fi

where-does-it-break.sh

@@ -1,29 +0,0 @@
-#!/bin/bash
-
-# Not really a unit test, but a check to see where bignum addition breaks
-
-broken=0
-i=11529215046068469750
-# we've already proven we can successfullu get up to here
-increment=1
-
-while [ $broken -eq "0" ]
-do
-  expr="(+ $i $increment)"
-  # Use sbcl as our reference implementation...
-  expected=`echo "$expr" | sbcl --noinform | grep -v '*'`
-  actual=`echo "$expr" | target/psse | tail -1 | sed 's/\,//g'`
-
-  echo -n "adding $increment to $i: "
-
-  if [ "${expected}" = "${actual}" ]
-  then
-      echo "OK"
-  else
-      echo "Fail: expected '${expected}', got '${actual}'"
-      broken=1
-      exit 1
-  fi
-
-  i=$expected
-done