print.c

Go to the documentation of this file.

/*
 * print.c
 *
 * First pass at a printer, for bootstrapping.
 *
 * (c) 2017 Simon Brooke <simon@journeyman.cc>
 * Licensed under GPL version 2.0, or, at your option, any later version.
 */
 
#include <ctype.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
 * wide characters
 */
#include <wchar.h>
#include <wctype.h>
 
#include "arith/integer.h"
#include "debug.h"
#include "io/io.h"
#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/hashmap.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
#include "ops/intern.h"
#include "time/psse_time.h"
 
/**
 * 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( URL_FILE *output, struct cons_pointer 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' ) {
            url_fputwc( c, output );
        }
        pointer = cell->payload.string.cdr;
    }
}
 
/**
 * print all the characters in the string indicated by `pointer` onto
 * the stream at this `output`, prepending and appending double quote
 * characters.
 */
void print_string( URL_FILE *output, struct cons_pointer pointer ) {
    url_fputwc( btowc( '"' ), output );
    print_string_contents( output, pointer );
    url_fputwc( btowc( '"' ), output );
}
 
/**
 * Print a single list cell (cons cell) indicated by `pointer` to the
 * stream indicated by `output`. if `initial_space` is `true`, prepend
 * a space character.
 */
void
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 ) {
                url_fputwc( btowc( ' ' ), output );
            }
            print( output, cell->payload.cons.car );
 
            print_list_contents( output, cell->payload.cons.cdr, true );
            break;
        case NILTV:
            break;
        default:
            url_fwprintf( output, L" . " );
            print( output, pointer );
    }
}
 
void print_list( URL_FILE *output, struct cons_pointer pointer ) {
    url_fputws( L"(", output );
    print_list_contents( output, pointer, false );
    url_fputws( L")", output );
}
 
void print_map( URL_FILE *output, struct cons_pointer map ) {
    if ( hashmapp( map ) ) {
        struct vector_space_object *vso = pointer_to_vso( map );
 
        url_fputwc( btowc( '{' ), output );
 
        for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks );
              ks = c_cdr( ks ) ) {
            struct cons_pointer key = c_car( ks );
            print( output, key );
            url_fputwc( btowc( ' ' ), output );
            print( output, hashmap_get( map, key ) );
 
            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 = pointer_to_vso( pointer );
    switch ( vso->header.tag.value ) {
        case HASHTV:
            print_map( output, pointer );
            break;
        case STACKFRAMETV:
            dump_stack_trace( output, pointer );
            break;
            // \todo: others.
        default:
            fwprintf( stderr, L"Unrecognised vector-space type '%d'\n",
                      vso->header.tag.value );
    }
}
 
/**
 * 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( URL_FILE *output, struct cons_pointer pointer ) {
    struct cons_space_object cell = pointer2cell( pointer );
    char *buffer;
 
    /*
     * Because tags have values as well as bytes, this if ... else if
     * statement can ultimately be replaced by a switch, which will be neater.
     */
    switch ( cell.tag.value ) {
        case CONSTV:
            print_list( output, pointer );
            break;
        case EXCEPTIONTV:
            url_fputws( L"\nException: ", output );
            dump_stack_trace( output, pointer );
            break;
        case FUNCTIONTV:
            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 );
            print_string_contents( output, s );
            dec_ref( s );
            break;
        case KEYTV:
            url_fputws( L":", output );
            print_string_contents( output, pointer );
            break;
        case LAMBDATV:{
                url_fputws( L"<Anonymous Function: ", output );
                struct cons_pointer to_print =
                    make_cons( c_string_to_lisp_symbol( L"\u03bb" ),
                               make_cons( cell.payload.lambda.args,
                                          cell.payload.lambda.body ) );
 
                print( output, to_print );
 
                dec_ref( to_print );
                url_fputwc( L'>', output );
            }
            break;
        case NILTV:
            url_fwprintf( output, L"nil" );
            break;
        case NLAMBDATV:{
                url_fputws( L"<Anonymous Special Form: ", output );
                struct cons_pointer to_print =
                    make_cons( c_string_to_lisp_symbol( L"n\u03bb" ),
                               make_cons( cell.payload.lambda.args,
                                          cell.payload.lambda.body ) );
 
                print( output, to_print );
 
                dec_ref( to_print );
                url_fputwc( L'>', output );
            }
            break;
        case RATIOTV:
            print( output, cell.payload.ratio.dividend );
            url_fputws( L"/", output );
            print( output, cell.payload.ratio.divisor );
            break;
        case READTV:
            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.
             * As soon as I have working vector space I'll use a special purpose
             * vector space object */
            buffer = ( char * ) malloc( 24 );
            memset( buffer, 0, 24 );
            /* format it really long, then clear the trailing zeros */
            sprintf( buffer, "%-.23Lg", cell.payload.real.value );
            if ( strchr( buffer, '.' ) != NULL ) {
                for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) {
                    buffer[i] = '\0';
                }
            }
            url_fwprintf( output, L"%s", buffer );
            free( buffer );
            break;
        case STRINGTV:
            print_string( output, pointer );
            break;
        case SYMBOLTV:
            print_string_contents( output, pointer );
            break;
        case SPECIALTV:
            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, cell.payload.time.value );
            url_fputwc( L'>', output );
            break;
        case TRUETV:
            url_fwprintf( output, L"t" );
            break;
        case VECTORPOINTTV:
            print_vso( output, pointer );
            break;
        case WRITETV:
            url_fwprintf( output, L"<Output stream: " );
            print( output, cell.payload.stream.meta );
            url_fputwc( L'>', output );
            break;
        default:
            fwprintf( stderr,
                      L"Error: Unrecognised tag value %d (%4.4s)\n",
                      cell.tag.value, &cell.tag.bytes[0] );
            // dump_object( stderr, pointer);
            break;
    }
 
    return pointer;
}
 
/**
 * Function; print one complete lisp expression and return NIL. If write-stream is specified and
 * is a write stream, then print to that stream, else  the stream which is the value of
 * `*out*` in the environment.
 *
 * * (print expr)
 * * (print expr write-stream)
 *
 * @param frame my stack_frame.
 * @param frame_pointer a pointer to my stack_frame.
 * @param env my environment (from which the stream may be extracted).
 * @return NIL.
 */
struct cons_pointer
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;
    URL_FILE *output;
    struct cons_pointer out_stream = writep( frame->arg[1] ) ?
        frame->arg[1] : get_default_stream( false, env );
 
    if ( writep( out_stream ) ) {
        debug_print( L"lisp_print: setting output stream\n", DEBUG_IO );
        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 );
    debug_dump_object( frame->arg[0], DEBUG_IO );
 
    result = print( output, frame->arg[0] );
 
    debug_print( L"lisp_print returning\n", DEBUG_IO );
    debug_dump_object( result, DEBUG_IO );
 
    if ( writep( out_stream ) ) {
        dec_ref( out_stream );
    } else {
        free( output );
    }
 
    return result;
}
 
void println( URL_FILE *output ) {
    url_fputws( L"\n", output );
}
 
/**
 * @brief `(prinln out-stream)`: Print a new line character to `out-stream`, if
 * it is specified and is an output stream, else to `*out*`.
 * 
 * @param frame 
 * @param frame_pointer 
 * @param env 
 * @return `nil`
 */
struct cons_pointer
lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
              struct cons_pointer env ) {
    URL_FILE *output;
    struct cons_pointer out_stream = writep( frame->arg[1] ) ?
        frame->arg[1] : get_default_stream( false, env );
 
    if ( writep( out_stream ) ) {
        output = pointer2cell( out_stream ).payload.stream.stream;
        inc_ref( out_stream );
    } else {
        output = file_to_url_file( stderr );
    }
 
    println( output );
 
    if ( writep( out_stream ) ) {
        dec_ref( out_stream );
    } else {
        free( output );
    }
 
    return NIL;
}