sjs/sectorlisp
1
0
Fork 0
mirror of https://github.com/samsonjs/sectorlisp.git synced 2026-04-27 14:57:41 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Improve LISP/C/ASM Rosetta Stone consistency

Browse source
This commit is contained in:
Justine Tunney 2021-10-30 00:42:55 -07:00
parent e09cdf6619
commit 05d2bcbfd9
5 changed files with 413 additions and 371 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

357
bestline.c
View file

@ -58,6 +58,7 @@
│ CTRL-L CLEAR │ │ CTRL-L CLEAR │
│ CTRL-H BACKSPACE │ │ CTRL-H BACKSPACE │
│ CTRL-D DELETE │ │ CTRL-D DELETE │
│ CTRL-Y YANK │
│ CTRL-D EOF (IF EMPTY) │ │ CTRL-D EOF (IF EMPTY) │
│ CTRL-N NEXT HISTORY │ │ CTRL-N NEXT HISTORY │
│ CTRL-P PREVIOUS HISTORY │ │ CTRL-P PREVIOUS HISTORY │
@ -69,13 +70,17 @@
│ ALT-B BACKWARD WORD │ │ ALT-B BACKWARD WORD │
│ CTRL-ALT-F FORWARD EXPR │ │ CTRL-ALT-F FORWARD EXPR │
│ CTRL-ALT-B BACKWARD EXPR │ │ CTRL-ALT-B BACKWARD EXPR │
│ ALT-RIGHT FORWARD EXPR │
│ ALT-LEFT BACKWARD EXPR │
│ ALT-SHIFT-B BARF EXPR │
│ ALT-SHIFT-S SLURP EXPR │
│ ALT-SHIFT-R RAISE EXPR │
│ CTRL-K KILL LINE FORWARDS │ │ CTRL-K KILL LINE FORWARDS │
│ CTRL-U KILL LINE BACKWARDS │ │ CTRL-U KILL LINE BACKWARDS │
│ ALT-H KILL WORD BACKWARDS │ │ ALT-H KILL WORD BACKWARDS │
│ CTRL-W KILL WORD BACKWARDS │ │ CTRL-W KILL WORD BACKWARDS │
│ CTRL-ALT-H KILL WORD BACKWARDS │ │ CTRL-ALT-H KILL WORD BACKWARDS │
│ ALT-D KILL WORD FORWARDS │ │ ALT-D KILL WORD FORWARDS │
│ CTRL-Y YANK │
│ ALT-Y ROTATE KILL RING AND YANK AGAIN │ │ ALT-Y ROTATE KILL RING AND YANK AGAIN │
│ ALT-\ SQUEEZE ADJACENT WHITESPACE │ │ ALT-\ SQUEEZE ADJACENT WHITESPACE │
│ CTRL-T TRANSPOSE │ │ CTRL-T TRANSPOSE │
@ -83,7 +88,6 @@
│ ALT-U UPPERCASE WORD │ │ ALT-U UPPERCASE WORD │
│ ALT-L LOWERCASE WORD │ │ ALT-L LOWERCASE WORD │
│ ALT-C CAPITALIZE WORD │ │ ALT-C CAPITALIZE WORD │
│ CTRL-C INTERRUPT PROCESS │
│ CTRL-Z SUSPEND PROCESS │ │ CTRL-Z SUSPEND PROCESS │
│ CTRL-\ QUIT PROCESS │ │ CTRL-\ QUIT PROCESS │
│ CTRL-S PAUSE OUTPUT │ │ CTRL-S PAUSE OUTPUT │
@ -243,7 +247,7 @@ static struct sigaction orig_cont;
static struct sigaction orig_winch; static struct sigaction orig_winch;
static struct termios orig_termios; static struct termios orig_termios;
static char *history[BESTLINE_MAX_HISTORY]; static char *history[BESTLINE_MAX_HISTORY];
static unsigned (*xlatCallback)(unsigned); static bestlineXlatCallback *xlatCallback;
static bestlineHintsCallback *hintsCallback; static bestlineHintsCallback *hintsCallback;
static bestlineFreeHintsCallback *freeHintsCallback; static bestlineFreeHintsCallback *freeHintsCallback;
static bestlineCompletionCallback *completionCallback; static bestlineCompletionCallback *completionCallback;
@ -290,7 +294,7 @@ static int GetMonospaceCharacterWidth(unsigned c) {
* and aren't in the number categorie (Nd, Nl, No). We also add a few * and aren't in the number categorie (Nd, Nl, No). We also add a few
* other things like blocks and emoji (So). * other things like blocks and emoji (So).
*/ */
static char IsSeparator(unsigned c) { char bestlineIsSeparator(unsigned c) {
int m, l, r, n; int m, l, r, n;
if (c < 0200) { if (c < 0200) {
return !(('0' <= c && c <= '9') || return !(('0' <= c && c <= '9') ||
@ -1070,8 +1074,8 @@ unsigned bestlineUppercase(unsigned c) {
} }
} }
static char NotSeparator(unsigned c) { char bestlineNotSeparator(unsigned c) {
return !IsSeparator(c); return !bestlineIsSeparator(c);
} }
static unsigned GetMirror(const unsigned short A[][2], size_t n, unsigned c) { static unsigned GetMirror(const unsigned short A[][2], size_t n, unsigned c) {
@ -1091,7 +1095,7 @@ static unsigned GetMirror(const unsigned short A[][2], size_t n, unsigned c) {
return 0; return 0;
} }
static unsigned GetMirrorLeft(unsigned c) { unsigned bestlineMirrorLeft(unsigned c) {
static const unsigned short kMirrorRight[][2] = { static const unsigned short kMirrorRight[][2] = {
{L')', L'('}, {L']', L'['}, {L'}', L'{'}, {L'⁆', L'⁅'}, {L')', L'('}, {L']', L'['}, {L'}', L'{'}, {L'⁆', L'⁅'},
{L'⁾', L'⁽'}, {L'₎', L'₍'}, {L'⌉', L'⌈'}, {L'⌋', L'⌊'}, {L'⁾', L'⁽'}, {L'₎', L'₍'}, {L'⌉', L'⌈'}, {L'⌋', L'⌊'},
@ -1110,7 +1114,7 @@ static unsigned GetMirrorLeft(unsigned c) {
c); c);
} }
static unsigned GetMirrorRight(unsigned c) { unsigned bestlineMirrorRight(unsigned c) {
static const unsigned short kMirrorLeft[][2] = { static const unsigned short kMirrorLeft[][2] = {
{L'(', L')'}, {L'[', L']'}, {L'{', L'}'}, {L'⁅', L'⁆'}, {L'(', L')'}, {L'[', L']'}, {L'{', L'}'}, {L'⁅', L'⁆'},
{L'⁽', L'⁾'}, {L'₍', L'₎'}, {L'⌈', L'⌉'}, {L'⌊', L'⌋'}, {L'⁽', L'⁾'}, {L'₍', L'₎'}, {L'⌈', L'⌉'}, {L'⌊', L'⌋'},
@ -1129,8 +1133,10 @@ static unsigned GetMirrorRight(unsigned c) {
c); c);
} }
static char IsXeparator(unsigned c) { char bestlineIsXeparator(unsigned c) {
return IsSeparator(c) && !GetMirrorLeft(c) && !GetMirrorRight(c); return (bestlineIsSeparator(c) &&
!bestlineMirrorLeft(c) &&
!bestlineMirrorRight(c));
} }
static unsigned Capitalize(unsigned c) { static unsigned Capitalize(unsigned c) {
@ -1331,7 +1337,7 @@ static char *GetLineBlock(FILE *f) {
} }
} }
static ssize_t ReadCharacter(int fd, char *p, size_t n) { long bestlineReadCharacter(int fd, char *p, unsigned long n) {
int e; int e;
size_t i; size_t i;
ssize_t rc; ssize_t rc;
@ -1444,7 +1450,16 @@ static ssize_t ReadCharacter(int fd, char *p, size_t n) {
break; break;
case kEsc: case kEsc:
if (0x20 <= c && c <= 0x2f) { /* Nf */ if (0x20 <= c && c <= 0x2f) { /* Nf */
/*
* Almost no one uses ANSI Nf sequences
* They overlaps with alt+graphic keystrokes
* We care more about being able to type alt-/
*/
if (c == ' ' || c == '#') {
t = kNf; t = kNf;
} else {
t = kDone;
}
} else if (0x30 <= c && c <= 0x3f) { /* Fp */ } else if (0x30 <= c && c <= 0x3f) { /* Fp */
t = kDone; t = kDone;
} else if (0x20 <= c && c <= 0x5F) { /* Fe */ } else if (0x20 <= c && c <= 0x5F) { /* Fe */
@ -1463,8 +1478,6 @@ static ssize_t ReadCharacter(int fd, char *p, size_t n) {
case '_': /* APC (Application Program Command) */ case '_': /* APC (Application Program Command) */
t = kStr; t = kStr;
break; break;
case '\\':
goto Whoopsie;
default: default:
t = kDone; t = kDone;
break; break;
@ -1562,7 +1575,7 @@ static char *GetLineChar(int fin, int fout) {
rc = -1; rc = -1;
break; break;
} }
if ((rc = ReadCharacter(fin, seq, sizeof(seq))) == -1) { if ((rc = bestlineReadCharacter(fin, seq, sizeof(seq))) == -1) {
if (errno == EAGAIN || errno == EWOULDBLOCK) { if (errno == EAGAIN || errno == EWOULDBLOCK) {
if (WaitUntilReady(fin, POLLIN) > 0) { if (WaitUntilReady(fin, POLLIN) > 0) {
continue; continue;
@ -1584,7 +1597,7 @@ static char *GetLineChar(int fin, int fout) {
} }
if (seq[0] == '\r') { if (seq[0] == '\r') {
if (HasPendingInput(fin)) { if (HasPendingInput(fin)) {
if ((rc = ReadCharacter(fin, seq + 1, sizeof(seq) - 1)) > 0) { if ((rc = bestlineReadCharacter(fin, seq + 1, sizeof(seq) - 1)) > 0) {
if (seq[0] == '\n') { if (seq[0] == '\n') {
break; break;
} }
@ -1681,12 +1694,19 @@ static int ParseUnsigned(const char *s, void *e) {
return x; return x;
} }
/**
* Returns UNICODE CJK Monospace Width of string.
*
* Control codes and ANSI sequences have a width of zero. We only parse
* a limited subset of ANSI here since we don't store ANSI codes in the
* linenoiseState::buf, but we do encourage CSI color codes in prompts.
*/
static size_t GetMonospaceWidth(const char *p, size_t n, char *out_haswides) { static size_t GetMonospaceWidth(const char *p, size_t n, char *out_haswides) {
int c, d; int c, d;
size_t i, w; size_t i, w;
struct rune r; struct rune r;
char haswides; char haswides;
enum { kAscii, kUtf8, kEsc, kCsi1, kCsi2, kSs, kNf, kStr, kStr2 } t; enum { kAscii, kUtf8, kEsc, kCsi1, kCsi2 } t;
for (haswides = r.c = r.n = w = i = 0, t = kAscii; i < n; ++i) { for (haswides = r.c = r.n = w = i = 0, t = kAscii; i < n; ++i) {
c = p[i] & 255; c = p[i] & 255;
switch (t) { switch (t) {
@ -1710,25 +1730,6 @@ static size_t GetMonospaceWidth(const char *p, size_t n, char *out_haswides) {
r.c <<= 6; r.c <<= 6;
r.c |= c & 077; r.c |= c & 077;
if (!--r.n) { if (!--r.n) {
switch (r.c) {
case 033:
t = kEsc;
break;
case 0x9b:
t = kCsi1;
break;
case 0x8e:
case 0x8f:
t = kSs;
break;
case 0x90:
case 0x98:
case 0x9d:
case 0x9e:
case 0x9f:
t = kStr;
break;
default:
d = GetMonospaceCharacterWidth(r.c); d = GetMonospaceCharacterWidth(r.c);
d = Max(0, d); d = Max(0, d);
w += d; w += d;
@ -1736,59 +1737,20 @@ static size_t GetMonospaceWidth(const char *p, size_t n, char *out_haswides) {
t = kAscii; t = kAscii;
break; break;
} }
}
} else { } else {
goto Whoopsie; goto Whoopsie;
} }
break; break;
case kEsc: case kEsc:
if (0x20 <= c && c <= 0x2f) { if (c == '[') {
t = kNf;
} else if (0x30 <= c && c <= 0x3f) {
t = kAscii;
} else if (0x20 <= c && c <= 0x5F) {
switch (c) {
case '[':
t = kCsi1; t = kCsi1;
break;
case 'N':
case 'O':
t = kSs;
break;
case 'P':
case 'X':
case ']':
case '^':
case '_':
t = kStr;
break;
default:
t = kAscii;
break;
}
} else if (0x60 <= c && c <= 0x7e) {
t = kAscii;
} else if (c == 033) {
if (i == 3) t = kAscii;
} else { } else {
t = kAscii; t = kAscii;
} }
break; break;
case kSs:
t = kAscii;
break;
case kNf:
if (0x30 <= c && c <= 0x7e) {
t = kAscii;
} else if (!(0x20 <= c && c <= 0x2f)) {
goto Whoopsie;
}
break;
case kCsi1: case kCsi1:
if (0x20 <= c && c <= 0x2f) { if (0x20 <= c && c <= 0x2f) {
t = kCsi2; t = kCsi2;
} else if (c == '[' && i == 3) {
/* linux function keys */
} else if (0x40 <= c && c <= 0x7e) { } else if (0x40 <= c && c <= 0x7e) {
t = kAscii; t = kAscii;
} else if (!(0x30 <= c && c <= 0x3f)) { } else if (!(0x30 <= c && c <= 0x3f)) {
@ -1802,31 +1764,6 @@ static size_t GetMonospaceWidth(const char *p, size_t n, char *out_haswides) {
goto Whoopsie; goto Whoopsie;
} }
break; break;
case kStr:
switch (c) {
case '\a':
t = kAscii;
break;
case 0033:
case 0302:
t = kStr2;
break;
default:
break;
}
break;
case kStr2:
switch (c) {
case '\a':
case '\\':
case 0234:
t = kAscii;
break;
default:
t = kStr;
break;
}
break;
default: default:
assert(0); assert(0);
} }
@ -1962,7 +1899,7 @@ static ssize_t bestlineRead(int fd, char *buf, size_t size,
refreshme = 1; refreshme = 1;
} }
if (refreshme) bestlineRefreshLine(l); if (refreshme) bestlineRefreshLine(l);
rc = ReadCharacter(fd, buf, size); rc = bestlineReadCharacter(fd, buf, size);
} while (rc == -1 && errno == EINTR); } while (rc == -1 && errno == EINTR);
if (rc != -1) { if (rc != -1) {
got = rc; got = rc;
@ -2271,11 +2208,11 @@ static size_t Backward(struct bestlineState *l, size_t pos) {
return pos; return pos;
} }
static int bestlineMirrorLeft(struct bestlineState *l, int res[2]) { static int bestlineEditMirrorLeft(struct bestlineState *l, int res[2]) {
unsigned c, pos, left, right, depth, index; unsigned c, pos, left, right, depth, index;
if ((pos = Backward(l, l->pos))) { if ((pos = Backward(l, l->pos))) {
right = GetUtf8(l->buf + pos, l->len - pos).c; right = GetUtf8(l->buf + pos, l->len - pos).c;
if ((left = GetMirrorLeft(right))) { if ((left = bestlineMirrorLeft(right))) {
depth = 0; depth = 0;
index = pos; index = pos;
do { do {
@ -2298,13 +2235,13 @@ static int bestlineMirrorLeft(struct bestlineState *l, int res[2]) {
return -1; return -1;
} }
static int bestlineMirrorRight(struct bestlineState *l, int res[2]) { static int bestlineEditMirrorRight(struct bestlineState *l, int res[2]) {
struct rune rune; struct rune rune;
unsigned pos, left, right, depth, index; unsigned pos, left, right, depth, index;
pos = l->pos; pos = l->pos;
rune = GetUtf8(l->buf + pos, l->len - pos); rune = GetUtf8(l->buf + pos, l->len - pos);
left = rune.c; left = rune.c;
if ((right = GetMirrorRight(left))) { if ((right = bestlineMirrorRight(left))) {
depth = 0; depth = 0;
index = pos; index = pos;
do { do {
@ -2326,10 +2263,10 @@ static int bestlineMirrorRight(struct bestlineState *l, int res[2]) {
return -1; return -1;
} }
static int bestlineMirror(struct bestlineState *l, int res[2]) { static int bestlineEditMirror(struct bestlineState *l, int res[2]) {
int rc; int rc;
rc = bestlineMirrorLeft(l, res); rc = bestlineEditMirrorLeft(l, res);
if (rc == -1) rc = bestlineMirrorRight(l, res); if (rc == -1) rc = bestlineEditMirrorRight(l, res);
return rc; return rc;
} }
@ -2365,7 +2302,7 @@ static void bestlineRefreshLineImpl(struct bestlineState *l, int force) {
gotwinch = 0; gotwinch = 0;
l->ws = GetTerminalSize(l->ws, l->ifd, l->ofd); l->ws = GetTerminalSize(l->ws, l->ifd, l->ofd);
} }
hasflip = !l->final && !bestlineMirror(l, flip); hasflip = !l->final && !bestlineEditMirror(l, flip);
StartOver: StartOver:
fd = l->ofd; fd = l->ofd;
@ -2599,14 +2536,14 @@ static size_t Forwards(struct bestlineState *l, size_t pos, char pred(unsigned))
} }
static size_t ForwardWord(struct bestlineState *l, size_t pos) { static size_t ForwardWord(struct bestlineState *l, size_t pos) {
pos = Forwards(l, pos, IsSeparator); pos = Forwards(l, pos, bestlineIsSeparator);
pos = Forwards(l, pos, NotSeparator); pos = Forwards(l, pos, bestlineNotSeparator);
return pos; return pos;
} }
static size_t BackwardWord(struct bestlineState *l, size_t pos) { static size_t BackwardWord(struct bestlineState *l, size_t pos) {
pos = Backwards(l, pos, IsSeparator); pos = Backwards(l, pos, bestlineIsSeparator);
pos = Backwards(l, pos, NotSeparator); pos = Backwards(l, pos, bestlineNotSeparator);
return pos; return pos;
} }
@ -2616,13 +2553,13 @@ static size_t EscapeWord(struct bestlineState *l) {
for (i = l->pos; i && i < l->len; i += r.n) { for (i = l->pos; i && i < l->len; i += r.n) {
if (i < l->len) { if (i < l->len) {
r = GetUtf8(l->buf + i, l->len - i); r = GetUtf8(l->buf + i, l->len - i);
if (IsSeparator(r.c)) break; if (bestlineIsSeparator(r.c)) break;
} }
if ((j = i)) { if ((j = i)) {
do --j; do --j;
while (j && (l->buf[j] & 0300) == 0200); while (j && (l->buf[j] & 0300) == 0200);
r = GetUtf8(l->buf + j, l->len - j); r = GetUtf8(l->buf + j, l->len - j);
if (IsSeparator(r.c)) break; if (bestlineIsSeparator(r.c)) break;
} }
} }
return i; return i;
@ -2652,22 +2589,22 @@ static void bestlineEditRightWord(struct bestlineState *l) {
static void bestlineEditLeftExpr(struct bestlineState *l) { static void bestlineEditLeftExpr(struct bestlineState *l) {
int mark[2]; int mark[2];
l->pos = Backwards(l, l->pos, IsXeparator); l->pos = Backwards(l, l->pos, bestlineIsXeparator);
if (!bestlineMirrorLeft(l, mark)) { if (!bestlineEditMirrorLeft(l, mark)) {
l->pos = mark[0]; l->pos = mark[0];
} else { } else {
l->pos = Backwards(l, l->pos, NotSeparator); l->pos = Backwards(l, l->pos, bestlineNotSeparator);
} }
bestlineRefreshLine(l); bestlineRefreshLine(l);
} }
static void bestlineEditRightExpr(struct bestlineState *l) { static void bestlineEditRightExpr(struct bestlineState *l) {
int mark[2]; int mark[2];
l->pos = Forwards(l, l->pos, IsXeparator); l->pos = Forwards(l, l->pos, bestlineIsXeparator);
if (!bestlineMirrorRight(l, mark)) { if (!bestlineEditMirrorRight(l, mark)) {
l->pos = Forward(l, mark[1]); l->pos = Forward(l, mark[1]);
} else { } else {
l->pos = Forwards(l, l->pos, NotSeparator); l->pos = Forwards(l, l->pos, bestlineNotSeparator);
} }
bestlineRefreshLine(l); bestlineRefreshLine(l);
} }
@ -2718,10 +2655,10 @@ static void bestlineEditXlatWord(struct bestlineState *l, unsigned xlat(unsigned
struct rune r; struct rune r;
struct abuf ab; struct abuf ab;
abInit(&ab); abInit(&ab);
i = Forwards(l, l->pos, IsSeparator); i = Forwards(l, l->pos, bestlineIsSeparator);
for (j = i; j < l->len; j += r.n) { for (j = i; j < l->len; j += r.n) {
r = GetUtf8(l->buf + j, l->len - j); r = GetUtf8(l->buf + j, l->len - j);
if (IsSeparator(r.c)) break; if (bestlineIsSeparator(r.c)) break;
if ((c = xlat(r.c)) != r.c) { if ((c = xlat(r.c)) != r.c) {
abAppendw(&ab, EncodeUtf8(c)); abAppendw(&ab, EncodeUtf8(c));
} else { /* avoid canonicalization */ } else { /* avoid canonicalization */
@ -2821,10 +2758,10 @@ static void bestlineEditTransposeWords(struct bestlineState *l) {
char *q, *p; char *q, *p;
size_t pi, xi, xj, yi, yj; size_t pi, xi, xj, yi, yj;
pi = EscapeWord(l); pi = EscapeWord(l);
xj = Backwards(l, pi, IsSeparator); xj = Backwards(l, pi, bestlineIsSeparator);
xi = Backwards(l, xj, NotSeparator); xi = Backwards(l, xj, bestlineNotSeparator);
yi = Forwards(l, pi, IsSeparator); yi = Forwards(l, pi, bestlineIsSeparator);
yj = Forwards(l, yi, NotSeparator); yj = Forwards(l, yi, bestlineNotSeparator);
if (!(xi < xj && xj < yi && yi < yj)) return; if (!(xi < xj && xj < yi && yi < yj)) return;
p = q = (char *)malloc(yj - xi); p = q = (char *)malloc(yj - xi);
p = Copy(p, l->buf + yi, yj - yi); p = Copy(p, l->buf + yi, yj - yi);
@ -2839,8 +2776,8 @@ static void bestlineEditTransposeWords(struct bestlineState *l) {
static void bestlineEditSqueeze(struct bestlineState *l) { static void bestlineEditSqueeze(struct bestlineState *l) {
size_t i, j; size_t i, j;
i = Backwards(l, l->pos, IsSeparator); i = Backwards(l, l->pos, bestlineIsSeparator);
j = Forwards(l, l->pos, IsSeparator); j = Forwards(l, l->pos, bestlineIsSeparator);
if (!(i < j)) return; if (!(i < j)) return;
memmove(l->buf + i, l->buf + j, l->len - j + 1); memmove(l->buf + i, l->buf + j, l->len - j + 1);
l->len -= j - i; l->len -= j - i;
@ -2932,6 +2869,149 @@ static void bestlineEditCtrlq(struct bestlineState *l) {
} }
} }
/**
* Moves last item inside current s-expression to outside, e.g.
*
* (a| b c)
* (a| b) c
*
* The cursor position changes only if a paren is moved before it:
*
* (a b c |)
* (a b) c |
*
* To accommodate non-LISP languages we connect unspaced outer symbols:
*
* f(a,| b, g())
* f(a,| b), g()
*
* Our standard keybinding is ALT-SHIFT-B.
*/
static void bestlineEditBarf(struct bestlineState *l) {
struct rune r;
unsigned long w;
size_t i, j, pos, depth = 0;
unsigned lhs, rhs, end, *stack = 0;
/* go as far right within current s-expr as possible */
for (pos = l->pos;; pos += r.n) {
if (pos == l->len) goto Finish;
r = GetUtf8(l->buf + pos, l->len - pos);
if (depth) {
if (r.c == stack[depth - 1]) {
--depth;
}
} else {
if ((rhs = bestlineMirrorRight(r.c))) {
stack = realloc(stack, ++depth * sizeof(*stack));
stack[depth - 1] = rhs;
} else if (bestlineMirrorLeft(r.c)) {
end = pos;
break;
}
}
}
/* go back one item */
pos = Backwards(l, pos, bestlineIsXeparator);
for (;; pos = i) {
if (!pos) goto Finish;
i = Backward(l, pos);
r = GetUtf8(l->buf + i, l->len - i);
if (depth) {
if (r.c == stack[depth - 1]) {
--depth;
}
} else {
if ((lhs = bestlineMirrorLeft(r.c))) {
stack = realloc(stack, ++depth * sizeof(*stack));
stack[depth - 1] = lhs;
} else if (bestlineIsSeparator(r.c)) {
break;
}
}
}
pos = Backwards(l, pos, bestlineIsXeparator);
/* now move the text */
r = GetUtf8(l->buf + end, l->len - end);
memmove(l->buf + pos + r.n, l->buf + pos, end - pos);
w = EncodeUtf8(r.c);
for (i = 0; i < r.n; ++i) {
l->buf[pos + i] = w;
w >>= 8;
}
if (l->pos > pos) {
l->pos += r.n;
}
bestlineRefreshLine(l);
Finish:
free(stack);
}
/**
* Moves first item outside current s-expression to inside, e.g.
*
* (a| b) c d
* (a| b c) d
*
* To accommodate non-LISP languages we connect unspaced outer symbols:
*
* f(a,| b), g()
* f(a,| b, g())
*
* Our standard keybinding is ALT-SHIFT-S.
*/
static void bestlineEditSlurp(struct bestlineState *l) {
char rp[6];
struct rune r;
unsigned long w;
size_t i, pos, depth = 0;
unsigned rhs, point = 0, start = 0, *stack = 0;
/* go to outside edge of current s-expr */
for (pos = l->pos; pos < l->len; pos += r.n) {
r = GetUtf8(l->buf + pos, l->len - pos);
if (depth) {
if (r.c == stack[depth - 1]) {
--depth;
}
} else {
if ((rhs = bestlineMirrorRight(r.c))) {
stack = realloc(stack, ++depth * sizeof(*stack));
stack[depth - 1] = rhs;
} else if (bestlineMirrorLeft(r.c)) {
point = pos;
pos += r.n;
start = pos;
break;
}
}
}
/* go forward one item */
pos = Forwards(l, pos, bestlineIsXeparator);
for (; pos < l->len ; pos += r.n) {
r = GetUtf8(l->buf + pos, l->len - pos);
if (depth) {
if (r.c == stack[depth - 1]) {
--depth;
}
} else {
if ((rhs = bestlineMirrorRight(r.c))) {
stack = realloc(stack, ++depth * sizeof(*stack));
stack[depth - 1] = rhs;
} else if (bestlineIsSeparator(r.c)) {
break;
}
}
}
/* now move the text */
memcpy(rp, l->buf + point, start - point);
memmove(l->buf + point, l->buf + start, pos - start);
memcpy(l->buf + pos - (start - point), rp, start - point);
bestlineRefreshLine(l);
free(stack);
}
static void bestlineEditRaise(struct bestlineState *l) {
}
/** /**
* Runs bestline engine. * Runs bestline engine.
* *
@ -2948,8 +3028,8 @@ static ssize_t bestlineEdit(int stdin_fd, int stdout_fd, const char *prompt,
char **obuf) { char **obuf) {
ssize_t rc; ssize_t rc;
size_t nread; size_t nread;
char *p, seq[16];
struct rune rune; struct rune rune;
char *p, seq[16];
unsigned long long w; unsigned long long w;
struct bestlineState l; struct bestlineState l;
memset(&l,0,sizeof(l)); memset(&l,0,sizeof(l));
@ -3002,10 +3082,20 @@ static ssize_t bestlineEdit(int stdin_fd, int stdout_fd, const char *prompt,
Case(Ctrl('L'), bestlineEditRefresh(&l)); Case(Ctrl('L'), bestlineEditRefresh(&l));
Case(Ctrl('Z'), bestlineEditSuspend()); Case(Ctrl('Z'), bestlineEditSuspend());
Case(Ctrl('U'), bestlineEditKillLeft(&l)); Case(Ctrl('U'), bestlineEditKillLeft(&l));
Case(Ctrl('C'), bestlineEditInterrupt());
Case(Ctrl('T'), bestlineEditTranspose(&l)); Case(Ctrl('T'), bestlineEditTranspose(&l));
Case(Ctrl('K'), bestlineEditKillRight(&l)); Case(Ctrl('K'), bestlineEditKillRight(&l));
Case(Ctrl('W'), bestlineEditRuboutWord(&l)); Case(Ctrl('W'), bestlineEditRuboutWord(&l));
case Ctrl('C'):
if (bestlineRead(l.ifd,seq,sizeof(seq),&l) != 1) break;
switch (seq[0]) {
Case(Ctrl('C'), bestlineEditInterrupt());
Case(Ctrl('B'), bestlineEditBarf(&l));
Case(Ctrl('S'), bestlineEditSlurp(&l));
Case(Ctrl('R'), bestlineEditRaise(&l));
default:
break;
}
break;
case Ctrl('X'): case Ctrl('X'):
if (l.seq[1][0] == Ctrl('X')) { if (l.seq[1][0] == Ctrl('X')) {
bestlineEditGoto(&l); bestlineEditGoto(&l);
@ -3035,6 +3125,9 @@ static ssize_t bestlineEdit(int stdin_fd, int stdout_fd, const char *prompt,
switch (seq[1]) { switch (seq[1]) {
Case('<', bestlineEditBof(&l)); Case('<', bestlineEditBof(&l));
Case('>', bestlineEditEof(&l)); Case('>', bestlineEditEof(&l));
Case('B', bestlineEditBarf(&l));
Case('S', bestlineEditSlurp(&l));
Case('R', bestlineEditRaise(&l));
Case('y', bestlineEditRotate(&l)); Case('y', bestlineEditRotate(&l));
Case('\\', bestlineEditSqueeze(&l)); Case('\\', bestlineEditSqueeze(&l));
Case('b', bestlineEditLeftWord(&l)); Case('b', bestlineEditLeftWord(&l));
@ -3420,7 +3513,7 @@ void bestlineSetFreeHintsCallback(bestlineFreeHintsCallback *fn) {
/** /**
* Sets character translation callback. * Sets character translation callback.
*/ */
void bestlineSetXlatCallback(unsigned fn(unsigned)) { void bestlineSetXlatCallback(bestlineXlatCallback *fn) {
xlatCallback = fn; xlatCallback = fn;
} }

10
bestline.h
View file

@ -9,11 +9,13 @@ typedef void(bestlineCompletionCallback)(const char *, bestlineCompletions *);
typedef char *(bestlineHintsCallback)(const char *, const char **, typedef char *(bestlineHintsCallback)(const char *, const char **,
const char **); const char **);
typedef void(bestlineFreeHintsCallback)(void *); typedef void(bestlineFreeHintsCallback)(void *);
typedef unsigned(bestlineXlatCallback)(unsigned);
void bestlineSetCompletionCallback(bestlineCompletionCallback *); void bestlineSetCompletionCallback(bestlineCompletionCallback *);
void bestlineSetHintsCallback(bestlineHintsCallback *); void bestlineSetHintsCallback(bestlineHintsCallback *);
void bestlineSetFreeHintsCallback(bestlineFreeHintsCallback *); void bestlineSetFreeHintsCallback(bestlineFreeHintsCallback *);
void bestlineAddCompletion(bestlineCompletions *, const char *); void bestlineAddCompletion(bestlineCompletions *, const char *);
void bestlineSetXlatCallback(bestlineXlatCallback *);
char *bestline(const char *); char *bestline(const char *);
char *bestlineRaw(const char *, int, int); char *bestlineRaw(const char *, int, int);
@ -28,6 +30,10 @@ void bestlineMaskModeEnable(void);
void bestlineMaskModeDisable(void); void bestlineMaskModeDisable(void);
void bestlineDisableRawMode(void); void bestlineDisableRawMode(void);
void bestlineFree(void *); void bestlineFree(void *);
unsigned bestlineLowercase(unsigned);
char bestlineIsSeparator(unsigned);
char bestlineNotSeparator(unsigned);
char bestlineIsXeparator(unsigned);
unsigned bestlineUppercase(unsigned); unsigned bestlineUppercase(unsigned);
void bestlineSetXlatCallback(unsigned(*)(unsigned)); unsigned bestlineLowercase(unsigned);
long bestlineReadCharacter(int, char *, unsigned long);

257
lisp.c
View file

@ -33,10 +33,10 @@
│ The LISP Challenge § LISP Machine ─╬─│┼ │ The LISP Challenge § LISP Machine ─╬─│┼
╚────────────────────────────────────────────────────────────────────────────│*/ ╚────────────────────────────────────────────────────────────────────────────│*/
#define ATOM 0 #define ATOM 1
#define CONS 1 #define CONS 0
#define ISATOM(x) (~(x)&1) #define ISATOM(x) ((x)&1)
#define VALUE(x) ((x)>>1) #define VALUE(x) ((x)>>1)
#define OBJECT(t,v) ((v)<<1|(t)) #define OBJECT(t,v) ((v)<<1|(t))
@ -52,17 +52,7 @@
#define ATOM_LAMBDA OBJECT(ATOM,38) #define ATOM_LAMBDA OBJECT(ATOM,38)
#define UNDEFINED OBJECT(ATOM,45) #define UNDEFINED OBJECT(ATOM,45)
struct Lisp { const char kSymbols[] =
int mem[8192];
unsigned char syntax[256];
int look;
int globals;
int index;
char token[128];
char str[8192];
};
static const char kSymbols[] =
"NIL\0" "NIL\0"
"T\0" "T\0"
"QUOTE\0" "QUOTE\0"
@ -78,53 +68,40 @@ static const char kSymbols[] =
#endif #endif
; ;
static struct Lisp q[1]; int g_look;
int g_index;
char g_token[128];
int g_mem[8192];
char g_str[8192];
static void Print(int); int GetList(void);
static int GetList(void); int GetObject(void);
static int GetObject(void); void PrintObject(int);
static void PrintObject(int); int Eval(int, int);
static int Eval(int, int);
static void SetupSyntax(void) { void SetupBuiltins(void) {
q->syntax[' '] = ' '; memmove(g_str, kSymbols, sizeof(kSymbols));
q->syntax['\r'] = ' ';
q->syntax['\n'] = ' ';
q->syntax['('] = '(';
q->syntax[')'] = ')';
q->syntax['.'] = '.';
q->syntax['\''] = '\'';
} }
static void SetupBuiltins(void) { int Car(int x) {
memmove(q->str, kSymbols, sizeof(kSymbols)); return g_mem[VALUE(x) + 0];
} }
static inline int Car(int x) { int Cdr(int x) {
return q->mem[VALUE(x) + 0]; return g_mem[VALUE(x) + 1];
} }
static inline int Cdr(int x) { int Cons(int car, int cdr) {
return q->mem[VALUE(x) + 1];
}
static int Set(int i, int k, int v) {
q->mem[VALUE(i) + 0] = k;
q->mem[VALUE(i) + 1] = v;
return i;
}
static int Cons(int car, int cdr) {
int i, cell; int i, cell;
i = q->index; i = g_index;
q->mem[i + 0] = car; g_mem[i + 0] = car;
q->mem[i + 1] = cdr; g_mem[i + 1] = cdr;
q->index = i + 2; g_index = i + 2;
cell = OBJECT(CONS, i); cell = OBJECT(CONS, i);
return cell; return cell;
} }
static char *StpCpy(char *d, char *s) { char *StpCpy(char *d, char *s) {
char c; char c;
do { do {
c = *s++; c = *s++;
@ -133,10 +110,10 @@ static char *StpCpy(char *d, char *s) {
return d; return d;
} }
static int Intern(char *s) { int Intern(char *s) {
int j, cx; int j, cx;
char c, *z, *t; char c, *z, *t;
z = q->str; z = g_str;
c = *z++; c = *z++;
while (c) { while (c) {
for (j = 0;; ++j) { for (j = 0;; ++j) {
@ -144,7 +121,7 @@ static int Intern(char *s) {
break; break;
} }
if (!c) { if (!c) {
return OBJECT(ATOM, z - q->str - j - 1); return OBJECT(ATOM, z - g_str - j - 1);
} }
c = *z++; c = *z++;
} }
@ -153,14 +130,14 @@ static int Intern(char *s) {
} }
--z; --z;
StpCpy(z, s); StpCpy(z, s);
return OBJECT(ATOM, z - q->str); return OBJECT(ATOM, z - g_str);
} }
static void PrintChar(unsigned char b) { void PrintChar(unsigned char b) {
if (write(1, &b, 1) == -1) exit(1); if (write(1, &b, 1) == -1) exit(1);
} }
static void PrintString(char *s) { void PrintString(char *s) {
char c; char c;
for (;;) { for (;;) {
if (!(c = s[0])) break; if (!(c = s[0])) break;
@ -169,12 +146,12 @@ static void PrintString(char *s) {
} }
} }
static int GetChar(void) { int GetChar(void) {
unsigned char b; int b;
static char *l, *p; static char *l, *p;
if (l || (l = p = bestlineWithHistory("* ", "sectorlisp"))) { if (l || (l = p = bestlineWithHistory("* ", "sectorlisp"))) {
if (*p) { if (*p) {
b = *p++; b = *p++ & 255;
} else { } else {
free(l); free(l);
l = p = 0; l = p = 0;
@ -182,108 +159,83 @@ static int GetChar(void) {
} }
return b; return b;
} else { } else {
PrintChar('\n'); PrintString("\n");
exit(0); exit(0);
} }
} }
static void GetToken(void) { void GetToken(void) {
char *t; int al;
int b, x; char *di;
b = q->look; di = g_token;
t = q->token; do {
for (;;) { if (g_look > ' ') {
x = q->syntax[b]; *di++ = g_look;
if (x != ' ') break;
b = GetChar();
} }
if (x) { al = g_look;
*t++ = b; g_look = GetChar();
b = GetChar(); } while (al <= ' ' || (al > ')' && g_look > ')'));
} else { *di++ = 0;
while (b && !x) {
*t++ = b;
b = GetChar();
x = q->syntax[b];
}
}
*t++ = 0;
q->look = b;
} }
static int ConsumeObject(void) { int ConsumeObject(void) {
GetToken(); GetToken();
return GetObject(); return GetObject();
} }
static int Cadr(int x) { int List(int x, int y) {
return Car(Cdr(x)); /* ((A B C D) (E F G) H I) → (E F G) */
}
static int List(int x, int y) {
return Cons(x, Cons(y, NIL)); return Cons(x, Cons(y, NIL));
} }
static int Quote(int x) { int Quote(int x) {
return List(ATOM_QUOTE, x); return List(ATOM_QUOTE, x);
} }
static int GetQuote(void) { int GetQuote(void) {
return Quote(ConsumeObject()); return Quote(ConsumeObject());
} }
static int AddList(int x) { int AddList(int x) {
return Cons(x, GetList()); return Cons(x, GetList());
} }
static int GetList(void) { int GetList(void) {
GetToken(); GetToken();
switch (*q->token & 0xFF) { #if QUOTES
default: if (*g_token == '.') return ConsumeObject();
if (*g_token == '\'') return AddList(GetQuote());
#endif
if (*g_token == ')') return NIL;
return AddList(GetObject()); return AddList(GetObject());
case ')':
return NIL;
case '.':
return ConsumeObject();
#if QUOTES
case '\'':
return AddList(GetQuote());
#endif
}
} }
static int GetObject(void) { int GetObject(void) {
switch (*q->token & 0xFF) {
default:
return Intern(q->token);
case '(':
return GetList();
#if QUOTES #if QUOTES
case '\'': if (*g_token == '\'') return GetQuote();
return GetQuote();
#endif #endif
} if (*g_token == '(') return GetList();
return Intern(g_token);
} }
static int ReadObject(void) { int ReadObject(void) {
q->look = GetChar(); g_look = GetChar();
GetToken(); GetToken();
return GetObject(); return GetObject();
} }
static int Read(void) { int Read(void) {
return ReadObject(); return ReadObject();
} }
static void PrintAtom(int x) { void PrintAtom(int x) {
PrintString(q->str + VALUE(x)); PrintString(g_str + VALUE(x));
} }
static void PrintList(int x) { void PrintList(int x) {
#if QUOTES #if QUOTES
if (Car(x) == ATOM_QUOTE) { if (Car(x) == ATOM_QUOTE) {
PrintChar('\''); PrintChar('\'');
PrintObject(Cadr(x)); PrintObject(Car(Cdr(x)));
return; return;
} }
#endif #endif
@ -294,7 +246,7 @@ static void PrintList(int x) {
PrintChar(' '); PrintChar(' ');
PrintObject(Car(x)); PrintObject(Car(x));
} else { } else {
PrintString(" . "); PrintString("∙");
PrintObject(x); PrintObject(x);
break; break;
} }
@ -302,7 +254,7 @@ static void PrintList(int x) {
PrintChar(')'); PrintChar(')');
} }
static void PrintObject(int x) { void PrintObject(int x) {
if (ISATOM(x)) { if (ISATOM(x)) {
PrintAtom(x); PrintAtom(x);
} else { } else {
@ -310,60 +262,46 @@ static void PrintObject(int x) {
} }
} }
static void Print(int i) { void Print(int i) {
PrintObject(i); PrintObject(i);
PrintString("\r\n"); PrintString("\n");
} }
/*───────────────────────────────────────────────────────────────────────────│─╗ /*───────────────────────────────────────────────────────────────────────────│─╗
│ The LISP Challenge § Bootstrap John McCarthy's Metacircular Evaluator ─╬─│┼ │ The LISP Challenge § Bootstrap John McCarthy's Metacircular Evaluator ─╬─│┼
╚────────────────────────────────────────────────────────────────────────────│*/ ╚────────────────────────────────────────────────────────────────────────────│*/
static int Caar(int x) { int Assoc(int x, int y) {
return Car(Car(x)); /* ((A B C D) (E F G) H I) → A */ if (y == NIL) return NIL;
if (x == Car(Car(y))) return Cdr(Car(y));
return Assoc(x, Cdr(y));
} }
static int Cdar(int x) { int Evcon(int c, int a) {
return Cdr(Car(x)); /* ((A B C D) (E F G) H I) → (B C D) */ if (Eval(Car(Car(c)), a) != NIL) {
return Eval(Car(Cdr(Car(c))), a);
} else {
return Evcon(Cdr(c), a);
}
} }
static int Cadar(int x) { int Pairlis(int x, int y, int a) {
return Cadr(Car(x)); /* ((A B C D) (E F G) H I) → B */ int di, si; /* it's zip() basically */
} if (x == NIL) return a;
static int Caddr(int x) {
return Cadr(Cdr(x)); /* ((A B C D) (E F G) H I) → H */
}
static int Caddar(int x) {
return Caddr(Car(x)); /* ((A B C D) (E F G) H I) → C */
}
static int Evcon(int c, int a) {
return Eval(Caar(c), a) != NIL ? Eval(Cadar(c), a) : Evcon(Cdr(c), a);
}
static int Assoc(int x, int a) {
return a ? Caar(a) == x ? Cdar(a) : Assoc(x, Cdr(a)) : NIL;
}
static int Pairlis(int x, int y, int a) { /* it's zip() basically */
int di, si;
if (!x) return a;
di = Cons(Car(x), Car(y)); di = Cons(Car(x), Car(y));
si = Pairlis(Cdr(x), Cdr(y), a); si = Pairlis(Cdr(x), Cdr(y), a);
return Cons(di, si); /* Tail-Modulo-Cons */ return Cons(di, si); /* Tail-Modulo-Cons */
} }
static int Evlis(int m, int a) { int Evlis(int m, int a) {
int di, si; int di, si;
if (!m) return NIL; if (m == NIL) return NIL;
di = Eval(Car(m), a); di = Eval(Car(m), a);
si = Evlis(Cdr(m), a); si = Evlis(Cdr(m), a);
return Cons(di, si); return Cons(di, si);
} }
static int Apply(int fn, int x, int a) { int Apply(int fn, int x, int a) {
int t1, si, ax; int t1, si, ax;
if (ISATOM(fn)) { if (ISATOM(fn)) {
switch (fn) { switch (fn) {
@ -372,15 +310,15 @@ static int Apply(int fn, int x, int a) {
return UNDEFINED; return UNDEFINED;
#endif #endif
case ATOM_CAR: case ATOM_CAR:
return Caar(x); return Car(Car(x));
case ATOM_CDR: case ATOM_CDR:
return Cdar(x); return Cdr(Car(x));
case ATOM_ATOM: case ATOM_ATOM:
return ISATOM(Car(x)) ? ATOM_T : NIL; return ISATOM(Car(x)) ? ATOM_T : NIL;
case ATOM_CONS: case ATOM_CONS:
return Cons(Car(x), Cadr(x)); return Cons(Car(x), Car(Cdr(x)));
case ATOM_EQ: case ATOM_EQ:
return Car(x) == Cadr(x) ? ATOM_T : NIL; return Car(x) == Car(Cdr(x)) ? ATOM_T : NIL;
default: default:
return Apply(Eval(fn, a), x, a); return Apply(Eval(fn, a), x, a);
} }
@ -388,27 +326,27 @@ static int Apply(int fn, int x, int a) {
if (Car(fn) == ATOM_LAMBDA) { if (Car(fn) == ATOM_LAMBDA) {
t1 = Cdr(fn); t1 = Cdr(fn);
si = Pairlis(Car(t1), x, a); si = Pairlis(Car(t1), x, a);
ax = Cadr(t1); ax = Car(Cdr(t1));
return Eval(ax, si); return Eval(ax, si);
} }
return UNDEFINED; return UNDEFINED;
} }
static int Evaluate(int e, int a) { int Evaluate(int e, int a) {
int ax; int ax;
if (ISATOM(e)) if (ISATOM(e))
return Assoc(e, a); return Assoc(e, a);
ax = Car(e); ax = Car(e);
if (ISATOM(ax)) { if (ISATOM(ax)) {
if (ax == ATOM_QUOTE) if (ax == ATOM_QUOTE)
return Cadr(e); return Car(Cdr(e));
if (ax == ATOM_COND) if (ax == ATOM_COND)
return Evcon(Cdr(e), a); return Evcon(Cdr(e), a);
} }
return Apply(ax, Evlis(Cdr(e), a), a); return Apply(ax, Evlis(Cdr(e), a), a);
} }
static int Eval(int e, int a) { int Eval(int e, int a) {
int ax; int ax;
#if TRACE #if TRACE
PrintString("> "); PrintString("> ");
@ -432,12 +370,11 @@ static int Eval(int e, int a) {
void Repl(void) { void Repl(void) {
for (;;) { for (;;) {
Print(Eval(Read(), q->globals)); Print(Eval(Read(), NIL));
} }
} }
int main(int argc, char *argv[]) { int main(int argc, char *argv[]) {
SetupSyntax();
SetupBuiltins(); SetupBuiltins();
bestlineSetXlatCallback(bestlineUppercase); bestlineSetXlatCallback(bestlineUppercase);
PrintString("THE LISP CHALLENGE V1\r\n" PrintString("THE LISP CHALLENGE V1\r\n"

66
lisp.lisp
View file

@ -73,44 +73,50 @@ NIL
;; CORRECT RESULT OF EXPRESSION IS STILL `A` ;; CORRECT RESULT OF EXPRESSION IS STILL `A`
;; REQUIRES CONS CAR CDR QUOTE ATOM EQ LAMBDA COND ;; REQUIRES CONS CAR CDR QUOTE ATOM EQ LAMBDA COND
;; SIMPLIFIED BUG FIXED VERSION OF JOHN MCCARTHY PAPER ;; SIMPLIFIED BUG FIXED VERSION OF JOHN MCCARTHY PAPER
;; NOTE: ((EQ (CAR E) NIL) (QUOTE *UNDEFINED)) CAN HELP ;; NOTE: ((EQ (CAR E) ()) (QUOTE *UNDEFINED)) CAN HELP
;; NOTE: ((EQ (CAR E) (QUOTE LAMBDA)) E) IS NICE ;; NOTE: ((EQ (CAR E) (QUOTE LAMBDA)) E) IS NICE
((LAMBDA (ASSOC EVCON BIND APPEND EVAL) ((LAMBDA (ASSOC EVCON PAIRLIS EVLIS APPLY EVAL)
(EVAL (QUOTE ((LAMBDA (FF X) (FF X)) (EVAL (QUOTE ((LAMBDA (FF X) (FF X))
(QUOTE (LAMBDA (X) (QUOTE (LAMBDA (X)
(COND ((ATOM X) X) (COND ((ATOM X) X)
((QUOTE T) (FF (CAR X)))))) ((QUOTE T) (FF (CAR X))))))
(QUOTE ((A) B C)))) (QUOTE ((A) B C))))
NIL)) ()))
(QUOTE (LAMBDA (X E) (QUOTE (LAMBDA (X Y)
(COND ((EQ E NIL) NIL) (COND ((EQ Y ()) ())
((EQ X (CAR (CAR E))) (CDR (CAR E))) ((EQ X (CAR (CAR Y)))
((QUOTE T) (ASSOC X (CDR E)))))) (CDR (CAR Y)))
(QUOTE (LAMBDA (C E) ((QUOTE T)
(COND ((EVAL (CAR (CAR C)) E) (EVAL (CAR (CDR (CAR C))) E)) (ASSOC X (CDR Y))))))
((QUOTE T) (EVCON (CDR C) E))))) (QUOTE (LAMBDA (C A)
(QUOTE (LAMBDA (V A E) (COND ((EVAL (CAR (CAR C)) A)
(COND ((EQ V NIL) E) (EVAL (CAR (CDR (CAR C))) A))
((QUOTE T) (CONS (CONS (CAR V) (EVAL (CAR A) E)) ((QUOTE T) (EVCON (CDR C) A)))))
(BIND (CDR V) (CDR A) E)))))) (QUOTE (LAMBDA (X Y A)
(QUOTE (LAMBDA (A B) (COND ((EQ X ()) A)
(COND ((EQ A NIL) B) ((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
((QUOTE T) (CONS (CAR A) (APPEND (CDR A) B)))))) (PAIRLIS (CDR X) (CDR Y) A))))))
(QUOTE (LAMBDA (M A)
(COND ((EQ M ()) ())
((QUOTE T) (CONS (EVAL (CAR M) A)
(EVLIS (CDR M) A A))))))
(QUOTE (LAMBDA (FN X A)
(COND
((ATOM FN)
(COND ((EQ FN (QUOTE CAR)) (CAR (CAR X)))
((EQ FN (QUOTE CDR)) (CDR (CAR X)))
((EQ FN (QUOTE ATOM)) (ATOM (CAR X)))
((EQ FN (QUOTE CONS)) (CONS (CAR X) (CAR (CDR X))))
((EQ FN (QUOTE EQ)) (EQ (CAR X) (CAR (CDR X))))
((QUOTE T) (APPLY (EVAL FN A) X A))))
((EQ (CAR FN) (QUOTE LAMBDA))
(EVAL (CAR (CDR (CDR FN)))
(PAIRLIS (CAR (CDR FN)) X A))))))
(QUOTE (LAMBDA (E A) (QUOTE (LAMBDA (E A)
(COND (COND
((ATOM E) (ASSOC E A)) ((ATOM E) (ASSOC E A))
((ATOM (CAR E)) ((ATOM (CAR E))
(COND (COND ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
((EQ (CAR E) (QUOTE ATOM)) (ATOM (EVAL (CAR (CDR E)) A)))
((EQ (CAR E) (QUOTE EQ)) (EQ (EVAL (CAR (CDR E)) A)
(EVAL (CAR (CDR (CDR E))) A)))
((EQ (CAR E) (QUOTE CAR)) (CAR (EVAL (CAR (CDR E)) A)))
((EQ (CAR E) (QUOTE CDR)) (CDR (EVAL (CAR (CDR E)) A)))
((EQ (CAR E) (QUOTE CONS)) (CONS (EVAL (CAR (CDR E)) A)
(EVAL (CAR (CDR (CDR E))) A)))
((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A)) ((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
((QUOTE T) (EVAL (CONS (EVAL (CAR E) A) (CDR E)) A)))) ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
((EQ (CAR (CAR E)) (QUOTE LAMBDA)) ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))))
(EVAL (CAR (CDR (CDR (CAR E))))
(BIND (CAR (CDR (CAR E))) (CDR E) A)))))))

22
sectorlisp.S
View file

@ -30,8 +30,8 @@
.set ATOM_CONS, 61 .set ATOM_CONS, 61
.set ATOM_EQ, 71 .set ATOM_EQ, 71
.set q.token, 0x4000 .set g_token, 0x4000
.set q.str, 0x4080 .set g_str, 0x4080
.set boot, 0x7c00 .set boot, 0x7c00
//////////////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////////////////
@ -56,10 +56,10 @@ _begin: push %cs # memory model cs=ds=es = 0x600
mov %cx,%sp mov %cx,%sp
cld cld
xor %ax,%ax xor %ax,%ax
mov %ax,%fs # fs = &q.mem mov %ax,%fs # fs = &g_mem
xor %di,%di xor %di,%di
rep stosb # clears our bss memory rep stosb # clears our bss memory
main: mov $q.str,%di main: mov $g_str,%di
mov $kSymbols,%si mov $kSymbols,%si
mov $37,%cx mov $37,%cx
rep movsb rep movsb
@ -73,15 +73,15 @@ main: mov $q.str,%di
call PutChar call PutChar
jmp 0b jmp 0b
GetToken: # GetToken():al, dl is q.look GetToken: # GetToken():al, dl is g_look
mov $q.token,%di mov $g_token,%di
1: mov %dl,%al 1: mov %dl,%al
cmp $' ',%al cmp $' ',%al
jbe 2f jbe 2f
stosb stosb
xchg %ax,%cx xchg %ax,%cx
2: call GetChar # bh = 0 after PutChar 2: call GetChar # bh = 0 after PutChar
xchg %ax,%dx # dl = q.look xchg %ax,%dx # dl = g_look
cmp $' ',%al cmp $' ',%al
jbe 1b jbe 1b
cmp $')',%al cmp $')',%al
@ -95,10 +95,10 @@ GetToken: # GetToken():al, dl is q.look
GetObject: # called just after GetToken GetObject: # called just after GetToken
cmpb $'(',%al cmpb $'(',%al
je GetList je GetList
mov $q.token,%si mov $g_token,%si
.Intern: .Intern:
mov %si,%bx # save s mov %si,%bx # save s
mov $q.str,%di mov $g_str,%di
xor %al,%al xor %al,%al
0: mov $-1,%cl 0: mov $-1,%cl
push %di # save 1 push %di # save 1
@ -118,7 +118,7 @@ GetObject: # called just after GetToken
test %al,%al test %al,%al
jnz 3b jnz 3b
4: pop %ax # restore 1 4: pop %ax # restore 1
add $-q.str,%ax # stc add $-g_str,%ax # stc
adc %ax,%ax # ax = 2 * ax + carry adc %ax,%ax # ax = 2 * ax + carry
.ret: ret .ret: ret
@ -128,7 +128,7 @@ PrintObject: # PrintObject(x:ax)
jz .PrintList jz .PrintList
.PrintAtom: .PrintAtom:
shr %di shr %di
lea q.str(%di),%si lea g_str(%di),%si
.PrintString: # nul-terminated in si .PrintString: # nul-terminated in si
lodsb lodsb
test %al,%al test %al,%al