hyung-hwan/qse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

* fixed an issue in parsing an expression like "a++ ++b" or "1 ++b"

Browse Source 
* added _WIN32 code handling QSE_PIO_MBSCMD
* fixed various _WIN32 issues in qse_env_t
* added untested OS2 code handling QSE_PIO_MBSCMD
This commit is contained in:
hyung-hwan 2011-08-12 09:11:02 +00:00
parent cfe85ecc60
commit f843a6e003
13 changed files with 497 additions and 834 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
qse/lib/awk/parse.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: parse.c 521 2011-07-25 08:25:13Z hyunghwan.chung $ * $Id: parse.c 540 2011-08-11 15:11:02Z hyunghwan.chung $
* *
Copyright 2006-2011 Chung, Hyung-Hwan. Copyright 2006-2011 Chung, Hyung-Hwan.
This file is part of QSE. This file is part of QSE.
@ -4141,22 +4141,27 @@ static qse_awk_nde_t* parse_increment (
opcode2 = MATCH(awk,TOK_PLUSPLUS)? QSE_AWK_INCOP_PLUS: opcode2 = MATCH(awk,TOK_PLUSPLUS)? QSE_AWK_INCOP_PLUS:
MATCH(awk,TOK_MINUSMINUS)? QSE_AWK_INCOP_MINUS: -1; MATCH(awk,TOK_MINUSMINUS)? QSE_AWK_INCOP_MINUS: -1;
if (opcode1 != -1 && opcode2 != -1) if ((awk->option & QSE_AWK_EXPLICIT) && !(awk->option & QSE_AWK_IMPLICIT))
{ {
/* both prefix and postfix increment operator. if (opcode1 != -1 && opcode2 != -1)
* not allowed */ {
qse_awk_clrpt (awk, left); /* both prefix and postfix increment operator.
SETERR_LOC (awk, QSE_AWK_EPREPST, xloc); * not allowed */
return QSE_NULL; qse_awk_clrpt (awk, left);
SETERR_LOC (awk, QSE_AWK_EPREPST, xloc);
return QSE_NULL;
}
} }
else if (opcode1 == -1 && opcode2 == -1)
if (opcode1 == -1 && opcode2 == -1)
{ {
/* no increment operators */ /* no increment operators */
return left; return left;
} }
else if (opcode1 != -1) else if (opcode1 != -1)
{ {
/* prefix increment operator */ /* prefix increment operator.
* ignore a potential postfix operator */
type = QSE_AWK_NDE_EXP_INCPRE; type = QSE_AWK_NDE_EXP_INCPRE;
opcode = opcode1; opcode = opcode1;
} }
@ -4175,9 +4180,18 @@ static qse_awk_nde_t* parse_increment (
if (!is_var(left) && left->type != QSE_AWK_NDE_POS) if (!is_var(left) && left->type != QSE_AWK_NDE_POS)
{ {
qse_awk_clrpt (awk, left); if (type == QSE_AWK_NDE_EXP_INCPST)
SETERR_LOC (awk, QSE_AWK_EINCDECOPR, xloc); {
return QSE_NULL; /* For an expression like 1 ++y,
* left is 1. so we leave ++ for y. */
return left;
}
else
{
qse_awk_clrpt (awk, left);
SETERR_LOC (awk, QSE_AWK_EINCDECOPR, xloc);
return QSE_NULL;
}
} }
nde = (qse_awk_nde_exp_t*) nde = (qse_awk_nde_exp_t*)

56
qse/lib/cmn/env.c
View File

@ -23,6 +23,10 @@
#include <qse/cmn/str.h> #include <qse/cmn/str.h>
#include "mem.h" #include "mem.h"
#if defined(_WIN32)
# include <windows.h>
#endif
#define STRSIZE 4096 #define STRSIZE 4096
#define ARRSIZE 128 #define ARRSIZE 128
@ -207,7 +211,7 @@ static int add_envstrw (qse_env_t* env, const qse_wchar_t* nv)
return 0; return 0;
} }
static int deletem (qse_env_t* env, const qse_wchar_t* name) static int deletew (qse_env_t* env, const qse_wchar_t* name)
{ {
qse_size_t i; qse_size_t i;
@ -224,7 +228,7 @@ static int deletem (qse_env_t* env, const qse_wchar_t* name)
/* bingo */ /* bingo */
qse_size_t len, rem; qse_size_t len, rem;
len = qse_mbslen (vp) + 1; len = qse_wcslen (vp) + 1;
rem = env->str.len - (vp + len - env->str.ptr) + 1; rem = env->str.len - (vp + len - env->str.ptr) + 1;
QSE_MEMCPY (vp, vp + len, rem * QSE_SIZEOF(*vp)); QSE_MEMCPY (vp, vp + len, rem * QSE_SIZEOF(*vp));
env->str.len -= len; env->str.len -= len;
@ -416,7 +420,7 @@ int qse_env_deletem (qse_env_t* env, const qse_mchar_t* name)
} }
#if defined(_WIN32) #if defined(_WIN32)
static qse_char_t* getenv (const qse_char_t* name, int* free) static qse_char_t* get_env (qse_env_t* env, const qse_char_t* name, int* free)
{ {
DWORD n; DWORD n;
@ -449,7 +453,7 @@ static qse_char_t* getenv (const qse_char_t* name, int* free)
# error IMPLEMENT THIS # error IMPLEMENT THIS
#else #else
static qse_mchar_t* getenv (const qse_mchar_t* name, int* free) static qse_mchar_t* get_env (qse_env_t* env, const qse_mchar_t* name, int* free)
{ {
extern char** environ; extern char** environ;
char** p = environ; char** p = environ;
@ -473,13 +477,16 @@ static qse_mchar_t* getenv (const qse_mchar_t* name, int* free)
int qse_env_insertsysw (qse_env_t* env, const qse_wchar_t* name) int qse_env_insertsysw (qse_env_t* env, const qse_wchar_t* name)
{ {
#if defined(_WIN32) && defined(QSE_CHAR_IS_WCHAR) #if defined(_WIN32) && defined(QSE_CHAR_IS_WCHAR)
int ret, free;
qse_wchar_t* v; qse_wchar_t* v;
int free;
int ret = -1;
v = getenv (name, &free); v = get_env (env, name, &free);
if (v == QSE_NULL) return 0; if (v)
ret = insertw (env, name, v); {
if (free) QSE_MMGR_FREE (env->mmgr, v); ret = insertw (env, name, v);
if (free) QSE_MMGR_FREE (env->mmgr, v);
}
return ret; return ret;
#else #else
/* convert wchar to mchar */ /* convert wchar to mchar */
@ -513,13 +520,16 @@ int qse_env_insertsysm (qse_env_t* env, const qse_mchar_t* name)
return ret; return ret;
#else #else
int ret, free;
qse_mchar_t* v; qse_mchar_t* v;
int free;
int ret = -1;
v = getenv (name, &free); v = get_env (env, name, &free);
if (v == QSE_NULL) return -1; if (v)
ret = insertm (env, name, v); {
if (free) QSE_MMGR_FREE (env->mmgr, v); ret = insertm (env, name, v);
if (free) QSE_MMGR_FREE (env->mmgr, v);
}
return ret; return ret;
#endif #endif
} }
@ -536,14 +546,24 @@ static int load_curenv (qse_env_t* env)
#if defined(QSE_CHAR_IS_WCHAR) #if defined(QSE_CHAR_IS_WCHAR)
while (*envstr != QSE_WT('\0')) while (*envstr != QSE_WT('\0'))
{ {
if (add_envstrw (env, envstr) <= -1) { ret = -1; goto done; } /* It seems that entries like the followings exist in the
envstr += qse_wcslen(evnstr) + 1; * environment variable string.
* - =::=::\
* - =C:=C:\Documents and Settings\Administrator
* - =ExitCode=00000000
*
* So entries beginning with = are excluded.
*/
if (*envstr != QSE_WT('=') &&
add_envstrw (env, envstr) <= -1) { ret = -1; goto done; }
envstr += qse_wcslen (envstr) + 1;
} }
#else #else
while (*envstr != QSE_MT('\0')) while (*envstr != QSE_MT('\0'))
{ {
if (add_envstrm (env, envstr) <= -1) { ret = -1; goto done; } if (*envstr != QSE_MT('=') &&
envstr += qse_mbslen(evnstr) + 1; add_envstrm (env, envstr) <= -1) { ret = -1; goto done; }
envstr += qse_mbslen (envstr) + 1;
} }
#endif #endif

106
qse/lib/cmn/pio.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: pio.c 539 2011-08-10 16:18:35Z hyunghwan.chung $ * $Id: pio.c 540 2011-08-11 15:11:02Z hyunghwan.chung $
* *
Copyright 2006-2011 Chung, Hyung-Hwan. Copyright 2006-2011 Chung, Hyung-Hwan.
This file is part of QSE. This file is part of QSE.
@ -244,19 +244,66 @@ qse_pio_t* qse_pio_init (
* takes the entire command line */ * takes the entire command line */
{ {
const qse_char_t* dupcmd; qse_char_t* dupcmd;
BOOL x; BOOL x;
if (oflags & QSE_PIO_SHELL) if (oflags & QSE_PIO_SHELL)
{ {
qse_size_t reqlen;
#if defined(QSE_CHAR_IS_WCHAR)
if (oflags & QSE_PIO_MBSCMD)
{
const qse_mchar_t* mbs = (const qse_mchar_t*)cmd;
qse_size_t ll = qse_mbstowcslen (mbs, &reqlen);
if (mbs[ll] != QSE_MT('\0')) goto oops; /* illegal sequence */
}
else
{
#endif
reqlen = qse_strlen(cmd);
#if defined(QSE_CHAR_IS_WCHAR)
}
#endif
reqlen++; /* increment for a terminating null */
dupcmd = QSE_MMGR_ALLOC ( dupcmd = QSE_MMGR_ALLOC (
mmgr, (11+qse_strlen(cmd)+1 )*QSE_SIZEOF(qse_char_t)); mmgr, (11 + reqlen) * QSE_SIZEOF(*dupcmd)
);
if (dupcmd == QSE_NULL) goto oops; if (dupcmd == QSE_NULL) goto oops;
qse_strcpy (dupcmd, QSE_T("cmd.exe /c ")); qse_strcpy (dupcmd, QSE_T("cmd.exe /c "));
qse_strcpy (&dupcmd[11], cmd);
#if defined(QSE_CHAR_IS_WCHAR)
if (oflags & QSE_PIO_MBSCMD)
{
qse_mbstowcs ((const qse_mchar_t*)cmd, &dupcmd[11], &reqlen);
}
else
{
#endif
qse_strcpy (&dupcmd[11], cmd);
#if defined(QSE_CHAR_IS_WCHAR)
}
#endif
}
else
{
#if defined(QSE_CHAR_IS_WCHAR)
if (oflags & QSE_PIO_MBSCMD)
{
dupcmd = qse_mbstowcsdup ((const qse_mchar_t*)cmd, mmgr);
}
else
{
#endif
/* CreateProcess requires command buffer to be read-write. */
dupcmd = qse_strdup (cmd, mmgr);
#if defined(QSE_CHAR_IS_WCHAR)
}
#endif
if (dupcmd == QSE_NULL) goto oops;
} }
else dupcmd = cmd;
x = CreateProcess ( x = CreateProcess (
QSE_NULL, /* LPCTSTR lpApplicationName */ QSE_NULL, /* LPCTSTR lpApplicationName */
@ -275,7 +322,7 @@ qse_pio_t* qse_pio_init (
&procinfo /* LPPROCESS_INFORMATION lpProcessInformation */ &procinfo /* LPPROCESS_INFORMATION lpProcessInformation */
); );
if (dupcmd != cmd) QSE_MMGR_FREE (mmgr, dupcmd); QSE_MMGR_FREE (mmgr, dupcmd);
if (x == FALSE) goto oops; if (x == FALSE) goto oops;
} }
@ -459,11 +506,18 @@ qse_pio_t* qse_pio_init (
#ifdef QSE_CHAR_IS_MCHAR #ifdef QSE_CHAR_IS_MCHAR
mn = qse_strlen(cmd); mn = qse_strlen(cmd);
#else #else
n = qse_wcstombslen (cmd, &mn); if (oflags & QSE_PIO_MBSCMD)
if (cmd[n] != QSE_WT('\0')) goto oops; /* illegal sequence found */ {
mn = qse_mbslen((const qse_mchar_t*)cmd);
}
else
{
n = qse_wcstombslen (cmd, &mn);
if (cmd[n] != QSE_WT('\0')) goto oops; /* illegal sequence found */
}
#endif #endif
cmd_line = QSE_MMGR_ALLOC ( cmd_line = QSE_MMGR_ALLOC (
mmgr, ((11+mn+1+1) * QSE_SIZEOF(qse_mchar_t))); mmgr, ((11+mn+1+1) * QSE_SIZEOF(*cmd_line)));
if (cmd_line == QSE_NULL) goto oops; if (cmd_line == QSE_NULL) goto oops;
qse_mbscpy (cmd_line, QSE_MT("cmd.exe")); /* cmd.exe\0/c */ qse_mbscpy (cmd_line, QSE_MT("cmd.exe")); /* cmd.exe\0/c */
@ -471,8 +525,15 @@ qse_pio_t* qse_pio_init (
#ifdef QSE_CHAR_IS_MCHAR #ifdef QSE_CHAR_IS_MCHAR
qse_mbscpy (&cmd_line[11], cmd); qse_mbscpy (&cmd_line[11], cmd);
#else #else
mn = mn + 1; /* update the buffer size */ if (oflags & QSE_PIO_MBSCMD)
n = qse_wcstombs (cmd, &cmd_line[11], &mn); {
qse_mbscpy (&cmd_line[11], (const qse_mchar_t*)cmd);
}
else
{
mn = mn + 1; /* update the buffer size */
n = qse_wcstombs (cmd, &cmd_line[11], &mn);
}
#endif #endif
cmd_line[11+mn+1] = QSE_MT('\0'); /* additional \0 after \0 */ cmd_line[11+mn+1] = QSE_MT('\0'); /* additional \0 after \0 */
@ -487,15 +548,24 @@ qse_pio_t* qse_pio_init (
cmd_line = qse_strdup2 (cmd, QSE_T(" "), pio->mmgr); cmd_line = qse_strdup2 (cmd, QSE_T(" "), pio->mmgr);
if (cmd_line == QSE_NULL) goto oops; if (cmd_line == QSE_NULL) goto oops;
#else #else
qse_size_t n, mn; if (oflags & QSE_PIO_MBSCMD)
n = qse_wcstombslen (cmd, &mn); {
if (cmd[n] != QSE_T('\0')) goto oops; /* illegal sequence in cmd */ qse_size_t mn = qse_mbslen((const qse_mchar_t*)cmd);
cmd_line = qse_mbsdup2 ((const qse_mchar_t*)cmd, QSE_MT(" "), pio->mmgr);
if (cmd_line == QSE_NULL) goto oops;
}
else
{
qse_size_t n, mn;
n = qse_wcstombslen (cmd, &mn);
if (cmd[n] != QSE_T('\0')) goto oops; /* illegal sequence in cmd */
mn = mn + 1; mn = mn + 1;
cmd_line = QSE_MMGR_ALLOC (pio->mmgr, mn * QSE_SIZEOF(qse_char_t)); cmd_line = QSE_MMGR_ALLOC (pio->mmgr, mn * QSE_SIZEOF(qse_char_t));
if (cmd_line == QSE_NULL) goto oops; if (cmd_line == QSE_NULL) goto oops;
qse_wcstombs (cmd, cmd_line, &mn); qse_wcstombs (cmd, cmd_line, &mn);
}
#endif #endif
/* TODO: enhance this part by: /* TODO: enhance this part by:

46
qse/lib/cmn/xma.c
View File

@ -716,14 +716,20 @@ void qse_xma_dump (qse_xma_t* xma, qse_xma_dumper_t dumper, void* ctx)
#ifdef QSE_XMA_ENABLE_STAT #ifdef QSE_XMA_ENABLE_STAT
dumper (ctx, QSE_T("== statistics ==\n")); dumper (ctx, QSE_T("== statistics ==\n"));
#if QSE_SIZEOF_LONG >= QSE_SIZEOF_LONG_LONG #if (QSE_SIZEOF_SIZE_T == QSE_SIZEOF_LONG)
dumper (ctx, QSE_T("total = %lu\n"), (unsigned long)xma->stat.total); dumper (ctx, QSE_T("total = %lu\n"), (unsigned long)xma->stat.total);
dumper (ctx, QSE_T("alloc = %lu\n"), (unsigned long)xma->stat.alloc); dumper (ctx, QSE_T("alloc = %lu\n"), (unsigned long)xma->stat.alloc);
dumper (ctx, QSE_T("avail = %lu\n"), (unsigned long)xma->stat.avail); dumper (ctx, QSE_T("avail = %lu\n"), (unsigned long)xma->stat.avail);
#else #elif (QSE_SIZEOF_SIZE_T == QSE_SIZEOF_LONG_LONG)
dumper (ctx, QSE_T("total = %llu\n"), (unsigned long long)xma->stat.total); dumper (ctx, QSE_T("total = %llu\n"), (unsigned long long)xma->stat.total);
dumper (ctx, QSE_T("alloc = %llu\n"), (unsigned long long)xma->stat.alloc); dumper (ctx, QSE_T("alloc = %llu\n"), (unsigned long long)xma->stat.alloc);
dumper (ctx, QSE_T("avail = %llu\n"), (unsigned long long)xma->stat.avail); dumper (ctx, QSE_T("avail = %llu\n"), (unsigned long long)xma->stat.avail);
#elif (QSE_SIZEOF_SIZE_T == QSE_SIZEOF_INT)
dumper (ctx, QSE_T("total = %u\n"), (unsigned int)xma->stat.total);
dumper (ctx, QSE_T("alloc = %u\n"), (unsigned int)xma->stat.alloc);
dumper (ctx, QSE_T("avail = %u\n"), (unsigned int)xma->stat.avail);
#else
# error weird size of qse_size_t. unsupported platform
#endif #endif
#endif #endif
@ -731,14 +737,20 @@ void qse_xma_dump (qse_xma_t* xma, qse_xma_dumper_t dumper, void* ctx)
dumper (ctx, QSE_T(" size avail address\n")); dumper (ctx, QSE_T(" size avail address\n"));
for (tmp = xma->head, fsum = 0, asum = 0; tmp; tmp = tmp->b.next) for (tmp = xma->head, fsum = 0, asum = 0; tmp; tmp = tmp->b.next)
{ {
#if QSE_SIZEOF_LONG >= QSE_SIZEOF_LONG_LONG #if (QSE_SIZEOF_SIZE_T == QSE_SIZEOF_LONG)
dumper (ctx, QSE_T(" %-18lu %-5d %p\n"), dumper (ctx, QSE_T(" %-18lu %-5u %p\n"),
(unsigned long)tmp->size, tmp->avail, tmp (unsigned long)tmp->size, (unsigned int)tmp->avail, tmp
);
#elif (QSE_SIZEOF_SIZE_T == QSE_SIZEOF_LONG_LONG)
dumper (ctx, QSE_T(" %-18llu %-5u %p\n"),
(unsigned long long)tmp->size, (unsigned int)tmp->avail, tmp
);
#elif (QSE_SIZEOF_SIZE_T == QSE_SIZEOF_INT)
dumper (ctx, QSE_T(" %-18u %-5u %p\n"),
(unsigned int)tmp->size, (unsigned int)tmp->avail, tmp
); );
#else #else
dumper (ctx, QSE_T(" %-18llu %-5d %p\n"), # error weird size of qse_size_t. unsupported platform
(unsigned long long)tmp->size, tmp->avail, tmp
);
#endif #endif
if (tmp->avail) fsum += tmp->size; if (tmp->avail) fsum += tmp->size;
else asum += tmp->size; else asum += tmp->size;
@ -749,21 +761,31 @@ void qse_xma_dump (qse_xma_t* xma, qse_xma_dumper_t dumper, void* ctx)
#endif #endif
dumper (ctx, QSE_T("---------------------------------------\n")); dumper (ctx, QSE_T("---------------------------------------\n"));
#if QSE_SIZEOF_LONG >= QSE_SIZEOF_LONG_LONG #if (QSE_SIZEOF_ULONG_T == QSE_SIZEOF_LONG)
dumper (ctx, QSE_T("Allocated blocks: %18lu bytes\n"), (unsigned long)asum); dumper (ctx, QSE_T("Allocated blocks: %18lu bytes\n"), (unsigned long)asum);
dumper (ctx, QSE_T("Available blocks: %18lu bytes\n"), (unsigned long)fsum); dumper (ctx, QSE_T("Available blocks: %18lu bytes\n"), (unsigned long)fsum);
#else #elif (QSE_SIZEOF_ULONG_T == QSE_SIZEOF_LONG_LONG)
dumper (ctx, QSE_T("Allocated blocks: %18llu bytes\n"), (unsigned long long)asum); dumper (ctx, QSE_T("Allocated blocks: %18llu bytes\n"), (unsigned long long)asum);
dumper (ctx, QSE_T("Available blocks: %18llu bytes\n"), (unsigned long long)fsum); dumper (ctx, QSE_T("Available blocks: %18llu bytes\n"), (unsigned long long)fsum);
#elif (QSE_SIZEOF_ULONG_T == QSE_SIZEOF_INT)
dumper (ctx, QSE_T("Allocated blocks: %18u bytes\n"), (unsigned int)asum);
dumper (ctx, QSE_T("Available blocks: %18u bytes\n"), (unsigned int)fsum);
#else
# error weird size of qse_ulong_t. unsupported platform
#endif #endif
#ifdef QSE_XMA_ENABLE_STAT #ifdef QSE_XMA_ENABLE_STAT
#if QSE_SIZEOF_LONG >= QSE_SIZEOF_LONG_LONG #if (QSE_SIZEOF_ULONG_T == QSE_SIZEOF_LONG)
dumper (ctx, QSE_T("Internal use : %18lu bytes\n"), (unsigned long)isum); dumper (ctx, QSE_T("Internal use : %18lu bytes\n"), (unsigned long)isum);
dumper (ctx, QSE_T("Total : %18lu bytes\n"), (unsigned long)(asum + fsum + isum)); dumper (ctx, QSE_T("Total : %18lu bytes\n"), (unsigned long)(asum + fsum + isum));
#else #elif (QSE_SIZEOF_ULONG_T == QSE_SIZEOF_LONG_LONG)
dumper (ctx, QSE_T("Internal use : %18llu bytes\n"), (unsigned long long)isum); dumper (ctx, QSE_T("Internal use : %18llu bytes\n"), (unsigned long long)isum);
dumper (ctx, QSE_T("Total : %18llu bytes\n"), (unsigned long long)(asum + fsum + isum)); dumper (ctx, QSE_T("Total : %18llu bytes\n"), (unsigned long long)(asum + fsum + isum));
#elif (QSE_SIZEOF_ULONG_T == QSE_SIZEOF_INT)
dumper (ctx, QSE_T("Internal use : %18u bytes\n"), (unsigned int)isum);
dumper (ctx, QSE_T("Total : %18u bytes\n"), (unsigned int)(asum + fsum + isum));
#else
# error weird size of qse_ulong_t. unsupported platform
#endif #endif
#endif #endif

5
qse/regress/awk/lang-024.awk
View File

@ -3,5 +3,10 @@ BEGIN {
a = 21; a = 21;
print a > 20? 1 : 2; print a > 20? 1 : 2;
c = a++ ++b;
print a;
print b;
print c;
} }

511
qse/regress/awk/lisp/awklisp
View File

@ -1,67 +1,57 @@
# #!/usr/bin/gawk -f
# $Id$
#
# This program is a modified version of awklisp originally written
# by Darius Bacon. The only modification is to append a semicolon
# onto the end of each statement to cater for the semicolon requirement
# of ASEAWK. The original file of this file has been renamed to awklisp.org.
#
# aseawk++ -si awklisp
# aseawk++ -si awklisp -ci startup -ci scmhelp.lsp -ci scheme.lsp
#
# --- Representation of Lisp data # --- Representation of Lisp data
BEGIN { BEGIN {
a_number = 0; a_number = 0
pair_ptr = a_pair = 1; pair_ptr = a_pair = 1
symbol_ptr = a_symbol = 2; symbol_ptr = a_symbol = 2
type_name[a_number] = "number"; type_name[a_number] = "number"
type_name[a_pair] = "pair"; type_name[a_pair] = "pair"
type_name[a_symbol] = "symbol"; type_name[a_symbol] = "symbol"
} }
function is(type, expr) function is(type, expr)
{ {
if (expr % 4 != type) if (expr % 4 != type)
error("Expected a " type_name[type] ", not a " type_name[expr % 4]) ; error("Expected a " type_name[type] ", not a " type_name[expr % 4])
return expr; return expr
} }
function is_number(expr) { return expr % 4 == 0; } function is_number(expr) { return expr % 4 == 0 }
function is_pair(expr) { return expr % 4 == 1; } function is_pair(expr) { return expr % 4 == 1 }
function is_symbol(expr) { return expr % 4 == 2; } function is_symbol(expr) { return expr % 4 == 2 }
function is_atom(expr) { return expr % 4 != 1; } function is_atom(expr) { return expr % 4 != 1 }
function make_number(n) { return n * 4; } function make_number(n) { return n * 4 }
function numeric_value(expr) function numeric_value(expr)
{ {
if (expr % 4 != 0) error("Not a number"); if (expr % 4 != 0) error("Not a number")
return expr / 4; return expr / 4
} }
# Return the symbol :string names. # Return the symbol :string names.
function string_to_symbol(string) function string_to_symbol(string)
{ {
if (string in intern) if (string in intern)
return intern[string]; return intern[string]
symbol_ptr += 4; symbol_ptr += 4
intern[string] = symbol_ptr; intern[string] = symbol_ptr
printname[symbol_ptr] = string; printname[symbol_ptr] = string
return symbol_ptr; return symbol_ptr
} }
# Define a primitive procedure, with :nparams parameters, # Define a primitive procedure, with :nparams parameters,
# bound to the symbol named :name. # bound to the symbol named :name.
function def_prim(name, nparams, sym) function def_prim(name, nparams, sym)
{ {
sym = string_to_symbol(name); sym = string_to_symbol(name)
value[sym] = string_to_symbol(sprintf("#<Primitive %s>", name)); value[sym] = string_to_symbol(sprintf("#<Primitive %s>", name))
if (nparams != "") if (nparams != "")
num_params[value[sym]] = nparams; num_params[value[sym]] = nparams
return value[sym]; return value[sym]
} }
# --- Garbage collection # --- Garbage collection
@ -70,119 +60,119 @@ function def_prim(name, nparams, sym)
function cons(the_car, the_cdr) function cons(the_car, the_cdr)
{ {
while (pair_ptr in marks) { while (pair_ptr in marks) {
delete marks[pair_ptr]; delete marks[pair_ptr]
pair_ptr += 4; pair_ptr += 4
} }
if (pair_ptr == pair_limit) if (pair_ptr == pair_limit)
gc(the_car, the_cdr); gc(the_car, the_cdr)
car[pair_ptr] = the_car; car[pair_ptr] = the_car
cdr[pair_ptr] = the_cdr; cdr[pair_ptr] = the_cdr
pair_ptr += 4; pair_ptr += 4
return pair_ptr - 4; return pair_ptr - 4
} }
function protect(object) { protected[++protected_ptr] = object; } function protect(object) { protected[++protected_ptr] = object }
function unprotect() { --protected_ptr; } function unprotect() { --protected_ptr }
function mark(object) function mark(object)
{ {
while (is_pair(object) && !(object in marks)) { #** speed while (is_pair(object) && !(object in marks)) { #** speed
marks[object] = 1; marks[object] = 1
mark(car[object]); mark(car[object])
object = cdr[object]; object = cdr[object]
} }
} }
function gc(the_car, the_cdr, p, i) function gc(the_car, the_cdr, p, i)
{ {
if (loud_gc) if (loud_gc)
printf("\nGC...") >"/dev/stderr"; printf("\nGC...") >"/dev/stderr"
mark(the_car); mark(the_cdr); mark(the_car); mark(the_cdr)
for (p in protected) for (p in protected)
mark(protected[p]); mark(protected[p])
for (p in stack) for (p in stack)
mark(stack[p]); mark(stack[p])
for (p in value) for (p in value)
mark(value[p]); mark(value[p])
for (p in property) { for (p in property) {
i = index(SUBSEP, p); i = index(SUBSEP, p)
mark(substr(p, 1, i-1)); mark(substr(p, 1, i-1))
mark(substr(p, i+1)); mark(substr(p, i+1))
mark(property[p]); mark(property[p])
} }
pair_ptr = a_pair; pair_ptr = a_pair
while (pair_ptr in marks) { while (pair_ptr in marks) {
delete marks[pair_ptr]; delete marks[pair_ptr]
pair_ptr += 4; pair_ptr += 4
} }
if (pair_ptr == pair_limit) { if (pair_ptr == pair_limit) {
if (loud_gc); if (loud_gc)
printf("Expanding heap...") >"/dev/stderr"; printf("Expanding heap...") >"/dev/stderr"
pair_limit += 4 * heap_increment; pair_limit += 4 * heap_increment
} }
} }
# --- Set up # --- Set up
BEGIN { BEGIN {
srand(); srand()
frame_ptr = stack_ptr = 0; frame_ptr = stack_ptr = 0
if (heap_increment == "") heap_increment = 1500; if (heap_increment == "") heap_increment = 1500
pair_limit = a_pair + 4 * heap_increment; pair_limit = a_pair + 4 * heap_increment
NIL = string_to_symbol("nil"); NIL = string_to_symbol("nil")
T = string_to_symbol("t"); T = string_to_symbol("t")
value[NIL] = NIL; value[NIL] = NIL
value[T] = T; value[T] = T
car[NIL] = cdr[NIL] = NIL; # this is convenient in a couple places... car[NIL] = cdr[NIL] = NIL # this is convenient in a couple places...
THE_EOF_OBJECT = string_to_symbol("#eof"); THE_EOF_OBJECT = string_to_symbol("#eof")
value[string_to_symbol("the-eof-object")] = THE_EOF_OBJECT; value[string_to_symbol("the-eof-object")] = THE_EOF_OBJECT
eof = "(eof)"; eof = "(eof)"
QUOTE = string_to_symbol("quote"); is_special[QUOTE] = 1; QUOTE = string_to_symbol("quote"); is_special[QUOTE] = 1
LAMBDA = string_to_symbol("lambda"); is_special[LAMBDA] = 1; LAMBDA = string_to_symbol("lambda"); is_special[LAMBDA] = 1
IF = string_to_symbol("if"); is_special[IF] = 1; IF = string_to_symbol("if"); is_special[IF] = 1
SETQ = string_to_symbol("set!"); is_special[SETQ] = 1; SETQ = string_to_symbol("set!"); is_special[SETQ] = 1
DEFINE = string_to_symbol("define"); is_special[DEFINE] = 1; DEFINE = string_to_symbol("define"); is_special[DEFINE] = 1
PROGN = string_to_symbol("begin"); is_special[PROGN] = 1; PROGN = string_to_symbol("begin"); is_special[PROGN] = 1
WHILE = string_to_symbol("while"); is_special[WHILE] = 1; WHILE = string_to_symbol("while"); is_special[WHILE] = 1
EQ = def_prim("eq?", 2); EQ = def_prim("eq?", 2)
NULL = def_prim("null?", 1); NULL = def_prim("null?", 1)
CAR = def_prim("car", 1); CAR = def_prim("car", 1)
CDR = def_prim("cdr", 1); CDR = def_prim("cdr", 1)
CADR = def_prim("cadr", 1); CADR = def_prim("cadr", 1)
CDDR = def_prim("cddr", 1); CDDR = def_prim("cddr", 1)
CONS = def_prim("cons", 2); CONS = def_prim("cons", 2)
LIST = def_prim("list"); LIST = def_prim("list")
EVAL = def_prim("eval", 1); EVAL = def_prim("eval", 1)
APPLY = def_prim("apply", 2); APPLY = def_prim("apply", 2)
READ = def_prim("read", 0); READ = def_prim("read", 0)
WRITE = def_prim("write", 1); WRITE = def_prim("write", 1)
NEWLINE = def_prim("newline", 0); NEWLINE = def_prim("newline", 0)
ADD = def_prim("+", 2); ADD = def_prim("+", 2)
SUB = def_prim("-", 2); SUB = def_prim("-", 2)
MUL = def_prim("*", 2); MUL = def_prim("*", 2)
DIV = def_prim("quotient", 2); DIV = def_prim("quotient", 2)
MOD = def_prim("remainder", 2); MOD = def_prim("remainder", 2)
LT = def_prim("<", 2); LT = def_prim("<", 2)
GET = def_prim("get", 2); GET = def_prim("get", 2)
PUT = def_prim("put", 3); PUT = def_prim("put", 3)
ATOMP = def_prim("atom?", 1); ATOMP = def_prim("atom?", 1)
PAIRP = def_prim("pair?", 1); PAIRP = def_prim("pair?", 1)
SYMBOLP = def_prim("symbol?", 1); SYMBOLP = def_prim("symbol?", 1)
NUMBERP = def_prim("number?", 1); NUMBERP = def_prim("number?", 1)
SETCAR = def_prim("set-car!", 2); SETCAR = def_prim("set-car!", 2)
SETCDR = def_prim("set-cdr!", 2); SETCDR = def_prim("set-cdr!", 2)
NREV = def_prim("reverse!", 1); NREV = def_prim("reverse!", 1)
GENSYM = def_prim("gensym", 0); GENSYM = def_prim("gensym", 0)
RANDOM = def_prim("random", 1); RANDOM = def_prim("random", 1)
ERROR = def_prim("error"); ERROR = def_prim("error")
DRIVER = string_to_symbol("top-level-driver"); DRIVER = string_to_symbol("top-level-driver")
} }
# --- The interpreter # --- The interpreter
@ -190,21 +180,21 @@ BEGIN {
BEGIN { BEGIN {
for (;;) { for (;;) {
if (DRIVER in value && value[DRIVER] != NIL) if (DRIVER in value && value[DRIVER] != NIL)
apply(value[DRIVER]); apply(value[DRIVER])
else { else {
expr = read(); expr = read()
if (expr == THE_EOF_OBJECT) if (expr == THE_EOF_OBJECT)
break; break;
protect(expr); protect(expr)
print_expr(eval(expr)); print_expr(eval(expr))
unprotect(); unprotect()
} }
} }
if (profiling) if (profiling)
for (proc in call_count) { for (proc in call_count) {
printf("%5d ", call_count[proc]); printf("%5d ", call_count[proc])
print_expr(proc); print_expr(proc)
} }
} }
@ -215,64 +205,64 @@ function eval(expr, old_frame_ptr)
{ {
if (is_atom(expr)) #** speed if (is_atom(expr)) #** speed
if (is_symbol(expr)) { if (is_symbol(expr)) {
if (!(expr in value)) error("Unbound variable: " printname[expr]); if (!(expr in value)) error("Unbound variable: " printname[expr])
return value[expr]; return value[expr]
} else } else
return expr; return expr
op = car[expr]; # op is global to save awk stack space op = car[expr] # op is global to save awk stack space
if (!(op in is_special)) { if (!(op in is_special)) {
old_frame_ptr = frame_ptr; old_frame_ptr = frame_ptr
frame_ptr = stack_ptr; frame_ptr = stack_ptr
eval_rands(cdr[expr]); eval_rands(cdr[expr])
protect(proc = eval(car[expr])); protect(proc = eval(car[expr]))
result = apply(proc); result = apply(proc)
unprotect(); unprotect()
stack_ptr = frame_ptr; stack_ptr = frame_ptr
frame_ptr = old_frame_ptr; frame_ptr = old_frame_ptr
return result; return result
} }
if (op == QUOTE) return car[cdr[expr]]; if (op == QUOTE) return car[cdr[expr]]
if (op == LAMBDA) return expr; if (op == LAMBDA) return expr
if (op == IF) return eval(car[cdr[expr]]) != NIL if (op == IF) return eval(car[cdr[expr]]) != NIL \
? eval(car[cdr[cdr[expr]]]) ? eval(car[cdr[cdr[expr]]]) \
: eval(car[cdr[cdr[cdr[expr]]]]); : eval(car[cdr[cdr[cdr[expr]]]])
if (op == PROGN) return progn(cdr[expr]); if (op == PROGN) return progn(cdr[expr])
if (op == SETQ) { if (op == SETQ) {
if (!(car[cdr[expr]] in value)) if (!(car[cdr[expr]] in value))
error("Unbound variable: " printname[car[cdr[expr]]]); error("Unbound variable: " printname[car[cdr[expr]]])
return value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]]); return value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]])
} }
if (op == WHILE) { if (op == WHILE) {
while (eval(car[cdr[expr]]) != NIL) while (eval(car[cdr[expr]]) != NIL)
progn(cdr[cdr[expr]]); progn(cdr[cdr[expr]])
return NIL; return NIL
} }
if (op == DEFINE) { if (op == DEFINE) {
value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]]); value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]])
return car[cdr[expr]]; return car[cdr[expr]]
} }
error("BUG: Unknown special form"); error("BUG: Unknown special form")
} }
# Evaluate a sequence of expressions, returning the last value. # Evaluate a sequence of expressions, returning the last value.
function progn(exprs) function progn(exprs)
{ {
for (; cdr[exprs] != NIL; exprs = cdr[exprs]) for (; cdr[exprs] != NIL; exprs = cdr[exprs])
eval(car[exprs]); eval(car[exprs])
return eval(car[exprs]); return eval(car[exprs])
} }
# Evaluate the operands of a procedure, pushing the results on the stack. # Evaluate the operands of a procedure, pushing the results on the stack.
function eval_rands(rands) function eval_rands(rands)
{ {
for (; rands != NIL; rands = cdr[rands]) for (; rands != NIL; rands = cdr[rands])
stack[stack_ptr++] = eval(car[rands]); stack[stack_ptr++] = eval(car[rands])
} }
# Call the procedure :proc, with args stack[frame_ptr]..stack[stack_ptr-1] # Call the procedure :proc, with args stack[frame_ptr]..stack[stack_ptr-1]
@ -280,72 +270,72 @@ function eval_rands(rands)
function apply(proc) function apply(proc)
{ {
if (profiling) if (profiling)
++call_count[proc]; ++call_count[proc]
if (car[proc] == LAMBDA) { if (car[proc] == LAMBDA) {
extend_env(car[cdr[proc]]); extend_env(car[cdr[proc]])
result = progn(cdr[cdr[proc]]); # result is global to save stack space result = progn(cdr[cdr[proc]]) # result is global to save stack space
unwind_env(car[cdr[proc]]); unwind_env(car[cdr[proc]])
return result; return result
} }
if (proc in num_params && num_params[proc] != stack_ptr - frame_ptr) if (proc in num_params && num_params[proc] != stack_ptr - frame_ptr)
error("Wrong number of arguments to " printname[cdr[proc]]); error("Wrong number of arguments to " printname[cdr[proc]])
if (proc == CAR) return car[is(a_pair, stack[frame_ptr])]; if (proc == CAR) return car[is(a_pair, stack[frame_ptr])]
if (proc == CDR) return cdr[is(a_pair, stack[frame_ptr])]; if (proc == CDR) return cdr[is(a_pair, stack[frame_ptr])]
if (proc == CONS) return cons(stack[frame_ptr], stack[frame_ptr+1]); if (proc == CONS) return cons(stack[frame_ptr], stack[frame_ptr+1])
if (proc == NULL) return stack[frame_ptr] == NIL ? T : NIL; if (proc == NULL) return stack[frame_ptr] == NIL ? T : NIL
if (proc == EQ) return stack[frame_ptr] == stack[frame_ptr+1] ? T : NIL; if (proc == EQ) return stack[frame_ptr] == stack[frame_ptr+1] ? T : NIL
if (proc == ATOMP) return is_atom(stack[frame_ptr]) ? T : NIL; if (proc == ATOMP) return is_atom(stack[frame_ptr]) ? T : NIL
if (proc == ADD) return is(a_number, stack[frame_ptr]) + is(a_number, stack[frame_ptr+1]); if (proc == ADD) return is(a_number, stack[frame_ptr]) + is(a_number, stack[frame_ptr+1])
if (proc == SUB) return is(a_number, stack[frame_ptr]) - is(a_number, stack[frame_ptr+1]); if (proc == SUB) return is(a_number, stack[frame_ptr]) - is(a_number, stack[frame_ptr+1])
if (proc == MUL) return make_number(numeric_value(stack[frame_ptr]) * numeric_value(stack[frame_ptr+1])); if (proc == MUL) return make_number(numeric_value(stack[frame_ptr]) * numeric_value(stack[frame_ptr+1]))
if (proc == DIV) return make_number(int(numeric_value(stack[frame_ptr]) / numeric_value(stack[frame_ptr+1]))); if (proc == DIV) return make_number(int(numeric_value(stack[frame_ptr]) / numeric_value(stack[frame_ptr+1])))
if (proc == MOD) return make_number(numeric_value(stack[frame_ptr]) % numeric_value(stack[frame_ptr+1])); if (proc == MOD) return make_number(numeric_value(stack[frame_ptr]) % numeric_value(stack[frame_ptr+1]))
if (proc == LT) return (stack[frame_ptr] + 0 < stack[frame_ptr+1] + 0) ? T : NIL; if (proc == LT) return (stack[frame_ptr] + 0 < stack[frame_ptr+1] + 0) ? T : NIL
if (proc == GET) return (stack[frame_ptr], stack[frame_ptr+1]) in property ? property[stack[frame_ptr], stack[frame_ptr+1]] : NIL; if (proc == GET) return (stack[frame_ptr], stack[frame_ptr+1]) in property ? property[stack[frame_ptr], stack[frame_ptr+1]] : NIL
if (proc == PUT) return property[stack[frame_ptr], stack[frame_ptr+1]] = stack[frame_ptr+2]; if (proc == PUT) return property[stack[frame_ptr], stack[frame_ptr+1]] = stack[frame_ptr+2]
if (proc == CADR) return car[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])]; if (proc == CADR) return car[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])]
if (proc == CDDR) return cdr[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])]; if (proc == CDDR) return cdr[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])]
if (proc == LIST) return listify_args(); if (proc == LIST) return listify_args()
if (proc == SYMBOLP)return is_symbol(stack[frame_ptr]) ? T : NIL; if (proc == SYMBOLP)return is_symbol(stack[frame_ptr]) ? T : NIL
if (proc == PAIRP) return is_pair(stack[frame_ptr]) ? T : NIL; if (proc == PAIRP) return is_pair(stack[frame_ptr]) ? T : NIL
if (proc == NUMBERP)return is_number(stack[frame_ptr]) ? T : NIL; if (proc == NUMBERP)return is_number(stack[frame_ptr]) ? T : NIL
if (proc == SETCAR) return car[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1]; if (proc == SETCAR) return car[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1]
if (proc == SETCDR) return cdr[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1]; if (proc == SETCDR) return cdr[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1]
if (proc == APPLY) return do_apply(stack[frame_ptr], stack[frame_ptr+1]); if (proc == APPLY) return do_apply(stack[frame_ptr], stack[frame_ptr+1])
if (proc == EVAL) return eval(stack[frame_ptr]); if (proc == EVAL) return eval(stack[frame_ptr])
if (proc == NREV) return nreverse(stack[frame_ptr], NIL); if (proc == NREV) return nreverse(stack[frame_ptr], NIL)
if (proc == WRITE) { write_expr(stack[frame_ptr]); printf(" "); return NIL; } if (proc == WRITE) { write_expr(stack[frame_ptr]); printf(" "); return NIL }
if (proc == NEWLINE){ printf("\n"); return NIL;} if (proc == NEWLINE){ printf("\n"); return NIL }
if (proc == READ) return read(); if (proc == READ) return read()
if (proc == RANDOM) return make_number(int(rand() * numeric_value(stack[frame_ptr]))); if (proc == RANDOM) return make_number(int(rand() * numeric_value(stack[frame_ptr])))
if (proc == GENSYM) return string_to_symbol("#G" ++gensym_counter); if (proc == GENSYM) return string_to_symbol("#G" ++gensym_counter)
if (proc == ERROR) { printf("Error!\n"); print_expr(listify_args()); exit(1); } if (proc == ERROR) { printf("Error!\n"); print_expr(listify_args()); exit(1) }
error("Unknown procedure type"); error("Unknown procedure type")
} }
function do_apply(proc, args, old_frame_ptr) function do_apply(proc, args, old_frame_ptr)
{ {
old_frame_ptr = frame_ptr; old_frame_ptr = frame_ptr
frame_ptr = stack_ptr; frame_ptr = stack_ptr
for (; is_pair(args); args = cdr[args]) for (; is_pair(args); args = cdr[args])
stack[stack_ptr++] = car[args]; stack[stack_ptr++] = car[args]
if (args != NIL) if (args != NIL)
error("Bad argument to APPLY: not a proper list"); error("Bad argument to APPLY: not a proper list")
result = apply(proc); result = apply(proc)
stack_ptr = frame_ptr; stack_ptr = frame_ptr
frame_ptr = old_frame_ptr; frame_ptr = old_frame_ptr
return result; return result
} }
function listify_args( p, result) function listify_args( p, result)
{ {
result = NIL; result = NIL
for (p = stack_ptr - 1; frame_ptr <= p; --p) for (p = stack_ptr - 1; frame_ptr <= p; --p)
result = cons(stack[p], result); result = cons(stack[p], result)
return result; return result
} }
# --- The environment # --- The environment
@ -361,24 +351,24 @@ function extend_env(vars, p, temp)
{ {
for (p = frame_ptr; vars != NIL; vars = cdr[vars]) { for (p = frame_ptr; vars != NIL; vars = cdr[vars]) {
if (p == stack_ptr) if (p == stack_ptr)
error("Too many arguments to procedure"); error("Too many arguments to procedure")
temp = value[car[vars]]; temp = value[car[vars]]
value[car[vars]] = stack[p]; value[car[vars]] = stack[p]
stack[p] = temp; stack[p] = temp
++p; ++p
} }
if (p != stack_ptr) if (p != stack_ptr)
error("Not enough arguments to procedure"); error("Not enough arguments to procedure")
} }
function unwind_env(vars, p) function unwind_env(vars, p)
{ {
for (p = frame_ptr; vars != NIL; vars = cdr[vars]) { for (p = frame_ptr; vars != NIL; vars = cdr[vars]) {
if (stack[p] == "") if (stack[p] == "")
delete value[car[vars]]; delete value[car[vars]]
else else
value[car[vars]] = stack[p]; value[car[vars]] = stack[p]
++p; ++p
} }
} }
@ -386,32 +376,32 @@ function unwind_env(vars, p)
function print_expr(expr) function print_expr(expr)
{ {
write_expr(expr); write_expr(expr)
print ""; print ""
} }
function write_expr(expr) function write_expr(expr)
{ {
if (is_atom(expr)) { if (is_atom(expr)) {
if (!is_symbol(expr)) if (!is_symbol(expr))
printf("%d", numeric_value(expr)); printf("%d", numeric_value(expr))
else { else {
if (!(expr in printname)) if (!(expr in printname))
error("BUG: " expr " has no printname"); error("BUG: " expr " has no printname")
printf("%s", printname[expr]); printf("%s", printname[expr])
} }
} else { } else {
printf("("); printf("(")
write_expr(car[expr]); write_expr(car[expr])
for (expr = cdr[expr]; is_pair(expr); expr = cdr[expr]) { for (expr = cdr[expr]; is_pair(expr); expr = cdr[expr]) {
printf(" "); printf(" ")
write_expr(car[expr]); write_expr(car[expr])
} }
if (expr != NIL) { if (expr != NIL) {
printf(" . "); printf(" . ")
write_expr(expr); write_expr(expr)
} }
printf(")"); printf(")")
} }
} }
@ -419,72 +409,72 @@ function write_expr(expr)
function read( committed, result) function read( committed, result)
{ {
skip_blanks(); skip_blanks()
if (token == eof) if (token == eof)
if (committed) if (committed)
error("Unexpected EOF"); error("Unexpected EOF")
else else
return THE_EOF_OBJECT; return THE_EOF_OBJECT
if (token == "(") { # read a list if (token == "(") { # read a list
advance(); advance()
result = NIL; result = NIL
for (;;) { for (;;) {
skip_blanks(); skip_blanks()
if (token == ".") { if (token == ".") {
advance(); advance()
after_dot = read(1); after_dot = read(1)
skip_blanks(); skip_blanks()
if (token != ")") if (token != ")")
error("')' expected"); error("')' expected")
advance(); advance()
return nreverse(result, after_dot); return nreverse(result, after_dot)
} else if (token == ")") { } else if (token == ")") {
advance(); advance()
return nreverse(result, NIL); return nreverse(result, NIL)
} else { } else {
protect(result); protect(result)
result = cons(read(1), result); result = cons(read(1), result)
unprotect(); unprotect()
} }
} }
} else if (token == "'") { # a quoted expression } else if (token == "'") { # a quoted expression
advance(); advance()
return cons(QUOTE, cons(read(1), NIL)); return cons(QUOTE, cons(read(1), NIL))
} else if (token ~ /^-?[0-9]+$/) { # a number } else if (token ~ /^-?[0-9]+$/) { # a number
result = make_number(token); result = make_number(token)
advance(); advance()
return result; return result
} else { # a symbol } else { # a symbol
result = string_to_symbol(token); result = string_to_symbol(token)
advance(); advance()
return result; return result
} }
} }
function skip_blanks() function skip_blanks()
{ {
while (token ~ /^[ \t]*$/) while (token ~ /^[ \t]*$/)
advance(); advance()
} }
function advance() function advance()
{ {
if (token == eof) return eof; if (token == eof) return eof
if (token == "") { if (token == "") {
if (getline line <= 0) { if (getline line <= 0) {
token = eof; token = eof
return; return
} }
} }
if (match(line, "^[()'.]") || if (match(line, "^[()'.]") ||
match(line, "^[_A-Za-z0-9=!@$%&*<>?+\\-*/:]+") || match(line, "^[_A-Za-z0-9=!@$%&*<>?+\\-*/:]+") ||
match(line, "^[ \\t]+")) { match(line, "^[ \\t]+")) {
token = substr(line, RSTART, RLENGTH); token = substr(line, RSTART, RLENGTH)
line = substr(line, RLENGTH+1); line = substr(line, RLENGTH+1)
} else if (line == "" || substr(line, 1, 1) == ";") } else if (line == "" || substr(line, 1, 1) == ";")
token = ""; # this kludge permits interactive use token = "" # this kludge permits interactive use
else else
error("Lexical error starting at " line); error("Lexical error starting at " line)
} }
# --- Miscellany # --- Miscellany
@ -493,19 +483,18 @@ function advance()
function nreverse(list, reversed_head, tail) function nreverse(list, reversed_head, tail)
{ {
while (is_pair(list)) { #** speed? while (is_pair(list)) { #** speed?
tail = cdr[list]; tail = cdr[list]
cdr[list] = reversed_head; cdr[list] = reversed_head
reversed_head = list; reversed_head = list
list = tail; list = tail
} }
if (list != NIL) if (list != NIL)
error("Not a proper list - reverse!"); error("Not a proper list - reverse!")
return reversed_head; return reversed_head
} }
function error(reason) function error(reason)
{ {
print "ERROR: " reason >"/dev/stderr"; print "ERROR: " reason >"/dev/stderr"
exit(1); exit(1)
} }

500
qse/regress/awk/lisp/awklisp.org
View File

@ -1,500 +0,0 @@
#!/usr/bin/gawk -f
# --- Representation of Lisp data
BEGIN {
a_number = 0
pair_ptr = a_pair = 1
symbol_ptr = a_symbol = 2
type_name[a_number] = "number"
type_name[a_pair] = "pair"
type_name[a_symbol] = "symbol"
}
function is(type, expr)
{
if (expr % 4 != type)
error("Expected a " type_name[type] ", not a " type_name[expr % 4])
return expr
}
function is_number(expr) { return expr % 4 == 0 }
function is_pair(expr) { return expr % 4 == 1 }
function is_symbol(expr) { return expr % 4 == 2 }
function is_atom(expr) { return expr % 4 != 1 }
function make_number(n) { return n * 4 }
function numeric_value(expr)
{
if (expr % 4 != 0) error("Not a number")
return expr / 4
}
# Return the symbol :string names.
function string_to_symbol(string)
{
if (string in intern)
return intern[string]
symbol_ptr += 4
intern[string] = symbol_ptr
printname[symbol_ptr] = string
return symbol_ptr
}
# Define a primitive procedure, with :nparams parameters,
# bound to the symbol named :name.
function def_prim(name, nparams, sym)
{
sym = string_to_symbol(name)
value[sym] = string_to_symbol(sprintf("#<Primitive %s>", name))
if (nparams != "")
num_params[value[sym]] = nparams
return value[sym]
}
# --- Garbage collection
# Make a new pair.
function cons(the_car, the_cdr)
{
while (pair_ptr in marks) {
delete marks[pair_ptr]
pair_ptr += 4
}
if (pair_ptr == pair_limit)
gc(the_car, the_cdr)
car[pair_ptr] = the_car
cdr[pair_ptr] = the_cdr
pair_ptr += 4
return pair_ptr - 4
}
function protect(object) { protected[++protected_ptr] = object }
function unprotect() { --protected_ptr }
function mark(object)
{
while (is_pair(object) && !(object in marks)) { #** speed
marks[object] = 1
mark(car[object])
object = cdr[object]
}
}
function gc(the_car, the_cdr, p, i)
{
if (loud_gc)
printf("\nGC...") >"/dev/stderr"
mark(the_car); mark(the_cdr)
for (p in protected)
mark(protected[p])
for (p in stack)
mark(stack[p])
for (p in value)
mark(value[p])
for (p in property) {
i = index(SUBSEP, p)
mark(substr(p, 1, i-1))
mark(substr(p, i+1))
mark(property[p])
}
pair_ptr = a_pair
while (pair_ptr in marks) {
delete marks[pair_ptr]
pair_ptr += 4
}
if (pair_ptr == pair_limit) {
if (loud_gc)
printf("Expanding heap...") >"/dev/stderr"
pair_limit += 4 * heap_increment
}
}
# --- Set up
BEGIN {
srand()
frame_ptr = stack_ptr = 0
if (heap_increment == "") heap_increment = 1500
pair_limit = a_pair + 4 * heap_increment
NIL = string_to_symbol("nil")
T = string_to_symbol("t")
value[NIL] = NIL
value[T] = T
car[NIL] = cdr[NIL] = NIL # this is convenient in a couple places...
THE_EOF_OBJECT = string_to_symbol("#eof")
value[string_to_symbol("the-eof-object")] = THE_EOF_OBJECT
eof = "(eof)"
QUOTE = string_to_symbol("quote"); is_special[QUOTE] = 1
LAMBDA = string_to_symbol("lambda"); is_special[LAMBDA] = 1
IF = string_to_symbol("if"); is_special[IF] = 1
SETQ = string_to_symbol("set!"); is_special[SETQ] = 1
DEFINE = string_to_symbol("define"); is_special[DEFINE] = 1
PROGN = string_to_symbol("begin"); is_special[PROGN] = 1
WHILE = string_to_symbol("while"); is_special[WHILE] = 1
EQ = def_prim("eq?", 2)
NULL = def_prim("null?", 1)
CAR = def_prim("car", 1)
CDR = def_prim("cdr", 1)
CADR = def_prim("cadr", 1)
CDDR = def_prim("cddr", 1)
CONS = def_prim("cons", 2)
LIST = def_prim("list")
EVAL = def_prim("eval", 1)
APPLY = def_prim("apply", 2)
READ = def_prim("read", 0)
WRITE = def_prim("write", 1)
NEWLINE = def_prim("newline", 0)
ADD = def_prim("+", 2)
SUB = def_prim("-", 2)
MUL = def_prim("*", 2)
DIV = def_prim("quotient", 2)
MOD = def_prim("remainder", 2)
LT = def_prim("<", 2)
GET = def_prim("get", 2)
PUT = def_prim("put", 3)
ATOMP = def_prim("atom?", 1)
PAIRP = def_prim("pair?", 1)
SYMBOLP = def_prim("symbol?", 1)
NUMBERP = def_prim("number?", 1)
SETCAR = def_prim("set-car!", 2)
SETCDR = def_prim("set-cdr!", 2)
NREV = def_prim("reverse!", 1)
GENSYM = def_prim("gensym", 0)
RANDOM = def_prim("random", 1)
ERROR = def_prim("error")
DRIVER = string_to_symbol("top-level-driver")
}
# --- The interpreter
BEGIN {
for (;;) {
if (DRIVER in value && value[DRIVER] != NIL)
apply(value[DRIVER])
else {
expr = read()
if (expr == THE_EOF_OBJECT)
break;
protect(expr)
print_expr(eval(expr))
unprotect()
}
}
if (profiling)
for (proc in call_count) {
printf("%5d ", call_count[proc])
print_expr(proc)
}
}
# All the interpretation routines have the precondition that their
# arguments are protected from garbage collection.
function eval(expr, old_frame_ptr)
{
if (is_atom(expr)) #** speed
if (is_symbol(expr)) {
if (!(expr in value)) error("Unbound variable: " printname[expr])
return value[expr]
} else
return expr
op = car[expr] # op is global to save awk stack space
if (!(op in is_special)) {
old_frame_ptr = frame_ptr
frame_ptr = stack_ptr
eval_rands(cdr[expr])
protect(proc = eval(car[expr]))
result = apply(proc)
unprotect()
stack_ptr = frame_ptr
frame_ptr = old_frame_ptr
return result
}
if (op == QUOTE) return car[cdr[expr]]
if (op == LAMBDA) return expr
if (op == IF) return eval(car[cdr[expr]]) != NIL \
? eval(car[cdr[cdr[expr]]]) \
: eval(car[cdr[cdr[cdr[expr]]]])
if (op == PROGN) return progn(cdr[expr])
if (op == SETQ) {
if (!(car[cdr[expr]] in value))
error("Unbound variable: " printname[car[cdr[expr]]])
return value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]])
}
if (op == WHILE) {
while (eval(car[cdr[expr]]) != NIL)
progn(cdr[cdr[expr]])
return NIL
}
if (op == DEFINE) {
value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]])
return car[cdr[expr]]
}
error("BUG: Unknown special form")
}
# Evaluate a sequence of expressions, returning the last value.
function progn(exprs)
{
for (; cdr[exprs] != NIL; exprs = cdr[exprs])
eval(car[exprs])
return eval(car[exprs])
}
# Evaluate the operands of a procedure, pushing the results on the stack.
function eval_rands(rands)
{
for (; rands != NIL; rands = cdr[rands])
stack[stack_ptr++] = eval(car[rands])
}
# Call the procedure :proc, with args stack[frame_ptr]..stack[stack_ptr-1]
# (in that order).
function apply(proc)
{
if (profiling)
++call_count[proc]
if (car[proc] == LAMBDA) {
extend_env(car[cdr[proc]])
result = progn(cdr[cdr[proc]]) # result is global to save stack space
unwind_env(car[cdr[proc]])
return result
}
if (proc in num_params && num_params[proc] != stack_ptr - frame_ptr)
error("Wrong number of arguments to " printname[cdr[proc]])
if (proc == CAR) return car[is(a_pair, stack[frame_ptr])]
if (proc == CDR) return cdr[is(a_pair, stack[frame_ptr])]
if (proc == CONS) return cons(stack[frame_ptr], stack[frame_ptr+1])
if (proc == NULL) return stack[frame_ptr] == NIL ? T : NIL
if (proc == EQ) return stack[frame_ptr] == stack[frame_ptr+1] ? T : NIL
if (proc == ATOMP) return is_atom(stack[frame_ptr]) ? T : NIL
if (proc == ADD) return is(a_number, stack[frame_ptr]) + is(a_number, stack[frame_ptr+1])
if (proc == SUB) return is(a_number, stack[frame_ptr]) - is(a_number, stack[frame_ptr+1])
if (proc == MUL) return make_number(numeric_value(stack[frame_ptr]) * numeric_value(stack[frame_ptr+1]))
if (proc == DIV) return make_number(int(numeric_value(stack[frame_ptr]) / numeric_value(stack[frame_ptr+1])))
if (proc == MOD) return make_number(numeric_value(stack[frame_ptr]) % numeric_value(stack[frame_ptr+1]))
if (proc == LT) return (stack[frame_ptr] + 0 < stack[frame_ptr+1] + 0) ? T : NIL
if (proc == GET) return (stack[frame_ptr], stack[frame_ptr+1]) in property ? property[stack[frame_ptr], stack[frame_ptr+1]] : NIL
if (proc == PUT) return property[stack[frame_ptr], stack[frame_ptr+1]] = stack[frame_ptr+2]
if (proc == CADR) return car[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])]
if (proc == CDDR) return cdr[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])]
if (proc == LIST) return listify_args()
if (proc == SYMBOLP)return is_symbol(stack[frame_ptr]) ? T : NIL
if (proc == PAIRP) return is_pair(stack[frame_ptr]) ? T : NIL
if (proc == NUMBERP)return is_number(stack[frame_ptr]) ? T : NIL
if (proc == SETCAR) return car[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1]
if (proc == SETCDR) return cdr[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1]
if (proc == APPLY) return do_apply(stack[frame_ptr], stack[frame_ptr+1])
if (proc == EVAL) return eval(stack[frame_ptr])
if (proc == NREV) return nreverse(stack[frame_ptr], NIL)
if (proc == WRITE) { write_expr(stack[frame_ptr]); printf(" "); return NIL }
if (proc == NEWLINE){ printf("\n"); return NIL }
if (proc == READ) return read()
if (proc == RANDOM) return make_number(int(rand() * numeric_value(stack[frame_ptr])))
if (proc == GENSYM) return string_to_symbol("#G" ++gensym_counter)
if (proc == ERROR) { printf("Error!\n"); print_expr(listify_args()); exit(1) }
error("Unknown procedure type")
}
function do_apply(proc, args, old_frame_ptr)
{
old_frame_ptr = frame_ptr
frame_ptr = stack_ptr
for (; is_pair(args); args = cdr[args])
stack[stack_ptr++] = car[args]
if (args != NIL)
error("Bad argument to APPLY: not a proper list")
result = apply(proc)
stack_ptr = frame_ptr
frame_ptr = old_frame_ptr
return result
}
function listify_args( p, result)
{
result = NIL
for (p = stack_ptr - 1; frame_ptr <= p; --p)
result = cons(stack[p], result)
return result
}
# --- The environment
# The current environment is represented by the set of values
# value[sym] where sym is a symbol. extend_env(vars) adds a new
# set of bindings for vars, saving the old values; unwind_env(vars)
# restores those old values. The new value for the nth member of
# vars is frame_ptr[n]; coincidentally, that's also where we
# store away the old value, since that stack frame's not needed
# for anything else after the extend_env() call.
function extend_env(vars, p, temp)
{
for (p = frame_ptr; vars != NIL; vars = cdr[vars]) {
if (p == stack_ptr)
error("Too many arguments to procedure")
temp = value[car[vars]]
value[car[vars]] = stack[p]
stack[p] = temp
++p
}
if (p != stack_ptr)
error("Not enough arguments to procedure")
}
function unwind_env(vars, p)
{
for (p = frame_ptr; vars != NIL; vars = cdr[vars]) {
if (stack[p] == "")
delete value[car[vars]]
else
value[car[vars]] = stack[p]
++p
}
}
# --- Output
function print_expr(expr)
{
write_expr(expr)
print ""
}
function write_expr(expr)
{
if (is_atom(expr)) {
if (!is_symbol(expr))
printf("%d", numeric_value(expr))
else {
if (!(expr in printname))
error("BUG: " expr " has no printname")
printf("%s", printname[expr])
}
} else {
printf("(")
write_expr(car[expr])
for (expr = cdr[expr]; is_pair(expr); expr = cdr[expr]) {
printf(" ")
write_expr(car[expr])
}
if (expr != NIL) {
printf(" . ")
write_expr(expr)
}
printf(")")
}
}
# --- Input
function read( committed, result)
{
skip_blanks()
if (token == eof)
if (committed)
error("Unexpected EOF")
else
return THE_EOF_OBJECT
if (token == "(") { # read a list
advance()
result = NIL
for (;;) {
skip_blanks()
if (token == ".") {
advance()
after_dot = read(1)
skip_blanks()
if (token != ")")
error("')' expected")
advance()
return nreverse(result, after_dot)
} else if (token == ")") {
advance()
return nreverse(result, NIL)
} else {
protect(result)
result = cons(read(1), result)
unprotect()
}
}
} else if (token == "'") { # a quoted expression
advance()
return cons(QUOTE, cons(read(1), NIL))
} else if (token ~ /^-?[0-9]+$/) { # a number
result = make_number(token)
advance()
return result
} else { # a symbol
result = string_to_symbol(token)
advance()
return result
}
}
function skip_blanks()
{
while (token ~ /^[ \t]*$/)
advance()
}
function advance()
{
if (token == eof) return eof
if (token == "") {
if (getline line <= 0) {
token = eof
return
}
}
if (match(line, "^[()'.]") ||
match(line, "^[_A-Za-z0-9=!@$%&*<>?+\\-*/:]+") ||
match(line, "^[ \\t]+")) {
token = substr(line, RSTART, RLENGTH)
line = substr(line, RLENGTH+1)
} else if (line == "" || substr(line, 1, 1) == ";")
token = "" # this kludge permits interactive use
else
error("Lexical error starting at " line)
}
# --- Miscellany
# Destructively reverse :list and append :reversed_head.
function nreverse(list, reversed_head, tail)
{
while (is_pair(list)) { #** speed?
tail = cdr[list]
cdr[list] = reversed_head
reversed_head = list
list = tail
}
if (list != NIL)
error("Not a proper list - reverse!")
return reversed_head
}
function error(reason)
{
print "ERROR: " reason >"/dev/stderr"
exit(1)
}

4
qse/regress/awk/lisp/eliza.dat Normal file
View File

@ -0,0 +1,4 @@
(eliza)
(how are you)
(what a wonderful world)
(how do you do)

2
qse/regress/awk/lisp/numbers.dat Normal file
View File

@ -0,0 +1,2 @@
(square 10000)
(abs -1231)

11
qse/regress/awk/regress.sh
View File

@ -169,7 +169,7 @@ PROGS="
lang-044.awk!lang-044.dat!!--newline=on -o- lang-044.awk!lang-044.dat!!--newline=on -o-
lang-045.awk!!!--newline=on -o- lang-045.awk!!!--newline=on -o-
columnate.awk!./passwd.dat!!--newline=on -F: columnate.awk!passwd.dat!!--newline=on -F:
levenshtein-utests.awk!!!--newline=on --include=on levenshtein-utests.awk!!!--newline=on --include=on
rcalc.awk!!!--newline=on -v target=89000 rcalc.awk!!!--newline=on -v target=89000
quicksort.awk!quicksort.dat!! quicksort.awk!quicksort.dat!!
@ -179,8 +179,17 @@ PROGS="
wordfreq.awk!wordfreq.awk!! wordfreq.awk!wordfreq.awk!!
hanoi.awk!!! hanoi.awk!!!
indent.awk!indent.dat!! indent.awk!indent.dat!!
lisp/awklisp!lisp/startup lisp/fib.lsp!!-o-
lisp/awklisp!lisp/startup lisp/numbers lisp/numbers.dat!!-o-
lisp/awklisp!lisp/startup lisp/scmhelp.lsp lisp/tail.lsp!!-o-
lisp/awklisp!lisp/startup lisp/scmhelp.lsp lisp/scheme.lsp!!-o-
" "
#
# I can't include this as eliza.lsp gives different output on each run.
# lisp/awklisp!lisp/startup lisp/lists lisp/eliza.lsp lisp/eliza.dat!!-o-
#
[ -x "${QSEAWK}" ] || [ -x "${QSEAWK}" ] ||
{ {
echo "ERROR: ${QSEAWK} not found" echo "ERROR: ${QSEAWK} not found"

10
qse/samples/cmn/env.c
View File

@ -101,15 +101,15 @@ static int test2 (void)
static int test3 (void) static int test3 (void)
{ {
qse_env_t* env; qse_env_t* env;
env = qse_env_open (QSE_NULL, 0, 0); env = qse_env_open (QSE_NULL, 0, 0);
qse_printf (QSE_T("%d\n"), qse_env_insertsys (env, QSE_T("PATH"))); qse_printf (QSE_T("inserting PATH => %d\n"), qse_env_insertsys (env, QSE_T("PATH")));
qse_printf (QSE_T("%d\n"), qse_env_insertsysm (env, QSE_MT("HOME"))); qse_printf (QSE_T("inserting HOME => %d\n"), qse_env_insertsysm (env, QSE_MT("HOME")));
qse_printf (QSE_T("%d\n"), qse_env_insertsysw (env, QSE_WT("USER"))); qse_printf (QSE_T("inserting USER => %d\n"), qse_env_insertsysw (env, QSE_WT("USER")));
qse_printf (QSE_T("%d\n"), qse_env_insertsys (env, QSE_T("WHAT"))); qse_printf (QSE_T("inserting WHAT => %d\n"), qse_env_insertsys (env, QSE_T("WHAT")));
qse_printf (QSE_T("inserting an empty string => %d\n"), qse_env_insertsys (env, QSE_T("")));
dump (env); dump (env);

6
qse/samples/cmn/lda.c
View File

@ -400,7 +400,7 @@ static int test5 ()
for (i = 0; i < 25; i++) for (i = 0; i < 25; i++)
{ {
j = random () % 100; j = rand () % 100;
qse_lda_pushheap (s1, &j, 1); qse_lda_pushheap (s1, &j, 1);
} }
@ -415,7 +415,7 @@ static int test5 ()
for (i = 0; i < 25; i++) for (i = 0; i < 25; i++)
{ {
j = random () % 100; j = rand () % 100;
qse_lda_pushheap (s1, &j, 1); qse_lda_pushheap (s1, &j, 1);
} }
@ -431,7 +431,7 @@ static int test5 ()
qse_lda_setcomper (s1, default_comparator); qse_lda_setcomper (s1, default_comparator);
for (i = 0; i < 25; i++) for (i = 0; i < 25; i++)
{ {
j = random () % 100; j = rand () % 100;
qse_lda_pushheap (s1, &j, 1); qse_lda_pushheap (s1, &j, 1);
} }

32
qse/samples/cmn/pio.c
View File

@ -244,6 +244,32 @@ static int test8 (void)
} }
static int test9 (void) static int test9 (void)
{
return pio1 (
#ifdef _WIN32
(const qse_char_t*)".\\sll.exe",
#else
(const qse_char_t*)"/bin/ls -laF",
#endif
QSE_PIO_MBSCMD|QSE_PIO_READOUT|QSE_PIO_WRITEIN,
QSE_PIO_OUT
);
}
static int test10 (void)
{
return pio1 (
#ifdef _WIN32
(const qse_char_t*)"dir /a",
#else
(const qse_char_t*)"/bin/ls -laF",
#endif
QSE_PIO_MBSCMD|QSE_PIO_READOUT|QSE_PIO_WRITEIN|QSE_PIO_SHELL,
QSE_PIO_OUT
);
}
static int test11 (void)
{ {
qse_pio_t* pio; qse_pio_t* pio;
int x; int x;
@ -272,7 +298,7 @@ static int test9 (void)
qse_printf (QSE_T("sleeping for %d seconds\n"), n); qse_printf (QSE_T("sleeping for %d seconds\n"), n);
Sleep (n * 1000); Sleep (n * 1000);
qse_printf (QSE_T("WaitForSingleObject....%d\n"), qse_printf (QSE_T("WaitForSingleObject....%d\n"),
WaitForSingleObject (pio->child, 0)); (int)WaitForSingleObject (pio->child, 0));
} }
#elif defined(__OS2__) #elif defined(__OS2__)
{ {
@ -282,7 +308,7 @@ static int test9 (void)
qse_printf (QSE_T("sleeping for %d seconds\n"), n); qse_printf (QSE_T("sleeping for %d seconds\n"), n);
DosSleep (n * 1000); DosSleep (n * 1000);
qse_printf (QSE_T("WaitForSingleObject....%d\n"), qse_printf (QSE_T("WaitForSingleObject....%d\n"),
WaitForSingleObject (pio->child, 0)); (int)WaitForSingleObject (pio->child, 0));
DosWaitChild (DCWA_PROCESS, DCWW_WAIT,..); DosWaitChild (DCWA_PROCESS, DCWW_WAIT,..);
} }
#else #else
@ -324,6 +350,8 @@ int main ()
R (test7); R (test7);
R (test8); R (test8);
R (test9); R (test9);
R (test10);
R (test11);
return 0; return 0;
} }