io.c - mplisp - miniPicoLisp with FFI and modules for Buddy BDD library, OpenGL, Gtk and GMP

io.c (22871B)
      1 /* 01apr08abu
      2  * (c) Software Lab. Alexander Burger
      3  */
      4 
      5 #include "pico.h"
      6 
      7 static any read0(bool);
      8 
      9 static int StrI;
     10 static cell StrCell, *StrP;
     11 static word StrW;
     12 static void (*PutSave)(int);
     13 static char Delim[] = " \t\n\r\"'()[]`~";
     14 
     15 static void openErr(any ex, char *s) {err(ex, NULL, "%s open: %s", s, strerror(errno));}
     16 static void eofErr(void) {err(NULL, NULL, "EOF Overrun");}
     17 
     18 /* Buffer size */
     19 int bufSize(any x) {return symBytes(x) + 1;}
     20 
     21 int pathSize(any x) {
     22    int c = firstByte(x);
     23 
     24    if (c != '@'  &&  (c != '+' || secondByte(x) != '@'))
     25       return bufSize(x);
     26    if (!Home)
     27       return symBytes(x);
     28    return strlen(Home) + symBytes(x);
     29 }
     30 
     31 void bufString(any x, char *p) {
     32    int c, i;
     33    word w;
     34 
     35    if (!isNil(x)) {
     36       for (x = name(x), c = getByte1(&i, &w, &x); c; c = getByte(&i, &w, &x)) {
     37          if (c == '^') {
     38             if ((c = getByte(&i, &w, &x)) == '?')
     39                c = 127;
     40             else
     41                c &= 0x1F;
     42          }
     43          *p++ = c;
     44       }
     45    }
     46    *p = '\0';
     47 }
     48 
     49 void pathString(any x, char *p) {
     50    int c, i;
     51    word w;
     52    char *h;
     53 
     54    x = name(x);
     55    if ((c = getByte1(&i, &w, &x)) == '+')
     56       *p++ = c,  c = getByte(&i, &w, &x);
     57    if (c != '@')
     58       while (*p++ = c)
     59          c = getByte(&i, &w, &x);
     60    else {
     61       if (h = Home)
     62          do
     63             *p++ = *h++;
     64          while (*h);
     65       while (*p++ = getByte(&i, &w, &x));
     66    }
     67 }
     68 
     69 // (path 'sym) -> sym
     70 any doPath(any ex) {
     71    any x;
     72 
     73    x = cdr(ex),  x = EVAL(car(x));
     74    NeedSym(ex,x);
     75    {
     76       char nm[pathSize(x)];
     77 
     78       pathString(x,nm);
     79       return mkStr(nm);
     80    }
     81 }
     82 
     83 void rdOpen(any ex, any x, inFrame *f) {
     84    NeedSymb(ex,x);
     85    if (isNil(x))
     86       f->fp = stdin;
     87    else {
     88       char nm[pathSize(x)];
     89 
     90       pathString(x,nm);
     91       if (nm[0] == '+') {
     92          if (!(f->fp = fopen(nm+1, "a+")))
     93             openErr(ex, nm);
     94          fseek(f->fp, 0L, SEEK_SET);
     95       }
     96       else if (!(f->fp = fopen(nm, "r")))
     97          openErr(ex, nm);
     98    }
     99 }
    100 
    101 void wrOpen(any ex, any x, outFrame *f) {
    102    NeedSymb(ex,x);
    103    if (isNil(x))
    104       f->fp = stdout;
    105    else {
    106       char nm[pathSize(x)];
    107 
    108       pathString(x,nm);
    109       if (nm[0] == '+') {
    110          if (!(f->fp = fopen(nm+1, "a")))
    111             openErr(ex, nm);
    112       }
    113       else if (!(f->fp = fopen(nm, "w")))
    114          openErr(ex, nm);
    115    }
    116 }
    117 
    118 /*** Reading ***/
    119 void getStdin(void) {Chr = getc(InFile);}
    120 
    121 static void getParse(void) {
    122    if ((Chr = getByte(&Env.parser->i, &Env.parser->w, &Env.parser->nm)) == 0)
    123       Chr = ']';
    124 }
    125 
    126 void pushInFiles(inFrame *f) {
    127    f->next = Chr,  Chr = 0;
    128    InFile = f->fp;
    129    f->get = Env.get,  Env.get = getStdin;
    130    f->link = Env.inFiles,  Env.inFiles = f;
    131 }
    132 
    133 void pushOutFiles(outFrame *f) {
    134    OutFile = f->fp;
    135    f->put = Env.put,  Env.put = putStdout;
    136    f->link = Env.outFiles,  Env.outFiles = f;
    137 }
    138 
    139 void popInFiles(void) {
    140    if (InFile != stdin)
    141       fclose(InFile);
    142    Chr = Env.inFiles->next;
    143    Env.get = Env.inFiles->get;
    144    InFile = (Env.inFiles = Env.inFiles->link)?  Env.inFiles->fp : stdin;
    145 }
    146 
    147 void popOutFiles(void) {
    148    if (OutFile != stdout)
    149       fclose(OutFile);
    150    Env.put = Env.outFiles->put;
    151    OutFile = (Env.outFiles = Env.outFiles->link)? Env.outFiles->fp : stdout;
    152 }
    153 
    154 /* Skip White Space and Comments */
    155 static int skip(int c) {
    156    for (;;) {
    157       if (Chr < 0)
    158          return Chr;
    159       while (Chr <= ' ') {
    160          Env.get();
    161          if (Chr < 0)
    162             return Chr;
    163       }
    164       if (Chr != c)
    165          return Chr;
    166       while (Env.get(), Chr != '\n')
    167          if (Chr < 0)
    168             return Chr;
    169       Env.get();
    170    }
    171 }
    172 
    173 /* Test for escaped characters */
    174 static bool testEsc(void) {
    175    for (;;) {
    176       if (Chr < 0)
    177          return NO;
    178       if (Chr != '\\')
    179          return YES;
    180       if (Env.get(), Chr != '\n')
    181          return YES;
    182       do
    183          Env.get();
    184       while (Chr == ' '  ||  Chr == '\t');
    185    }
    186 }
    187 
    188 /* Read a list */
    189 static any rdList(void) {
    190    any x;
    191    cell c1, c2;
    192 
    193    if (skip('#') == ')') {
    194       Env.get();
    195       return Nil;
    196    }
    197    if (Chr == ']')
    198       return Nil;
    199    for (;;) {
    200       if (Chr != '~') {
    201          Push(c1, x = cons(read0(NO),Nil));
    202          break;
    203       }
    204       Env.get();
    205       Push(c1, read0(NO));
    206       if (isCell(x = data(c1) = EVAL(data(c1)))) {
    207          do
    208             x = cdr(x);
    209          while (isCell(cdr(x)));
    210          break;
    211       }
    212       drop(c1);
    213    }
    214    for (;;) {
    215       if (skip('#') == ')') {
    216          Env.get();
    217          break;
    218       }
    219       if (Chr == ']')
    220          break;
    221       if (Chr == '.') {
    222          Env.get();
    223          cdr(x) = skip('#')==')' || Chr==']'? data(c1) : read0(NO);
    224          if (skip('#') == ')')
    225             Env.get();
    226          else if (Chr != ']')
    227             err(NULL, x, "Bad dotted pair");
    228          break;
    229       }
    230       if (Chr != '~')
    231          x = cdr(x) = cons(read0(NO),Nil);
    232       else {
    233          Env.get();
    234          Push(c2, read0(NO));
    235          data(c2) = EVAL(data(c2));
    236          if (isCell(cdr(x) = Pop(c2)))
    237             do
    238                x = cdr(x);
    239             while (isCell(cdr(x)));
    240       }
    241    }
    242    return Pop(c1);
    243 }
    244 
    245 /* Try for anonymous symbol */
    246 static any anonymous(any s) {
    247    int c, i;
    248    word w;
    249    unsigned long n;
    250    heap *h;
    251 
    252    if ((c = getByte1(&i, &w, &s)) != '$')
    253       return NULL;
    254    n = 0;
    255    while (c = getByte(&i, &w, &s)) {
    256       if (c < '0' || c > '9')
    257          return NULL;
    258       n = n * 10 + c - '0';
    259    }
    260    n *= sizeof(cell);
    261    h = Heaps;
    262    do
    263       if ((any)n > h->cells  &&  (any)n < h->cells + CELLS)
    264          return symPtr((any)n);
    265    while (h = h->next);
    266    return NULL;
    267 }
    268 
    269 /* Relocate anonymous symbol */
    270 static any reloc(any key) {
    271    any x, y;
    272    int n;
    273 
    274    if (!isCell(x = Reloc)) {
    275       Reloc = cons(cons(key, y = consSym(Nil,0)), Nil);
    276       return y;
    277    }
    278    for (;;) {
    279       if ((n = num(key) - num(caar(x))) == 0)
    280          return cdar(x);
    281       if (!isCell(cdr(x))) {
    282          key = cons(cons(key, y = consSym(Nil,0)), Nil);
    283          cdr(x) = n<0? cons(key,Nil) : cons(Nil,key);
    284          return y;
    285       }
    286       if (n < 0) {
    287          if (!isCell(cadr(x))) {
    288             cadr(x) = cons(cons(key, y = consSym(Nil,0)), Nil);
    289             return y;
    290          }
    291          x = cadr(x);
    292       }
    293       else {
    294          if (!isCell(cddr(x))) {
    295             cddr(x) = cons(cons(key, y = consSym(Nil,0)), Nil);
    296             return y;
    297          }
    298          x = cddr(x);
    299       }
    300    }
    301 }
    302 
    303 /* Read one expression */
    304 static any read0(bool top) {
    305    int i;
    306    word w;
    307    any x, y;
    308    cell c1, *p;
    309 
    310    if (skip('#') < 0) {
    311       if (top)
    312          return Nil;
    313       eofErr();
    314    }
    315    if (Chr == '(') {
    316       Env.get();
    317       x = rdList();
    318       if (top  &&  Chr == ']')
    319          Env.get();
    320       return x;
    321    }
    322    if (Chr == '[') {
    323       Env.get();
    324       x = rdList();
    325       if (Chr != ']')
    326          err(NULL, x, "Super parentheses mismatch");
    327       Env.get();
    328       return x;
    329    }
    330    if (Chr == '\'') {
    331       Env.get();
    332       return cons(Quote, read0(NO));
    333    }
    334    if (Chr == '`') {
    335       Env.get();
    336       Push(c1, read0(NO));
    337       x = EVAL(data(c1));
    338       drop(c1);
    339       return x;
    340    }
    341    if (Chr == '\\') {
    342       Env.get();
    343       Push(c1, read0(NO));
    344       if (isNum(x = data(c1)))
    345          x = reloc(x);
    346       else if (isCell(x)) {
    347          Transient[0] = Transient[1] = Nil;
    348          if (isNum(x = car(y = x)))
    349             x = car(y) = reloc(x);
    350          if (isCell(y = cdr(y))) {
    351             val(x) = car(y);
    352             p = (any)&tail(x);
    353             while (isCell(car(p)))
    354                car(p) = caar(p);
    355             while (isCell(y = cdr(y)))
    356                car(p) = cons(car(p),car(y)),  p = car(p);
    357          }
    358       }
    359       drop(c1);
    360       return x;
    361    }
    362    if (Chr == '"') {
    363       Env.get();
    364       if (Chr == '"') {
    365          Env.get();
    366          return Nil;
    367       }
    368       if (!testEsc())
    369          eofErr();
    370       putByte1(Chr, &i, &w, &p);
    371       while (Env.get(), Chr != '"') {
    372          if (!testEsc())
    373             eofErr();
    374          putByte(Chr, &i, &w, &p, &c1);
    375       }
    376       y = popSym(i, w, p, &c1),  Env.get();
    377       if (x = isIntern(tail(y), Transient))
    378          return x;
    379       if (Env.get == getStdin)
    380          intern(y, Transient);
    381       return y;
    382    }
    383    if (strchr(Delim, Chr))
    384       err(NULL, NULL, "Bad input '%c' (%d)", isprint(Chr)? Chr:'?', Chr);
    385    if (Chr == '\\')
    386       Env.get();
    387    putByte1(Chr, &i, &w, &p);
    388    for (;;) {
    389       Env.get();
    390       if (strchr(Delim, Chr))
    391          break;
    392       if (Chr == '\\')
    393          Env.get();
    394       putByte(Chr, &i, &w, &p, &c1);
    395    }
    396    y = popSym(i, w, p, &c1);
    397    if (x = symToNum(tail(y), (int)unBox(val(Scl)), '.', 0))
    398       return x;
    399    if (x = isIntern(tail(y), Intern))
    400       return x;
    401    if (x = anonymous(name(y)))
    402       return x;
    403    intern(y, Intern);
    404    val(y) = Nil;
    405    return y;
    406 }
    407 
    408 any read1(int end) {
    409    any x;
    410 
    411    if (!Chr)
    412       Env.get();
    413    if (Chr == end)
    414       return Nil;
    415    x = read0(YES);
    416    while (Chr  &&  strchr(" \t)]", Chr))
    417       Env.get();
    418    return x;
    419 }
    420 
    421 /* Read one token */
    422 any token(any x, int c) {
    423    int i;
    424    word w;
    425    any y;
    426    cell c1, *p;
    427 
    428    if (!Chr)
    429       Env.get();
    430    if (skip(c) < 0)
    431       return Nil;
    432    if (Chr == '"') {
    433       Env.get();
    434       if (Chr == '"') {
    435          Env.get();
    436          return Nil;
    437       }
    438       testEsc();
    439       putByte1(Chr, &i, &w, &p);
    440       while (Env.get(), Chr != '"' && testEsc())
    441          putByte(Chr, &i, &w, &p, &c1);
    442       Env.get();
    443       return popSym(i, w, p, &c1);
    444    }
    445    if (Chr >= '0' && Chr <= '9') {
    446       putByte1(Chr, &i, &w, &p);
    447       while (Env.get(), Chr >= '0' && Chr <= '9' || Chr == '.')
    448          putByte(Chr, &i, &w, &p, &c1);
    449       return symToNum(tail(popSym(i, w, p, &c1)), (int)unBox(val(Scl)), '.', 0);
    450    }
    451    {
    452       char nm[bufSize(x)];
    453 
    454       bufString(x, nm);
    455       if (Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr)) {
    456          if (Chr == '\\')
    457             Env.get();
    458          putByte1(Chr, &i, &w, &p);
    459          while (Env.get(),
    460                Chr >= '0' && Chr <= '9' || Chr >= 'A' && Chr <= 'Z' ||
    461                Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr) ) {
    462             if (Chr == '\\')
    463                Env.get();
    464             putByte(Chr, &i, &w, &p, &c1);
    465          }
    466          y = popSym(i, w, p, &c1);
    467          if (x = isIntern(tail(y), Intern))
    468             return x;
    469          intern(y, Intern);
    470          val(y) = Nil;
    471          return y;
    472       }
    473    }
    474    y = mkTxt(c = Chr);
    475    Env.get();
    476    if (x = isIntern(y, Intern))
    477       return x;
    478    return mkChar(c);
    479 }
    480 
    481 // (read ['sym1 ['sym2]]) -> any
    482 any doRead(any ex) {
    483    any x, y;
    484 
    485    if (!isCell(x = cdr(ex)))
    486       x = read1(0),  Reloc = Nil;
    487    else {
    488       y = EVAL(car(x));
    489       NeedSym(ex,y);
    490       x = cdr(x),  x = EVAL(car(x));
    491       NeedSym(ex,x);
    492       x = token(y, firstByte(x));
    493    }
    494    if (InFile == stdin  &&  Chr == '\n')
    495       Chr = 0;
    496    return x;
    497 }
    498 
    499 // (peek) -> sym
    500 any doPeek(any ex __attribute__((unused))) {
    501    if (!Chr)
    502       Env.get();
    503    return Chr<0? Nil : mkChar(Chr);
    504 }
    505 
    506 // (char) -> sym
    507 // (char 'num) -> sym
    508 // (char 'sym) -> num
    509 any doChar(any ex) {
    510    any x = cdr(ex);
    511 
    512    if (!isCell(x)) {
    513       if (!Chr)
    514          Env.get();
    515       x = Chr<0? Nil : mkChar(Chr);
    516       Env.get();
    517       return x;
    518    }
    519    if (isNum(x = EVAL(car(x)))) {
    520       int c = (int)unBox(x);
    521 
    522       if (c == 127)
    523          return mkChar2('^','?');
    524       if (c < ' ')
    525          return mkChar2('^', c + 0x40);
    526       return mkChar(c);
    527    }
    528    if (isSym(x)) {
    529       int c;
    530 
    531       if ((c = firstByte(x)) != '^')
    532          return box(c);
    533       return box((c = secondByte(x)) == '?'? 127 : c & 0x1F);
    534    }
    535    atomError(ex,x);
    536 }
    537 
    538 // (skip ['sym]) -> sym
    539 any doSkip(any ex) {
    540    any x;
    541 
    542    x = cdr(ex),  x = EVAL(car(x));
    543    NeedSymb(ex,x);
    544    return skip(firstByte(x))<0? Nil : mkChar(Chr);
    545 }
    546 
    547 // (eol) -> flg
    548 any doEol(any ex __attribute__((unused))) {
    549    return InFile && Chr=='\n' || Chr<=0? T : Nil;
    550 }
    551 
    552 // (eof ['flg]) -> flg
    553 any doEof(any x) {
    554    x = cdr(x);
    555    if (!isNil(EVAL(car(x)))) {
    556       Chr = -1;
    557       return T;
    558    }
    559    if (!Chr)
    560       Env.get();
    561    return Chr < 0? T : Nil;
    562 }
    563 
    564 // (from 'any ..) -> sym
    565 any doFrom(any ex) {
    566    any x;
    567    int res, i, j, ac = length(x = cdr(ex)), p[ac];
    568    cell c[ac];
    569    char *av[ac];
    570 
    571    if (ac == 0)
    572       return Nil;
    573    for (i = 0;;) {
    574       Push(c[i], evSym(x));
    575       av[i] = alloc(NULL, bufSize(data(c[i]))),  bufString(data(c[i]), av[i]);
    576       p[i] = 0;
    577       if (++i == ac)
    578          break;
    579       x = cdr(x);
    580    }
    581    res = -1;
    582    if (!Chr)
    583       Env.get();
    584    while (Chr >= 0) {
    585       for (i = 0; i < ac; ++i) {
    586          for (;;) {
    587             if (av[i][p[i]] == (byte)Chr) {
    588                if (av[i][++p[i]])
    589                   break;
    590                Env.get();
    591                res = i;
    592                goto done;
    593             }
    594             if (!p[i])
    595                break;
    596             for (j = 1; --p[i]; ++j)
    597                if (memcmp(av[i], av[i]+j, p[i]) == 0)
    598                   break;
    599          }
    600       }
    601       Env.get();
    602    }
    603 done:
    604    i = 0;  do
    605       free(av[i]);
    606    while (++i < ac);
    607    drop(c[0]);
    608    return res < 0? Nil : data(c[res]);
    609 }
    610 
    611 // (till 'any ['flg]) -> lst|sym
    612 any doTill(any ex) {
    613    any x;
    614    int i;
    615    word w;
    616    cell c1;
    617 
    618    x = evSym(cdr(ex));
    619    {
    620       char buf[bufSize(x)];
    621 
    622       bufString(x, buf);
    623       if (!Chr)
    624          Env.get();
    625       if (Chr < 0 || strchr(buf,Chr))
    626          return Nil;
    627       x = cddr(ex);
    628       if (isNil(EVAL(car(x)))) {
    629          Push(c1, x = cons(mkChar(Chr), Nil));
    630          while (Env.get(), Chr > 0 && !strchr(buf,Chr))
    631             x = cdr(x) = cons(mkChar(Chr), Nil);
    632          return Pop(c1);
    633       }
    634       putByte1(Chr, &i, &w, &x);
    635       while (Env.get(), Chr > 0 && !strchr(buf,Chr))
    636          putByte(Chr, &i, &w, &x, &c1);
    637       return popSym(i, w, x, &c1);
    638    }
    639 }
    640 
    641 static inline bool eol(void) {
    642    if (Chr < 0)
    643       return YES;
    644    if (Chr == '\n') {
    645       Chr = 0;
    646       return YES;
    647    }
    648    if (Chr == '\r') {
    649       Env.get();
    650       if (Chr == '\n')
    651          Chr = 0;
    652       return YES;
    653    }
    654    return NO;
    655 }
    656 
    657 // (line 'flg) -> lst|sym
    658 any doLine(any x) {
    659    any y;
    660    int i;
    661    word w;
    662    cell c1;
    663 
    664    if (!Chr)
    665       Env.get();
    666    if (eol())
    667       return Nil;
    668    x = cdr(x);
    669    if (isNil(EVAL(car(x)))) {
    670       Push(c1, cons(mkChar(Chr), Nil));
    671       y = data(c1);
    672       for (;;) {
    673          if (Env.get(), eol())
    674             return Pop(c1);
    675          y = cdr(y) = cons(mkChar(Chr), Nil);
    676       }
    677    }
    678    else {
    679       putByte1(Chr, &i, &w, &y);
    680       for (;;) {
    681          if (Env.get(), eol())
    682             return popSym(i, w, y, &c1);
    683          putByte(Chr, &i, &w, &y, &c1);
    684       }
    685    }
    686 }
    687 
    688 static any parse(any x, bool skp) {
    689    int c;
    690    parseFrame *save, parser;
    691    void (*getSave)(void);
    692    cell c1;
    693 
    694    if (save = Env.parser)
    695       Push(c1, Env.parser->sym);
    696    Env.parser = &parser;
    697    parser.nm = name(parser.sym = x);
    698    getSave = Env.get,  Env.get = getParse,  c = Chr;
    699    Chr = getByte1(&parser.i, &parser.w, &parser.nm);
    700    if (skp)
    701       getParse();
    702    x = rdList();
    703    Chr = c,  Env.get = getSave;
    704    if (Env.parser = save)
    705       drop(c1);
    706    return x;
    707 }
    708 
    709 static void putString(int c) {
    710    putByte(c, &StrI, &StrW, &StrP, &StrCell);
    711 }
    712 
    713 void begString(void) {
    714    putByte0(&StrI, &StrW, &StrP);
    715    PutSave = Env.put,  Env.put = putString;
    716 }
    717 
    718 any endString(void) {
    719    Env.put = PutSave;
    720    StrP = popSym(StrI, StrW, StrP, &StrCell);
    721    return StrI? StrP : Nil;
    722 }
    723 
    724 // (any 'sym) -> any
    725 any doAny(any ex) {
    726    any x;
    727 
    728    x = cdr(ex),  x = EVAL(car(x));
    729    NeedSymb(ex,x);
    730    if (!isNil(x)) {
    731       int c;
    732       parseFrame *save, parser;
    733       void (*getSave)(void);
    734       cell c1;
    735 
    736       if (save = Env.parser)
    737          Push(c1, Env.parser->sym);
    738       Env.parser = &parser;
    739       parser.nm = name(parser.sym = x);
    740       getSave = Env.get,  Env.get = getParse,  c = Chr;
    741       Chr = getByte1(&parser.i, &parser.w, &parser.nm);
    742       x = read0(YES);
    743       Chr = c,  Env.get = getSave;
    744       if (Env.parser = save)
    745          drop(c1);
    746    }
    747    return x;
    748 }
    749 
    750 // (sym 'any) -> sym
    751 any doSym(any x) {
    752    cell c1;
    753 
    754    x = EVAL(cadr(x));
    755    begString();
    756    Push(c1,x);
    757    print(data(c1));
    758    drop(c1);
    759    return endString();
    760 }
    761 
    762 // (str 'sym) -> lst
    763 // (str 'lst) -> sym
    764 any doStr(any ex) {
    765    any x;
    766    cell c1;
    767 
    768    x = cdr(ex);
    769    if (isSymb(x = EVAL(car(x))))
    770       return isNil(x)? Nil : parse(x,NO);
    771    NeedCell(ex,x);
    772    begString();
    773    Push(c1,x);
    774    print(car(x));
    775    while (isCell(x = cdr(x)))
    776       space(),  print(car(x));
    777    drop(c1);
    778    return endString();
    779 }
    780 
    781 any load(any ex, int pr, any x) {
    782    cell c1;
    783    inFrame f;
    784 
    785    if (isSymb(x) && firstByte(x) == '-') {
    786       Push(c1, parse(x,YES));
    787       x = evList(data(c1));
    788       drop(c1);
    789       return x;
    790    }
    791    rdOpen(ex, x, &f);
    792    doHide(Nil);
    793    pushInFiles(&f);
    794    x = Nil;
    795    for (;;) {
    796       if (InFile != stdin)
    797          data(c1) = read1(0);
    798       else {
    799          if (pr && !Chr)
    800             Env.put(pr), space(), fflush(OutFile);
    801          data(c1) = read1('\n');
    802          if (Chr == '\n')
    803             Chr = 0;
    804       }
    805       if (isNil(data(c1)))
    806          break;
    807       Save(c1),  x = EVAL(data(c1)),  drop(c1);
    808       if (InFile == stdin && !Chr) {
    809          val(At3) = val(At2),  val(At2) = val(At),  val(At) = x;
    810          outString("-> "),  fflush(OutFile),  print(x),  crlf();
    811       }
    812    }
    813    popInFiles();
    814    doHide(Nil);
    815    return x;
    816 }
    817 
    818 // (load 'any ..) -> any
    819 any doLoad(any ex) {
    820    any x, y;
    821 
    822    x = cdr(ex);
    823    do {
    824       if ((y = EVAL(car(x))) != T)
    825          y = load(ex, '>', y);
    826       else
    827          while (*AV  &&  strcmp(*AV,"-") != 0)
    828             y = load(ex, '>', mkStr(*AV++));
    829    } while (isCell(x = cdr(x)));
    830    return y;
    831 }
    832 
    833 // (in 'any . prg) -> any
    834 any doIn(any ex) {
    835    any x;
    836    inFrame f;
    837 
    838    x = cdr(ex),  x = EVAL(car(x));
    839    rdOpen(ex,x,&f);
    840    pushInFiles(&f);
    841    x = prog(cddr(ex));
    842    popInFiles();
    843    return x;
    844 }
    845 
    846 // (out 'any . prg) -> any
    847 any doOut(any ex) {
    848    any x;
    849    outFrame f;
    850 
    851    x = cdr(ex),  x = EVAL(car(x));
    852    wrOpen(ex,x,&f);
    853    pushOutFiles(&f);
    854    x = prog(cddr(ex));
    855    popOutFiles();
    856    return x;
    857 }
    858 
    859 /*** Prining ***/
    860 void putStdout(int c) {putc(c, OutFile);}
    861 
    862 void crlf(void) {Env.put('\n');}
    863 void space(void) {Env.put(' ');}
    864 
    865 void outString(char *s) {
    866    while (*s)
    867       Env.put(*s++);
    868 }
    869 
    870 int bufNum(char buf[BITS/2], long n) {
    871    return sprintf(buf, "%ld", n);
    872 }
    873 
    874 void outNum(long n) {
    875    char buf[BITS/2];
    876 
    877    bufNum(buf, n);
    878    outString(buf);
    879 }
    880 
    881 void prIntern(any nm) {
    882    int i, c;
    883    word w;
    884 
    885    c = getByte1(&i, &w, &nm);
    886    if (strchr(Delim, c))
    887       Env.put('\\');
    888    Env.put(c);
    889    while (c = getByte(&i, &w, &nm)) {
    890       if (strchr(Delim, c))
    891          Env.put('\\');
    892       Env.put(c);
    893    }
    894 }
    895 
    896 void prTransient(any nm) {
    897    int i, c;
    898    word w;
    899 
    900    Env.put('"');
    901    c = getByte1(&i, &w, &nm);
    902    do {
    903       if (c == '"'  ||  c == '\\')
    904          Env.put('\\');
    905       Env.put(c);
    906    } while (c = getByte(&i, &w, &nm));
    907    Env.put('"');
    908 }
    909 
    910 /* Print one expression */
    911 void print(any x) {
    912    if (isNum(x))
    913       outNum(unBox(x));
    914    else if (isSym(x)) {
    915       any nm = name(x);
    916 
    917       if (nm == txt(0))
    918          Env.put('$'),  outNum((word)x/sizeof(cell));
    919       else if (x == isIntern(nm, Intern))
    920          prIntern(nm);
    921       else
    922          prTransient(nm);
    923    }
    924    else if (car(x) == Quote  &&  x != cdr(x))
    925       Env.put('\''),  print(cdr(x));
    926    else {
    927       any y = x;
    928       Env.put('(');
    929       while (print(car(x)), !isNil(x = cdr(x))) {
    930          if (x == y) {
    931             outString(" .");
    932             break;
    933          }
    934          if (!isCell(x)) {
    935             outString(" . ");
    936             print(x);
    937             break;
    938          }
    939          space();
    940       }
    941       Env.put(')');
    942    }
    943 }
    944 
    945 void prin(any x) {
    946    if (!isNil(x)) {
    947       if (isNum(x))
    948          outNum(unBox(x));
    949       else if (isSym(x)) {
    950          int i, c;
    951          word w;
    952 
    953          for (x = name(x), c = getByte1(&i, &w, &x); c; c = getByte(&i, &w, &x)) {
    954             if (c != '^')
    955                Env.put(c);
    956             else if (!(c = getByte(&i, &w, &x)))
    957                Env.put('^');
    958             else if (c == '?')
    959                Env.put(127);
    960             else
    961                Env.put(c &= 0x1F);
    962          }
    963       }
    964       else {
    965          while (prin(car(x)), !isNil(x = cdr(x))) {
    966             if (!isCell(x)) {
    967                prin(x);
    968                break;
    969             }
    970          }
    971       }
    972    }
    973 }
    974 
    975 // (prin 'any ..) -> any
    976 any doPrin(any x) {
    977    any y = Nil;
    978 
    979    while (isCell(x = cdr(x)))
    980       prin(y = EVAL(car(x)));
    981    return y;
    982 }
    983 
    984 // (prinl 'any ..) -> any
    985 any doPrinl(any x) {
    986    any y = Nil;
    987 
    988    while (isCell(x = cdr(x)))
    989       prin(y = EVAL(car(x)));
    990    crlf();
    991    return y;
    992 }
    993 
    994 // (space ['num]) -> num
    995 any doSpace(any ex) {
    996    any x;
    997    int n;
    998 
    999    if (isNil(x = EVAL(cadr(ex)))) {
   1000       Env.put(' ');
   1001       return One;
   1002    }
   1003    for (n = xNum(ex,x); n > 0; --n)
   1004       Env.put(' ');
   1005    return x;
   1006 }
   1007 
   1008 // (print 'any ..) -> any
   1009 any doPrint(any x) {
   1010    any y;
   1011 
   1012    x = cdr(x),  print(y = EVAL(car(x)));
   1013    while (isCell(x = cdr(x)))
   1014       space(),  print(y = EVAL(car(x)));
   1015    return y;
   1016 }
   1017 
   1018 // (printsp 'any ..) -> any
   1019 any doPrintsp(any x) {
   1020    any y;
   1021 
   1022    x = cdr(x);
   1023    do
   1024       print(y = EVAL(car(x))),  space();
   1025    while (isCell(x = cdr(x)));
   1026    return y;
   1027 }
   1028 
   1029 // (println 'any ..) -> any
   1030 any doPrintln(any x) {
   1031    any y;
   1032 
   1033    x = cdr(x),  print(y = EVAL(car(x)));
   1034    while (isCell(x = cdr(x)))
   1035       space(),  print(y = EVAL(car(x)));
   1036    crlf();
   1037    return y;
   1038 }
   1039 
   1040 /* Save one expression */
   1041 static void save(any x) {
   1042    any y, nm;
   1043 
   1044    if (isNum(x))
   1045       outNum(unBox(x));
   1046    else if (isSym(x)) {
   1047       if (x == isIntern(nm = name(x), Intern))
   1048          prIntern(nm);
   1049       else if (num(y = val(x)) & 1) {
   1050          if (nm == txt(0))
   1051             Env.put('\\'), outNum((word)x/sizeof(cell));
   1052          else
   1053             prTransient(nm);
   1054       }
   1055       else {
   1056          *(long*)&val(x) |= 1;
   1057          if (x == y && nm != txt(0))
   1058             prTransient(nm);
   1059          else {
   1060             outString("\\(");
   1061             if (nm == txt(0))
   1062                outNum((word)x/sizeof(cell));
   1063             else
   1064                prTransient(nm);
   1065             space(), save(y);
   1066             for (y = tail(x); isCell(y); y = car(y))
   1067                space(), save(cdr(y));
   1068             Env.put(')');
   1069          }
   1070       }
   1071    }
   1072    else {
   1073       y = x;
   1074       Env.put('(');
   1075       while (save(car(x)), !isNil(x = cdr(x))) {
   1076          if (x == y) {
   1077             outString(" .");
   1078             break;
   1079          }
   1080          if (!isCell(x)) {
   1081             outString(" . ");
   1082             save(x);
   1083             break;
   1084          }
   1085          space();
   1086       }
   1087       Env.put(')');
   1088    }
   1089 }
   1090 
   1091 // (save 'any) -> any
   1092 any doSave(any x) {
   1093    any p;
   1094    heap *h;
   1095 
   1096    x = cdr(x),  save(x = EVAL(car(x))),  crlf();
   1097    h = Heaps;
   1098    do {
   1099       p = h->cells + CELLS-1;
   1100       do
   1101          *(long*)&cdr(p) &= ~1;
   1102       while (--p >= h->cells);
   1103    } while (h = h->next);
   1104    return x;
   1105 }
   1106 
   1107 // (flush) -> flg
   1108 any doFlush(any ex __attribute__((unused))) {
   1109    return fflush(OutFile)? Nil : T;
   1110 }
	mplisp miniPicoLisp with FFI and modules for Buddy BDD library, OpenGL, Gtk and GMP
	git clone https://logand.com/git/mplisp.git/
	Log \| Files \| Refs