ulambda/bootstrap/libprebirth.js

/**
 * Transition library for Prebirth
 *
 *  Copyright (C) 2017 Mike Gerwitz
 *
 *  This file is part of Ulambda Scheme.
 *
 *  Ulambda Scheme is free software: you can redistribute it and/or modify
 *  it under the terms of the GNU Affero General Public License as
 *  published by the Free Software Foundation, either version 3 of the
 *  License, or (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU Affero General Public License
 *  along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *
 * THIS IS TEMPORARY CODE that will be REWRITTEN IN REBIRTH LISP ITSELF after
 * a very basic bootstrap is complete.  It is retained as an important
 * artifact for those who wish to build Ulambda Scheme from scratch without
 * using another version of Ulambda itself.  This is called "self-hosting".
 *
 * For the actual Prebirth compiler before self-hosting, see `prebirth.js'
 * in the same directory as this file.
 *
 * This library is intended to be concatenated with the compiled
 * Prebirth Lisp to ease the transition by providing a set of functions that
 * will Just Work™ without a Prebirth Lisp implementation.  They will be
 * removed as they are rewritten in Prebirth Lisp.
 *
 * By convention, everything is prefixed with `js:' in Prebirth (not `es:',
 * because we're using JavaScript-specific features).  For character
 * transformation rules, see `Compiler#_idFromName' in `prebirth.js'.
 *
 * These implementations are largely flawed in some manner, but that's okay,
 * because they do their job.  Some flaws are noted.
 */

const $$$h$t  = true;
const $$$h$f  = false;

const $$symbol$q$$7$ = ( a, b ) => ( ( typeof a === 'symbol' ) && ( a === b ) );

const argToArr = args => Array.prototype.slice.call( args );

function $$list() { return argToArr( arguments ); }

const _error = str =>
{
    throw Error( str );
}

const _assertPair = xs =>
{
    _assertList( xs );

    if ( xs.length === 0 ) {
        throw TypeError( "expecting pair" );
    }

    return true;
}

const _assertList = xs =>
{
    if ( !Array.isArray( xs ) ) {
        throw TypeError( "expecting list" );
    }

    return true;
}

// only false (#f in Scheme) is non-true
const _truep = x => x !== false;

// ignore obj for now
const $$error = ( msg, obj ) => _error( msg );

const $$cons = ( item, list ) => _assertList( list ) && [ item ].concat( list )
const $$car  = xs => _assertPair( xs ) && xs[ 0 ];
const $$cdr  = xs => _assertPair( xs ) && xs.slice( 1 );

// warning: blows up if any items are non-lists, whereas the proper RnRS
// implementation will set the cdr to the final item even if it's not a pair
function $$append()
{
    return argToArr( arguments )
        .reduce( ( xs, x ) => xs.concat( _assertList( x ) && x ) );
}

const $$list$7$ = xs => Array.isArray( xs );
const $$pair$7$ = xs => Array.isArray( xs ) && ( xs.length > 0 );


// R7RS string
const $$substring       = ( s, start, end ) => s.substring( start, end );
const $$string$_$length = s => s.length;
const $$string$q$$7$    = ( x, y ) => x === y;
const $$string$_$ref    = ( s, i ) => s[ i ]
                              || _error( `value out of range: ${i}`);

function $$string$_$append()
{
    return argToArr( arguments ).join( "" );
}

// R7RS math
function $$$p$()
{
    return argToArr( arguments ).reduce( ( ( x, y ) => x + y ), 0 );
}
function $$$_$()
{
    const args  = argToArr( arguments );
    const first = args.shift();

    return args.reduce( ( ( x, y ) => x - y ), first );
}
const $$zero$7$ = x => x === 0;

// SRFI-1
// warning: fold here only supports one list
const $$fold = ( f, init, xs ) =>
    xs.reduce( ( prev, x ) => f( x, prev ), init );
// warning: map here uses the length of the first list, not the shortest
// (we implement this in ES for now so that we don't have to augment
// Prebirth Lisp to support the "rest" procedure definition syntax)
const $$map = ( f, ...xs ) =>
                  xs[ 0 ].map(
                      ( _, i ) => f.apply( null,
                                           xs.map( x => x[ i ] ) ) );


const $$es$regexp   = ( s, opts )    => new RegExp( s, opts );
const $$es$match    = ( r, s )       => s.match( r ) || false;
const $$es$replace  = ( r, repl, s ) => s.replace( r, repl );


// the variable __fsinit, if defined, can be used to stub the filesystem
const fsdata = ( typeof __fsinit !== 'undefined' ) ? __fsinit : {};

const fs = ( typeof require !== 'undefined' )
    ? require( 'fs' )
    : {
        readFileSync( path )
        {
            throw Error( `Cannot load ${path} (no fs module)` );
        },
    }

// file->string
const $$es$file$_$$g$string = ( path ) =>
{
    if ( fsdata[ path ] !== undefined ) {
       return fsdata[ path ];
    }

    return fsdata[ path ] = fs.readFileSync( path ).toString();
};


/** =============== end of libprebirth =============== **/