Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk1.iso/altsrc/articles/11162

Internet Message Format | 1994-08-23 | 29KB

Path: wupost!uhog.mit.edu!news.kei.com!travelers.mail.cornell.edu!newstand.syr.edu!galileo.cc.rochester.edu!ceas.rochester.edu!ceas.rochester.edu!not-for-mail
From: [e-mail] (Jeff Weisberg)
Newsgroups: alt.sources
Subject: jlisp interpreter part07 / 10
Followup-To: alt.sources.d
Date: 23 Aug 1994 11:08:00 -0400
Organization: University of Rochester School of Engineering and Applied Science
Lines: 1390
Message-ID: <[e-mail]>
References: <[e-mail]>
NNTP-Posting-Host: kirchoff.ee.rochester.edu


Archive-name: jlisp-1.03
Submitted-by: [e-mail]

#! /bin/sh
# 0. this is shell archive
# 1. Remove everything above the #! /bin/sh line
# 2. Save the resulting text in a file
# 3. Execute the file with /bin/sh (not csh)
# 4. Or use your favorite variant of unshar
# 5. To overwrite existing files use "sh -c"
#
# Created by: weisberg@ankara on Tue Aug 23 10:51:39 EDT 1994
#
# This is part 07

if test -f jlisp-1.03/src/port.c -a "$1" != "-c" ; then
    echo "will not overwrite jlisp-1.03/src/port.c"
else
    echo "    x - jlisp-1.03/src/port.c (7514 bytes)"
    sed 's/^X//' > jlisp-1.03/src/port.c << \CEST_TOUT
X
X/*
X    Copyright (c) 1994 Jeff Weisberg
X
X    see the file "License"
X*/
X
X#ifdef RCSID
Xstatic const char *const rcsid
X= "@(#)$Id: port.c,v 1.26 94/08/23 07:20:10 weisberg Exp Locker: weisberg $";
X#endif
X
X
X/* I/O ports */
X
X#include <jlisp.h>
X#include <stdio.h>
X#include <setjmp.h>
X#include <unistd.h>
X#include <fcntl.h>
X
Xtypedef struct {
X    void (*mark)(Obj);
X    int (*free)(Obj);
X    int (*print)(Obj,Obj,int);
X    Obj (*equal)(Obj, Obj);
X    int (*getc)(Obj);
X    void (*ungetc)(Obj,int);
X    void (*flush)(Obj);
X    void (*putc)(Obj,int);
X    void (*seek)(Obj, int);
X    Obj (*tell)(Obj);
X} PortDesc;
X
Xextern Obj sym_eof;
X
Xextern void mark0(), markcdr();
Xextern int free0();
Xextern Obj eqcdr();
X
Xvoid funreadc();
Xint  freadc(), freefile(), freepipe();
Xint strreadc();
Xvoid strunreadc();
Xvoid flflush(), flputc(), strputc();
Xvoid flseek(), strseek();
XObj fltell(), strtell();
X
XObj Fclose(Obj);
X
XPortDesc pdesc[] = {
X    {mark0, freefile, 0, eqcdr, freadc, funreadc, flflush, flputc, flseek, fltell },    /* std file */
X    {mark0, freepipe, 0, eqcdr, freadc, funreadc, flflush, flputc, flseek, fltell },    /* pipe */
X    {markcdr, free0,  0, eqcdr, strreadc, strunreadc, 0, strputc, strseek, strtell },    /* string input */
X    {0,0,0,0,0,0,0,0}
X};
X
X
X/* entries to vtbl table in jlisp.c */
Xvoid markport(Obj p){
X    void (*fnc)(Obj);
X    int t = CAR(p) >> 14;
X
X    fnc = pdesc[t].mark;
X
X    if(fnc) fnc(p);
X    else mark0(p);
X}
X
Xint freeport(Obj p){
X    int (*fnc)(Obj);
X    int t = CAR(p) >> 14;
X
X    fnc = pdesc[t].free;
X
X    if(fnc) return fnc(p);
X    else return free0(p);
X}
X
Xint prnport(Obj p, Obj s, int h){
X    int (*fnc)(Obj,Obj,int);
X    int t = CAR(p) >> 14;
X
X    fnc = pdesc[t].print;
X
X    if(fnc) return fnc(p, s, h);
X    else return 0;
X}
X
XObj eqport(Obj a, Obj b){
X    Obj (*fnc)(Obj,Obj);
X    int t = CAR(a) >> 14;
X
X    fnc = pdesc[t].equal;
X
X    if(fnc) return fnc(a, b);
X    else return eqcdr(a, b);
X}
X
X
X/* entries for port desc table (top of this file) */
Xint freefile(Obj a){
X
X    fclose( CFILEPTR( a ));
X    return 1;
X}
X
Xint freepipe(Obj a){
X
X    pclose( CFILEPTR( a ));
X    return 1;
X}
X
Xint freadc(Obj p){
X    return fgetc( CFILEPTR(p) );
X}
X
Xvoid funreadc(Obj p, int c){
X    ungetc(c, CFILEPTR(p));
X}
X
Xvoid flflush(Obj p){
X    fflush( CFILEPTR(p));
X}
X
Xvoid flputc(Obj p, int c){
X    fputc(c, CFILEPTR(p));
X}
X
Xvoid flseek(Obj p, int i){
X    fseek(CFILEPTR(p), i, SEEK_SET);
X}
X
XObj fltell(Obj p){
X    return MAKINT( ftell(CFILEPTR(p)));
X}
X
X/* string port code is now in string.c */
X
XObj openport(Obj a, char *mode, int m, char*fnc){
X    FILE*fp;
X    int p=0;
X
X    if(! STRINGP(a))
X        return jlerror(fnc, a, "WTA: filename expected");
X
X    if( CCHARS(a)[0] == '|'){
X        p = 1;
X        fp = popen( CCHARS(a)+1, mode);
X    }else
X        fp = fopen( CCHARS(a), mode);
X
X    if( !fp)
X        return IC_NIL;
X    return makport( fp, m + 4*p);    /* 4*p => subtype==pipe */
X}
X
X
XDEFUN("open:read", Fopenread,Sopenread, 1,1,1,0,
X      "(open:read filename) Open a file for reading",
X      (Obj a))
X{
X    return openport(a, "r", READABLE, Sopenread.name);
X}
X
XDEFUN("open:write",Fopenwrite,Sopenwrite,1,1,1,0,
X      "(open:write filename) Open a file for writing",
X      (Obj a))
X{
X    return openport(a, "w", WRITABLE, Sopenwrite.name);
X}
X
XDEFUN("open:read/write", Fopenrw, Sopenrw, 1,1,1,0,
X      "(open:read/write filename) Open a file for reading and writing",
X      (Obj a))
X{
X    return openport(a, "r+", READABLE|WRITABLE, Sopenrw.name);
X}
X
XDEFUN("open:append",Fopenappend,Sopenappend,1,1,1,0,
X      "(open:append filename) Open a file for appending",
X      (Obj a))
X{
X    return openport(a, "a", WRITABLE, Sopenappend.name);
X}
X
XDEFUN("open:string", Fopen_str, Sopen_str, 1,1,1,0,
X      "(open:string string) Open a string as an io port",
X      (Obj str))
X{
X    Obj p = newcell(), foo;
X    int sigs;
X
X    if(! STRINGP(str))
X        return jlerror(Sopen_str.name, str, "WTA: stringp");
X
X    foo = Fcons( MAKINT(0), str);
X    DISABLE( sigs );
X    CAR(p) = MAKETYPE( TPV_IOPORT ) | ((8+READABLE+WRITABLE) <<12);
X    CDR(p) = foo;
X    RENABLE( sigs );
X
X    return p;
X}
X
XDEFUN("load", Fload, Sload, 1,1,1,0,
X      "(load filename) load a lisp file",
X      (Obj file))
X{
X    /* this is used only for the initial init file
X    which then redefines load to a much more useful
X    function (with more jlerror handling...) */
X    FILE *fp;
X    Obj foo;
X
X    if( STRINGP(file)){
X        Fdefine(maksym_c("*current-file*"), file, IC_UNSPEC);
X        file = Fopenread(file);
X    }
X    if( NULLP( file )) return IC_FALSE;
X
X    if( ! RPORTP(file))
X        return IC_FALSE;
X        /* return jlerror("load",file,"WTA: filename or input port p");  */
X
X    fp = CFILEPTR( file );
X
X    while( !feof( fp )){
X        foo = Fread(file);
X        /* Fdisplay( foo, IC_UNSPEC ); */
X        Feval( foo );
X    }
X    Fclose( file );
X    return IC_TRUE;
X}
X
X
Xint readchar(Obj port){
X    int (*fnc)(Obj);
X    int t = CAR(port) >> 14;
X
X    fnc = pdesc[t].getc;
X
X    if(fnc) return fnc(port);
X    else return EOF;
X}
X
Xvoid unreadchar(Obj port, int c){
X    void (*fnc)(Obj,int);
X    int t = CAR(port) >> 14;
X
X    fnc = pdesc[t].ungetc;
X
X    if(fnc) fnc(port, c);
X
X}
X
Xvoid writechar(Obj port, int c){
X    void (*fnc)(Obj,int);
X    int t = CAR(port) >> 14;
X
X    fnc = pdesc[t].putc;
X
X    if(fnc) fnc(port, c);
X}
X
Xvoid writestr(Obj port, char* s){
X    void (*fnc)(Obj,int);
X    int t = CAR(port) >> 14;
X
X    if(! (fnc=pdesc[t].putc))
X        return;
X    while( *s)
X        fnc(port, *s++);
X}
X
XDEFUN("getc", Fgetc, Sgetc, 0,1,1,0,
X      "(getc port) Read a character from the specified port",
X      (Obj p))
X{
X    int c;
X
X    if( NBOUNDP(p)) p = stdin_port;
X    if( NULLP(p)){
X        Fthrow(sym_eof, IC_TRUE);
X        return IC_EOF;
X    }
X    if(! RPORTP(p))
X        return jlerror("getc",p, "WTA: input port p");
X    c = readchar(p);
X    if(c==EOF){
X        Fthrow(sym_eof, IC_TRUE);
X        return IC_EOF;
X    }
X    return MAKCHAR( c );
X}
X
XDEFUN("ungetc", Fungetc, Sungetc, 1,2,1,0,
X      "(ungetc char [port]) un-get a character from the specified port",
X      (Obj c, Obj p))
X{
X
X    if( NBOUNDP(p)) p = stdin_port;
X    if(! RPORTP(p))
X        return jlerror("ungetc",p, "WTA: input port p");
X    if(! ICHARP(c)) c = MAKCHAR(0);
X    unreadchar(p, CCHAR( c ));
X    return c;
X}
X
XDEFUN("putc", Fputc, Sputc, 1,2,1,0,
X      "(putc char [port]) Write a character to the specified port",
X      (Obj c, Obj p))
X{
X    if( NBOUNDP(p)) p = stdout_port;
X    if(! WPORTP(p))
X        return jlerror("putc",p, "WTA: output port p");
X
X    if(! ICHARP(c))
X        return jlerror(Sputc.name, c, "WTA: charp");
X
X    writechar(p, CCHAR(c));
X    return IC_UNSPEC;
X}
X
X
XDEFUN("flush", Fflush, Sflush, 0,1,1,0,
X      "(flush port) flush the buffer associated with port",
X      (Obj port))
X{
X    void (*fnc)(Obj);
X    int t;
X
X    if( NBOUNDP(port)) port = stdin_port;
X    if(! IOPORTP(port))
X        return jlerror("flush", port, "WTA: ioportp");
X
X    t = CAR(port) >> 14;
X    fnc = pdesc[t].flush;
X    if(fnc) fnc(port);
X    return IC_UNSPEC;
X}
X
X/* this ought use bignum offset */
XDEFUN("seek", Fseek, Sseek, 2,2,1,0,
X      "(seek port offset) move file postion",
X      (Obj p, Obj  o))
X{
X    void (*fnc)(Obj, int);
X    int t;
X
X    if(! IOPORTP(p))
X        return jlerror("seek", p, "WTA: ioportp");
X
X    if(! INUMP(o))
X        return jlerror("seek", o, "WTA: integerp");
X
X    t = CAR(p) >> 14;
X    fnc = pdesc[t].seek;
X    if(fnc) fnc(p, CINT(o));
X
X    return IC_UNSPEC;
X}
X
XDEFUN("tell", Ftell, Stell, 1,1,1,0,
X      "(tell port) return the current file postion",
X      (Obj p))
X{
X    Obj (*fnc)(Obj);
X    int t;
X
X    if(! IOPORTP(p))
X        return jlerror("seek", p, "WTA: ioportp");
X
X    t = CAR(p) >> 14;
X    fnc = pdesc[t].tell;
X    if(fnc) return fnc(p);
X
X    return IC_UNSPEC;
X}
X
XDEFUN("close", Fclose, Sclose, 1,1,1,0,
X      "(close port) closes the port",
X      (Obj p))
X{
X    int (*fnc)(Obj);
X    int t;
X
X    if(! IOPORTP(p))
X        return jlerror("seek", p, "WTA: ioportp");
X
X    t = CAR(p) >> 14;
X    fnc = pdesc[t].free;
X    if(fnc){
X        fnc(p);
X        /* make sure it is no longer used */
X        CAR(p) = CDR(p) = IC_NIL;
X    }
X    return IC_UNSPEC;
X}
CEST_TOUT
    if test `wc -c < jlisp-1.03/src/port.c` -ne 7514 ; then
        echo "file jlisp-1.03/src/port.c has been corrupted (should be 7514 bytes)"
    fi
fi
if test -f jlisp-1.03/src/pred.c -a "$1" != "-c" ; then
    echo "will not overwrite jlisp-1.03/src/pred.c"
else
    echo "    x - jlisp-1.03/src/pred.c (3154 bytes)"
    sed 's/^X//' > jlisp-1.03/src/pred.c << \CEST_TOUT
X
X/*
X    Copyright (c) 1994 Jeff Weisberg
X
X    see the file "License"
X*/
X
X#ifdef RCSID
Xstatic const char *const rcsid
X= "@(#)$Id: pred.c,v 1.9 94/08/07 13:47:29 weisberg Exp Locker: weisberg $";
X#endif
X
X/* $Id: pred.c,v 1.9 94/08/07 13:47:29 weisberg Exp Locker: weisberg $ */
X
X
X#include <jlisp.h>
X
XDEFUN("consp", Fconsp, Sconsp, 1, 1, 1,0,  "Is this a cons cell",
X      (Obj a))
X{
X
X    return CONSP( a ) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("intp", Fintp, Sintp, 1,1, 1,0, "An integer?",
X      (Obj a))
X{
X    return INUMP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("charp", Fcharp, Scharp, 1,1,1,0, "A charcacter?",
X      (Obj a))
X{
X    return ICHARP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("floatp", Ffloatp, Sfloatp, 1,1,1,0, "A float?",
X      (Obj a))
X{
X    return FLOATP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("doublep", Fdoublep, Sdoublep, 1,1,1,0, "A double?",
X      (Obj a))
X{
X    return DOUBLEP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("bignump", Fbignp, Sbignp, 1,1,1,0, "A bignum?",
X      (Obj a))
X{
X    return BIGNUMP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("stringp", Fstringp, Sstringp, 1,1,1,0, "A string?",
X      (Obj a))
X{
X    return STRINGP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("vectorp", Fvectorp, Svectorp, 1,1,1,0, "A vector?",
X      (Obj a))
X{
X    return VECTORP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("atomp", Fatomp, Satomp, 1,1,1,0, "An atom?",
X      (Obj a))
X{
X    return NCONSP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("nullp", Fnullp, Snullp, 1,1,1,0, "()?",
X      (Obj a))
X{
X    return NULLP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("falsep", Ffalsep, Sfalsep, 1,1,1,0, "false?",
X      (Obj a))
X{
X    return FALSEP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("symbolp", Fsymbolp, Ssymbolp, 1,1,1,0, "A symbol?",
X      (Obj a))
X{
X    return SYMBOLP(a)||SYMBOXP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("boundp", Fboundp, Sboundp, 1,1,1,0, "a bound symbol?",
X      (Obj a))
X{
X
X    if( SYMBOLP(a) )
X        a = Fenvlookup(a, IC_UNSPEC);
X    if( SYMBOXP(a) && BOUNDP( a ))
X        return IC_TRUE;
X    return a==IC_UNSPEC ? IC_FALSE : IC_TRUE;
X}
X
XDEFUN("definedp", Fdefinedp,Sdefinedp, 1,1,1,0, "defined?",
X      (Obj a))
X{
X
X    if( SYMBOLP(a) )
X        a = Fenvlookup(a, IC_UNSPEC);
X    if( SYMBOXP(a) && DEFINEDP( a ))
X        return IC_TRUE;
X    return a==IC_UNDEF ? IC_FALSE : IC_TRUE;
X}
X
XDEFUN("zerop", Fzerop, Szerop, 1,1,1,0, "zero?",
X      (Obj a))
X{
X
X    if( INUMP(a)) return CINT(a)==0 ? IC_TRUE : IC_FALSE;
X    if( FLOATP(a))return *(float*)&CDR(a)==0.0 ? IC_TRUE : IC_FALSE;
X
X    return IC_FALSE;
X}
X
XDEFUN("inputportp",Finputportp, Sinputportp, 1,1,1,0, "A readable ioport?",
X      (Obj a))
X{
X    return RPORTP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("outputportp",Foutputportp,Soutputportp,1,1,1,0, "A writable ioport?",
X      (Obj a))
X{
X    return WPORTP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("procedurep", Fprocp, Sprocp, 1,1,1,0, "A procedure?",
X      (Obj a))
X{
X
X    return (CCODEP(a) || FUNCTIONP(a) || MACROP(a)) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("ccodep", Fccodep, Sccodep, 1,1,1,0, "Builtin C code?",
X      (Obj a))
X{
X    return CCODEP(a) ? IC_TRUE : IC_FALSE;
X}
X
XDEFUN("functionp", Fcosp, Sclosp, 1,1,1,0, "A function?",
X      (Obj a))
X{
X
X    return FUNCTIONP(a) ? IC_TRUE : IC_FALSE;
X}
XDEFUN("macrop", Fmacrop, Smacrop, 1,1,1,0, "A macro?",
X      (Obj a))
X{
X
X    return MACROP(a) ? IC_TRUE : IC_FALSE;
X}
CEST_TOUT
    if test `wc -c < jlisp-1.03/src/pred.c` -ne 3154 ; then
        echo "file jlisp-1.03/src/pred.c has been corrupted (should be 3154 bytes)"
    fi
fi
if test -f jlisp-1.03/src/print.c -a "$1" != "-c" ; then
    echo "will not overwrite jlisp-1.03/src/print.c"
else
    echo "    x - jlisp-1.03/src/print.c (6894 bytes)"
    sed 's/^X//' > jlisp-1.03/src/print.c << \CEST_TOUT
X
X/*
X    Copyright (c) 1994 Jeff Weisberg
X
X    see the file "License"
X*/
X
X#ifdef RCSID
Xstatic const char *const rcsid
X= "@(#)$Id: print.c,v 1.18 94/08/18 16:14:02 weisberg Exp Locker: weisberg $";
X#endif
X
X/* $Id: print.c,v 1.18 94/08/18 16:14:02 weisberg Exp Locker: weisberg $ */
X
X
X#include <jlisp.h>
X#include <stdio.h>
X#include <math.h>
X
Xextern Obj_Vtbl jlisp_vtbl[];
Xvoid writestr(Obj port, char* s);
Xvoid writechar(Obj port, int c);
Xvoid printnum(Obj port, int val, int bacse, int len, int zc);
X
Xextern Obj sym_oradix, sym_stdout;
X
X
X/* how:
X       0    std. print form (no quotes)
X       1    in a form that can be read back
X*/
X
X
Xvoid prnobj(Obj a, Obj stream, int how){
X    int typ = TYPEOFX(a);
X    int (*printfnc)();
X    int i;
X    char *foo;
X    Obj radix;
X    int base;
X    double val;
X
X    switch( typ ){
X      case TPVF_IMMED:
X        if( INUMP( a )){
X            /* int */
X            radix = getvalue( sym_oradix);
X            if(DEFINEDP(radix)&& INUMP(radix))
X                base = CINT(radix);
X            else
X                base = 10;
X            printnum(stream, CINT(a), base, 0,0);
X        } else if( ICHARP( a )){
X            /* char */
X            foo = 0;
X            if(how){
X                writechar(stream, '?');
X                switch( CCHAR(a)){
X                  case '\n': foo = "\\n"; break;
X                  case '\r': foo = "\\r"; break;
X                  case '\b': foo = "\\b"; break;
X                  case ' ' : foo = "\\s"; break;
X                  case '\t': foo = "\\t"; break;
X                  case '\f': foo = "\\f"; break;
X                  case 0x1B: foo = "\\e"; break;
X                  default: foo = 0;
X                }
X            }
X            if( foo)
X                writestr(stream, foo);
X            else
X                writechar(stream, CCHAR(a));
X        } else if( ICONSTP( a )){
X            /* const sym */
X            switch( a ){
X
X              case IC_NIL:
X                writestr(stream, "()");
X                break;
X
X              case IC_TRUE:
X                writestr(stream, "#t");
X                break;
X
X              case IC_FALSE:
X                writestr(stream, "#f");
X                break;
X
X              case IC_UNDEF:
X                writestr(stream, "#<undefined>");
X                break;
X
X              case IC_UNSPEC:
X                writestr(stream, "#<unspecified>");
X                break;
X
X              case IC_EOF:
X                writestr(stream, "#<EOF>");
X                break;
X
X              default:
X                writestr(stream, "#<IC_0x");
X                printnum(stream, a, 16,0,0);
X                writestr(stream, "?>");
X                break;
X            }
X        } else {
X            writestr(stream, "#<IMM_0x");
X            printnum(stream, a, 16,0,0);
X            writestr(stream, "?>");
X        }
X        break;
X
X      case TPV_SYMBOL:
X        writestr(stream, CCHARS(a));
X        break;
X
X      case TPV_SYM_BOX:
X        writestr(stream, CSYM_BOX(a)->name);
X        break;
X
X      default:
X        printfnc = jlisp_vtbl[ typ ].print;
X
X        if( !printfnc || ! printfnc(a, stream, how) ){
X            writestr(stream, "#<_");
X            printnum(stream, typ, 10,0,0);
X            writestr(stream, "_0x");
X            printnum(stream, a, 16, 0,0);
X            writestr(stream, ">");
X        }
X        break;
X    }
X}
X
Xint prn_func_macr(Obj a, Obj stream, char* which){
X
X    writestr(stream, "(");
X    writestr(stream, which);
X    writestr(stream, " ");
X    prnobj( CADR(a), stream, 1);    /* the args */
X    writestr(stream, " ");
X
X    a = CDDR(a);
X    while( NNULLP( a )){
X        if( NCONSP( a )){
X            writestr(stream, " . ");
X            prnobj(a, stream, 1);
X            break;
X        }
X        writestr(stream, " ");
X        prnobj( CAR(a), stream, 1);
X        a = CDR( a );
X    }
X    writestr(stream, ")");
X    return 1;
X}
X
Xint prnfunc(Obj a, Obj stream, int how){
X
X    if( how) return prn_func_macr(a, stream, "lambda");
X    else writestr(stream, "#<function>");
X    return 1;
X}
Xint prnmacr(Obj a, Obj stream, int how){
X
X    if( how) return prn_func_macr(a, stream, "macro");
X    else writestr(stream, "#<macro>");
X    return 1;
X}
X
Xint prnccode(Obj a, Obj stream, int how){
X
X    writestr(stream, "#<builtin-function:");
X    writestr(stream, CCDECL(a)->name);
X    writestr(stream, ">");
X    return 1;
X}
X
Xint prnstr(Obj a, Obj stream, int how){
X    int i;
X
X    if(how) writestr(stream, "\"");
X    for(i=0; i< CLENGTH(a); i++)
X        writechar(stream, CCHARS(a)[i]);
X    if(how) writestr(stream, "\"");
X    return 1;
X}
X
Xint prnvect(Obj a, Obj stream, int how){
X    int i;
X
X    writestr(stream, "#(");
X    if( CLENGTH(a)) prnobj( CVECTOR(a)[0], stream, how);
X    for(i=1; i< CLENGTH(a); i++){
X        writestr(stream, " ");
X        prnobj( CVECTOR(a)[i], stream, how);
X    }
X    writestr(stream, ")");
X
X    return 1;
X}
Xint prnbign(Obj a, Obj stream, int how){
X    return 0;
X}
X
Xint prncmplx(Obj a, Obj stream, int how){
X    return 0;
X}
X
Xint prncons(Obj a, Obj stream, int how){
X    FILE *fp = CFILEPTR( stream );
X
X    writestr(stream, "(");
X    prnobj(CAR(a), stream, how);
X    a = CDR(a);
X    while( NNULLP( a )){
X        if( NCONSP( a )){
X            writestr(stream, " . ");
X            prnobj(a, stream, how);
X            break;
X        }
X        writestr(stream, " ");
X        prnobj( CAR(a), stream, how );
X        a = CDR( a );
X    }
X    writestr(stream, ")");
X    return 1;
X}
X
XDEFUN("display", Fdisplay, Sdisplay, 1, 2, 1,0,
X      "(display obj [port]) Display the object",
X      (Obj a, Obj stream))
X{
X
X    if( NBOUNDP( stream )) stream = getvalue(sym_stdout);
X
X    if( NULLP(stream)) return IC_UNSPEC;
X
X    if( ! WPORTP( stream )){
X        return jlerror("display", stream, "WTA: outputportp");
X    }
X
X    prnobj(a, stream, 0);
X    return IC_UNSPEC;
X}
X
XDEFUN("write", Fwrite, Swrite, 1, 2, 1,0,
X      "(write obj [port]) Display the object in read form",
X      (Obj a, Obj stream))
X{
X
X    if( NBOUNDP( stream )) stream = getvalue(sym_stdout);
X
X    if( NULLP(stream)) return IC_UNSPEC;
X
X    if( ! WPORTP( stream )){
X        return jlerror("write", stream, "WTA: outputportp");
X    }
X
X    prnobj(a, stream, 1);
X    return IC_UNSPEC;
X}
X
X
Xvoid printnum(Obj port, int val, int base, int len, int zc){
X    int c;
X    int vv=1;
X    int foo;
X    if(!zc) zc = '0';
X
X    if(val<0){
X        val = -val;
X        writechar(port, '-');
X    }
X    if(!val && !len){
X        writechar(port, '0');
X        return;
X    }
X    if(len) vv = pow(base, len);
X    else{
X        foo = val;
X        while (foo >= base){
X            foo /= base;
X            vv *= base;
X        }
X    }
X
X    while(vv){
X
X        c = val / vv;
X        if(!c)
X            writechar(port, zc);
X        else{
X            if(c>=0 && c<=9) c+= '0';
X            else c += 'A' - 0xA;
X            writechar(port, c);
X            zc = '0';
X        }
X        val %= vv;
X        vv /= base;
X    }
X}
X
X
Xvoid prnfldbl(double val, int len, Obj stream, int how){
X    float vv, vl;
X    int vvl;
X    int ip, fp;
X    Obj radix;
X    int base;
X
X    if(isinf(val)){
X        writestr(stream, "Infinity");
X        return;
X    }
X    if(isnan(val)){
X        writestr(stream, "**NaN**");
X        return;
X    }
X    if(val==0.0){
X        writestr(stream, "0.0");
X        return;
X    }
X    if(val<0){
X        val = -val;
X        writechar(stream, '-');
X    }
X    radix = getvalue( sym_oradix);
X    if(DEFINEDP(radix)&& INUMP(radix))
X        base = CINT(radix);
X    else
X        base = 10;
X
X    if(!how){
X        vv = floor(log(val)/log(base));
X        if( vv>=-3 && vv<=4 )
X            vv = 1;
X        else{
X            vvl = vv;
X            vv = pow(base, vv);
X        }
X    }else{
X        vv = 1;
X    }
X
X    /* into: ip.fp */
X
X    vl = pow(base, len);
X    val /= vv;
X    val *= vl;
X    val = rint(val);
X
X    fp = (int)val % (int)vl;
X    ip = (val - fp) / vl;
X
X
X    printnum(stream, ip, base, 0, 0);
X    writechar(stream, '.');
X    printnum(stream, fp, base, len-1, 0);
X
X    if(vv!=1){
X        writechar(stream, '$');
X        printnum(stream, vvl, base, 0,0);
X    }
X}
X
Xint prnflt(Obj a, Obj stream, int how){
X    prnfldbl( CFLOAT(a), 4, stream, how);
X    return 1;
X}
X
Xint prndbl(Obj a, Obj stream, int how){
X    prnfldbl( CDOUBLE(a), 8, stream, how);
X    return 1;
X}
X
Xint prnenvec(Obj a, Obj stream, int how){
X
X    writestr(stream, "#<ENV_0x");
X    printnum(stream, a, 16, 0,0);
X    writestr(stream, ">");
X}
X
CEST_TOUT
    if test `wc -c < jlisp-1.03/src/print.c` -ne 6894 ; then
        echo "file jlisp-1.03/src/print.c has been corrupted (should be 6894 bytes)"
    fi
fi
if test -f jlisp-1.03/src/reader.c -a "$1" != "-c" ; then
    echo "will not overwrite jlisp-1.03/src/reader.c"
else
    echo "    x - jlisp-1.03/src/reader.c (7307 bytes)"
    sed 's/^X//' > jlisp-1.03/src/reader.c << \CEST_TOUT
X
X/*
X    Copyright (c) 1994 Jeff Weisberg
X
X    see the file "License"
X*/
X
X#ifdef RCSID
Xstatic const char *const rcsid
X= "@(#)$Id: reader.c,v 1.27 94/08/23 08:51:51 weisberg Exp Locker: weisberg $";
X#endif
X
X#include <jlisp.h>
X#include <stdio.h>
X
Xextern Obj makfloat(float);
Xextern Obj str_append(Obj, int, int);
X
XObj Fread();
Xint readchar(Obj port);
Xvoid unreadchar(Obj port, int c);
X
Xextern Obj sym_optional, sym_rest, sym_quote;
Xextern Obj sym_quote, sym_bquote, sym_bq_comma, sym_bq_comma_at;
X
Xextern Obj sym_iradix, sym_eof, sym_stdin;
X
XDEFVAR(".lineno", Vlineno, ".lineno the current line number", MAKINT(1))
X
X
Xvoid inc_lineno(){
X    /* increment line number */
X    VALUE( Vlineno ) += MAKINT(1) - MAKINT(0);
X}
X
Xint vallof(int c, int b){
X
X    if(c>='0' && c<='9') return c - '0';
X    if(c>='a' && c<='z') return c - 'a' + 0xa;
X    if(c>='A' && c<='Z') return c - 'A' + 0xA;
X
X    return 255;
X}
X
Xint isvalid(int c, int b){
X
X    return vallof(c, b) < b;
X}
X
Xvoid eatcomment(Obj stream){
X    /* eat #| comment |#
X       may be nested */
X    int c=0;
X
X    while( c!='#'){
X        while(c!='|'){
X            c = readchar(stream);
X            switch(c){
X              case '#':
X                c = readchar(stream);
X                if(c=='|'){
X                    eatcomment(stream);
X                    c = readchar(stream);
X                }
X                break;
X              case '\n':
X                inc_lineno();
X              default:
X                break;
X            }
X        }
X        c = readchar(stream);
X    }
X    return;
X}
X
Xint special_char(Obj stream){
X    /* handle special \escaped characters */
X    int c;
X    int val=0, base;
X    c = readchar(stream);
X    switch( c ){
X      case 'a':    c = '\a';    break;    /* yes, I know that this is the ANSI C alert char... */
X      case 'n':    c = '\n';    break;
X      case 'r':    c = '\r';    break;
X      case 'b':    c = '\b';    break;
X      case 't':    c = '\t';    break;
X      case 's':    c = ' ';    break;
X      case 'f':    c = '\f';    break;
X      case 'v':    c = '\v';    break;
X      case 'e':    c = '\033';    break;
X
X      case '"':    c = '"';    break;
X
X      case '0':
X        base = 8;  goto rnum;
X      case 'x':
X      case 'X':
X        c = readchar(stream);
X        base = 16; goto rnum;
X      case '1': case '2': case '3':
X      case '4': case '5': case '6':
X      case '7': case '8': case '9':
X        base = 10; goto rnum;
X      rnum:
X
X        while( isvalid(c, base)){
X            val *= base;
X            val += vallof(c, base);
X            c = readchar(stream);
X        }
X        unreadchar(stream, c);
X        c = val;
X        break;
X
X      case '\n':
X        inc_lineno();
X      default:
X        Fdisplay( makstr_c("Warning: unknown escape \\"), stderr_port);
X        Fdisplay( MAKCHAR( c ),  stderr_port);
X        Fdisplay( MAKCHAR('\n'), stderr_port);
X        c = c;        break;
X
X    }
X    return c;
X}
X
Xint getc_skipws(Obj stream){
X    int c;
X
X    while( 1 ){
X        c = readchar(stream);
X        switch(c){
X          case ';':
X            while( c != '\r' && c!= '\n' ) c = readchar(stream);
X            /* fall thru' */
X          case '\n':
X            inc_lineno();
X          case ' ':
X          case '\t':
X          case '\r':
X            continue;
X          case '#':
X            c = readchar(stream);
X            if(c!='|'){
X                unreadchar(stream, c);
X                return '#';
X            }
X            eatcomment(stream);
X            continue;
X        }
X        break;
X    }
X    return c;
X}
X
XObj readparen( Obj stream ){
X    int c;
X    Obj foo;
X
X    c = getc_skipws( stream );
X    if( c==')' ) return IC_NIL;
X    unreadchar(stream, c);
X    foo = Fread( stream );
X    if( SYMBOLP(foo) && !strcmp( CCHARS(foo), ".")){
X        /* KLUDGE ALERT */
X        /* a lone .
X        turn it into an improper list */
X        foo = Fread( stream );
X        c = getc_skipws( stream );
X        if( c!=')' ) unreadchar(stream, c);
X        return foo;
X    }
X    return Fcons( foo, readparen( stream ) );
X}
X
XDEFUN("read", Fread, Sread, 0, 1, 1,0,
X      "(read [port]) read in an expression",
X      (Obj stream))
X{
X
X    int c;
X    char buf[1024];
X    int i;
X    Obj val, frac, baseo;
X    int decmp, negp, base;
X    Obj radix;
X    Obj buffer;
X
X    if( NBOUNDP( stream )) stream = getvalue(sym_stdin);
X    if( NULLP(stream)){
X        Fthrow(sym_eof, IC_EOF);
X        return IC_EOF;
X    }
X    if( !RPORTP( stream )){
X        return jlerror("read", stream, "wrong type of argument, inputportp");
X    }
X
X    c = getc_skipws( stream );
X
X    switch( c ){
X      case EOF:
X        Fthrow(sym_eof, IC_TRUE);
X        return IC_EOF;
X
X      case '(':
X        return readparen( stream );
X
X      case ')':
X        return jlerror("read", stream, "unexpected ')'");
X
X      case '"':
X        buffer = makstrn("", 0);
X        i = 0;
X        do {
X            c = readchar(stream);
X            if(c=='\\'){
X                c = special_char(stream);
X                str_append(buffer, i++, c);
X                c = 0;
X                continue;
X            }
X            if( c=='\n') inc_lineno();
X            if( c!= '"')
X                str_append(buffer, i++, c);
X        }while( c != '"' );
X
X        CCHARS(buffer)[i] = 0;
X        return buffer;
X
X      case '?':
X      rchar:
X        c = readchar(stream);
X        if( c == '\\' ){
X            i = special_char(stream);
X        }else
X            i = c;
X        return MAKCHAR( i );
X
X      case '#':
X        c = getc_skipws( stream );
X
X        switch( c ){
X          case '\\':
X            /* handle scheme-like character syntax #\x #\\n would be a newline... */
X            goto rchar;
X          case 't':
X          case 'T':
X            return IC_TRUE;
X          case 'f':
X          case 'F':
X            return IC_FALSE;
X          case '<':
X            while ( c != '>') c = getc_skipws(stream);
X            return jlerror("read", IC_UNSPEC, "unreadable syntax");
X          case '(':
X            return Flist_vect( readparen(stream) );
X          case 'x':
X          case 'X':
X            /* _I_ like spagetti... */
X            base = 16;    goto rnump;
X          case 'o':
X          case 'O':
X            base = 8;    goto rnump;
X          case 'd':
X          case 'D':
X            base = 10;    goto rnump;
X          case 'b':
X          case 'B':
X            base = 2;
X          rnump:
X            c = getc_skipws(stream);
X            goto rnum;
X          case '!':
X            if( VALUE(Vlineno)==MAKINT(1)){
X                /* special script file handling
X                   #! is a comment on the 1st line of a file
X                */
X                while( c != '\n') c = readchar(stream);
X                unreadchar(stream, c);
X                return Fread(stream);
X            }
X            /* fall thru' */
X          default:
X            return jlerror(Sread.name, IC_UNSPEC, "unreadable syntax");
X        }
X        break;
X
X      case '\'':
X        return Fcons(sym_quote, Fcons(Fread( stream ), IC_NIL));
X        break;
X
X      case '`':
X        return Fcons(sym_bquote, Fcons(Fread( stream ), IC_NIL));
X        break;
X
X      case ',':
X        c = readchar(stream);
X        if( c=='@') return Fcons(sym_bq_comma_at, Fcons(Fread( stream ), IC_NIL));
X        unreadchar(stream, c);
X        return Fcons(sym_bq_comma, Fcons(Fread( stream ), IC_NIL));
X
X      default:
X        radix = getvalue( sym_iradix );
X
X        if( INUMP(radix))
X            base = CINT(radix);
X        else
X            base = 10;
X
X      rnum:
X        baseo = MAKINT(base);
X
X        i = 0;
X        while(1){
X            if( c==' ' ) break;
X            if( c=='\t') break;
X            if( c=='\r') break;
X            if( c=='\n') break;
X            if( c==')' ) break;
X            if( c=='(' ) break;
X            if( c==';' ) break;
X            if( c=='#' ) break;    /* XXX ? ought # be allowed in a symbol name? */
X            if( c==EOF ) break;
X
X            buf[i++] = c;
X            buf[i] = 0;
X            c = readchar(stream);
X        }
X        unreadchar(stream, c);
X
X        /* handle 2 special cases */
X        if(!strcmp(buf, "&rest"))     return sym_rest;
X        if(!strcmp(buf, "&optional"))     return sym_optional;
X
X        val = MAKINT(0);
X        frac= makfloat(1);
X        decmp = negp = 0;
X        i = 0;
X
X
X        if( buf[0]=='-'){
X            negp = 1;
X            i++;
X        }
X        while(buf[i]){
X            if( !isvalid(buf[i], base) && buf[i]!='.'){
X                /* a symbol */
X                return maksym( buf );
X            }
X            if( buf[i]=='.' ){
X                if( decmp ) return maksym( buf );
X                decmp = 1;
X                i++;
X                continue;
X            }
X
X            if( decmp ){
X                frac = Fdivide(frac, baseo);
X                val  = Ftimes(val, baseo);
X                val  = Fplus(val, MAKINT(vallof( buf[i], base )));
X            } else {
X                val = Ftimes(val, baseo);
X                val = Fplus(val, MAKINT(vallof( buf[i], base )));
X            }
X            i++;
X
X        }
X        if(negp && i==1)
X            return maksym( buf );
X        if(decmp && i==1)
X            return maksym( buf );
X        if(decmp)
X            val = Ftimes(val, frac);
X        if(negp)
X            val = Fminus(MAKINT(0), val);
X        return val;
X
X    }
X}
X
X
X
X
X
X
X
CEST_TOUT
    if test `wc -c < jlisp-1.03/src/reader.c` -ne 7307 ; then
        echo "file jlisp-1.03/src/reader.c has been corrupted (should be 7307 bytes)"
    fi
fi
echo part07 done.
exit 0