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.
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:
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.
* not allowed */
qse_awk_clrpt (awk, left);
SETERR_LOC (awk, QSE_AWK_EPREPST, xloc);
return QSE_NULL;
if (opcode1 != -1 && opcode2 != -1)
{
/* both prefix and postfix increment operator.
* not allowed */
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 */
return left;
}
else if (opcode1 != -1)
{
/* prefix increment operator */
/* prefix increment operator.
* ignore a potential postfix operator */
type = QSE_AWK_NDE_EXP_INCPRE;
opcode = opcode1;
}
@ -4175,9 +4180,18 @@ static qse_awk_nde_t* parse_increment (
if (!is_var(left) && left->type != QSE_AWK_NDE_POS)
{
qse_awk_clrpt (awk, left);
SETERR_LOC (awk, QSE_AWK_EINCDECOPR, xloc);
return QSE_NULL;
if (type == QSE_AWK_NDE_EXP_INCPST)
{
/* 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*)

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

@ -23,6 +23,10 @@
#include <qse/cmn/str.h>
#include "mem.h"
#if defined(_WIN32)
# include <windows.h>
#endif
#define STRSIZE 4096
#define ARRSIZE 128
@ -207,7 +211,7 @@ static int add_envstrw (qse_env_t* env, const qse_wchar_t* nv)
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;
@ -224,7 +228,7 @@ static int deletem (qse_env_t* env, const qse_wchar_t* name)
/* bingo */
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;
QSE_MEMCPY (vp, vp + len, rem * QSE_SIZEOF(*vp));
env->str.len -= len;
@ -416,7 +420,7 @@ int qse_env_deletem (qse_env_t* env, const qse_mchar_t* name)
}
#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;
@ -449,7 +453,7 @@ static qse_char_t* getenv (const qse_char_t* name, int* free)
# error IMPLEMENT THIS
#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;
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)
{
#if defined(_WIN32) && defined(QSE_CHAR_IS_WCHAR)
int ret, free;
qse_wchar_t* v;
int free;
int ret = -1;
v = getenv (name, &free);
if (v == QSE_NULL) return 0;
ret = insertw (env, name, v);
if (free) QSE_MMGR_FREE (env->mmgr, v);
v = get_env (env, name, &free);
if (v)
{
ret = insertw (env, name, v);
if (free) QSE_MMGR_FREE (env->mmgr, v);
}
return ret;
#else
/* convert wchar to mchar */
@ -513,13 +520,16 @@ int qse_env_insertsysm (qse_env_t* env, const qse_mchar_t* name)
return ret;
#else
int ret, free;
qse_mchar_t* v;
int free;
int ret = -1;
v = getenv (name, &free);
if (v == QSE_NULL) return -1;
ret = insertm (env, name, v);
if (free) QSE_MMGR_FREE (env->mmgr, v);
v = get_env (env, name, &free);
if (v)
{
ret = insertm (env, name, v);
if (free) QSE_MMGR_FREE (env->mmgr, v);
}
return ret;
#endif
}
@ -536,14 +546,24 @@ static int load_curenv (qse_env_t* env)
#if defined(QSE_CHAR_IS_WCHAR)
while (*envstr != QSE_WT('\0'))
{
if (add_envstrw (env, envstr) <= -1) { ret = -1; goto done; }
envstr += qse_wcslen(evnstr) + 1;
/* It seems that entries like the followings exist in the
* 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
while (*envstr != QSE_MT('\0'))
{
if (add_envstrm (env, envstr) <= -1) { ret = -1; goto done; }
envstr += qse_mbslen(evnstr) + 1;
if (*envstr != QSE_MT('=') &&
add_envstrm (env, envstr) <= -1) { ret = -1; goto done; }
envstr += qse_mbslen (envstr) + 1;
}
#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.
This file is part of QSE.
@ -244,19 +244,66 @@ qse_pio_t* qse_pio_init (
* takes the entire command line */
{
const qse_char_t* dupcmd;
qse_char_t* dupcmd;
BOOL x;
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 (
mmgr, (11+qse_strlen(cmd)+1 )*QSE_SIZEOF(qse_char_t));
mmgr, (11 + reqlen) * QSE_SIZEOF(*dupcmd)
);
if (dupcmd == QSE_NULL) goto oops;
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 (
QSE_NULL, /* LPCTSTR lpApplicationName */
@ -275,7 +322,7 @@ qse_pio_t* qse_pio_init (
&procinfo /* LPPROCESS_INFORMATION lpProcessInformation */
);
if (dupcmd != cmd) QSE_MMGR_FREE (mmgr, dupcmd);
QSE_MMGR_FREE (mmgr, dupcmd);
if (x == FALSE) goto oops;
}
@ -459,11 +506,18 @@ qse_pio_t* qse_pio_init (
#ifdef QSE_CHAR_IS_MCHAR
mn = qse_strlen(cmd);
#else
n = qse_wcstombslen (cmd, &mn);
if (cmd[n] != QSE_WT('\0')) goto oops; /* illegal sequence found */
if (oflags & QSE_PIO_MBSCMD)
{
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
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;
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
qse_mbscpy (&cmd_line[11], cmd);
#else
mn = mn + 1; /* update the buffer size */
n = qse_wcstombs (cmd, &cmd_line[11], &mn);
if (oflags & QSE_PIO_MBSCMD)
{
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
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);
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 */
if (oflags & QSE_PIO_MBSCMD)
{
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;
cmd_line = QSE_MMGR_ALLOC (pio->mmgr, mn * QSE_SIZEOF(qse_char_t));
if (cmd_line == QSE_NULL) goto oops;
mn = mn + 1;
cmd_line = QSE_MMGR_ALLOC (pio->mmgr, mn * QSE_SIZEOF(qse_char_t));
if (cmd_line == QSE_NULL) goto oops;
qse_wcstombs (cmd, cmd_line, &mn);
qse_wcstombs (cmd, cmd_line, &mn);
}
#endif
/* 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
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("alloc = %lu\n"), (unsigned long)xma->stat.alloc);
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("alloc = %llu\n"), (unsigned long long)xma->stat.alloc);
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
@ -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"));
for (tmp = xma->head, fsum = 0, asum = 0; tmp; tmp = tmp->b.next)
{
#if QSE_SIZEOF_LONG >= QSE_SIZEOF_LONG_LONG
dumper (ctx, QSE_T(" %-18lu %-5d %p\n"),
(unsigned long)tmp->size, tmp->avail, tmp
#if (QSE_SIZEOF_SIZE_T == QSE_SIZEOF_LONG)
dumper (ctx, QSE_T(" %-18lu %-5u %p\n"),
(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
dumper (ctx, QSE_T(" %-18llu %-5d %p\n"),
(unsigned long long)tmp->size, tmp->avail, tmp
);
# error weird size of qse_size_t. unsupported platform
#endif
if (tmp->avail) fsum += 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
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("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("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
#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("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("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

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

@ -3,5 +3,10 @@ BEGIN {
a = 21;
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 @@
#
# $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
#
#!/usr/bin/gawk -f
# --- Representation of Lisp data
BEGIN {
a_number = 0;
pair_ptr = a_pair = 1;
symbol_ptr = a_symbol = 2;
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";
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;
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 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 make_number(n) { return n * 4 }
function numeric_value(expr)
{
if (expr % 4 != 0) error("Not a number");
return expr / 4;
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;
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));
sym = string_to_symbol(name)
value[sym] = string_to_symbol(sprintf("#<Primitive %s>", name))
if (nparams != "")
num_params[value[sym]] = nparams;
return value[sym];
num_params[value[sym]] = nparams
return value[sym]
}
# --- Garbage collection
@ -70,119 +60,119 @@ function def_prim(name, nparams, sym)
function cons(the_car, the_cdr)
{
while (pair_ptr in marks) {
delete marks[pair_ptr];
pair_ptr += 4;
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;
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 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];
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);
printf("\nGC...") >"/dev/stderr"
mark(the_car); mark(the_cdr)
for (p in protected)
mark(protected[p]);
mark(protected[p])
for (p in stack)
mark(stack[p]);
mark(stack[p])
for (p in value)
mark(value[p]);
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]);
i = index(SUBSEP, p)
mark(substr(p, 1, i-1))
mark(substr(p, i+1))
mark(property[p])
}
pair_ptr = a_pair;
pair_ptr = a_pair
while (pair_ptr in marks) {
delete marks[pair_ptr];
pair_ptr += 4;
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;
if (loud_gc)
printf("Expanding heap...") >"/dev/stderr"
pair_limit += 4 * heap_increment
}
}
# --- Set up
BEGIN {
srand();
srand()
frame_ptr = stack_ptr = 0;
frame_ptr = stack_ptr = 0
if (heap_increment == "") heap_increment = 1500;
pair_limit = a_pair + 4 * heap_increment;
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...
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)";
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;
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");
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");
DRIVER = string_to_symbol("top-level-driver")
}
# --- The interpreter
@ -190,21 +180,21 @@ BEGIN {
BEGIN {
for (;;) {
if (DRIVER in value && value[DRIVER] != NIL)
apply(value[DRIVER]);
apply(value[DRIVER])
else {
expr = read();
expr = read()
if (expr == THE_EOF_OBJECT)
break;
protect(expr);
print_expr(eval(expr));
unprotect();
protect(expr)
print_expr(eval(expr))
unprotect()
}
}
if (profiling)
for (proc in call_count) {
printf("%5d ", call_count[proc]);
print_expr(proc);
printf("%5d ", call_count[proc])
print_expr(proc)
}
}
@ -215,64 +205,64 @@ 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];
if (!(expr in value)) error("Unbound variable: " printname[expr])
return value[expr]
} 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)) {
old_frame_ptr = frame_ptr;
frame_ptr = stack_ptr;
old_frame_ptr = frame_ptr
frame_ptr = stack_ptr
eval_rands(cdr[expr]);
protect(proc = eval(car[expr]));
result = apply(proc);
unprotect();
eval_rands(cdr[expr])
protect(proc = eval(car[expr]))
result = apply(proc)
unprotect()
stack_ptr = frame_ptr;
frame_ptr = old_frame_ptr;
return result;
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 == 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]]]);
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;
progn(cdr[cdr[expr]])
return NIL
}
if (op == DEFINE) {
value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]]);
return car[cdr[expr]];
value[car[cdr[expr]]] = eval(car[cdr[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.
function progn(exprs)
{
for (; cdr[exprs] != NIL; exprs = cdr[exprs])
eval(car[exprs]);
return eval(car[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]);
stack[stack_ptr++] = eval(car[rands])
}
# Call the procedure :proc, with args stack[frame_ptr]..stack[stack_ptr-1]
@ -280,72 +270,72 @@ function eval_rands(rands)
function apply(proc)
{
if (profiling)
++call_count[proc];
++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;
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]]);
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");
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;
old_frame_ptr = frame_ptr
frame_ptr = stack_ptr
for (; is_pair(args); args = cdr[args])
stack[stack_ptr++] = car[args];
stack[stack_ptr++] = car[args]
if (args != NIL)
error("Bad argument to APPLY: not a proper list");
result = apply(proc);
error("Bad argument to APPLY: not a proper list")
result = apply(proc)
stack_ptr = frame_ptr;
frame_ptr = old_frame_ptr;
return result;
stack_ptr = frame_ptr
frame_ptr = old_frame_ptr
return result
}
function listify_args( p, result)
{
result = NIL;
result = NIL
for (p = stack_ptr - 1; frame_ptr <= p; --p)
result = cons(stack[p], result);
return result;
result = cons(stack[p], result)
return result
}
# --- The environment
@ -361,24 +351,24 @@ 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;
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");
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]];
delete value[car[vars]]
else
value[car[vars]] = stack[p];
++p;
value[car[vars]] = stack[p]
++p
}
}
@ -386,32 +376,32 @@ function unwind_env(vars, p)
function print_expr(expr)
{
write_expr(expr);
print "";
write_expr(expr)
print ""
}
function write_expr(expr)
{
if (is_atom(expr)) {
if (!is_symbol(expr))
printf("%d", numeric_value(expr));
printf("%d", numeric_value(expr))
else {
if (!(expr in printname))
error("BUG: " expr " has no printname");
printf("%s", printname[expr]);
error("BUG: " expr " has no printname")
printf("%s", printname[expr])
}
} else {
printf("(");
write_expr(car[expr]);
printf("(")
write_expr(car[expr])
for (expr = cdr[expr]; is_pair(expr); expr = cdr[expr]) {
printf(" ");
write_expr(car[expr]);
printf(" ")
write_expr(car[expr])
}
if (expr != NIL) {
printf(" . ");
write_expr(expr);
printf(" . ")
write_expr(expr)
}
printf(")");
printf(")")
}
}
@ -419,72 +409,72 @@ function write_expr(expr)
function read( committed, result)
{
skip_blanks();
skip_blanks()
if (token == eof)
if (committed)
error("Unexpected EOF");
error("Unexpected EOF")
else
return THE_EOF_OBJECT;
return THE_EOF_OBJECT
if (token == "(") { # read a list
advance();
result = NIL;
advance()
result = NIL
for (;;) {
skip_blanks();
skip_blanks()
if (token == ".") {
advance();
after_dot = read(1);
skip_blanks();
advance()
after_dot = read(1)
skip_blanks()
if (token != ")")
error("')' expected");
advance();
return nreverse(result, after_dot);
error("')' expected")
advance()
return nreverse(result, after_dot)
} else if (token == ")") {
advance();
return nreverse(result, NIL);
advance()
return nreverse(result, NIL)
} else {
protect(result);
result = cons(read(1), result);
unprotect();
protect(result)
result = cons(read(1), result)
unprotect()
}
}
} else if (token == "'") { # a quoted expression
advance();
return cons(QUOTE, cons(read(1), NIL));
advance()
return cons(QUOTE, cons(read(1), NIL))
} else if (token ~ /^-?[0-9]+$/) { # a number
result = make_number(token);
advance();
return result;
result = make_number(token)
advance()
return result
} else { # a symbol
result = string_to_symbol(token);
advance();
return result;
result = string_to_symbol(token)
advance()
return result
}
}
function skip_blanks()
{
while (token ~ /^[ \t]*$/)
advance();
advance()
}
function advance()
{
if (token == eof) return eof;
if (token == eof) return eof
if (token == "") {
if (getline line <= 0) {
token = eof;
return;
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);
token = substr(line, RSTART, RLENGTH)
line = substr(line, RLENGTH+1)
} else if (line == "" || substr(line, 1, 1) == ";")
token = ""; # this kludge permits interactive use
token = "" # this kludge permits interactive use
else
error("Lexical error starting at " line);
error("Lexical error starting at " line)
}
# --- Miscellany
@ -493,19 +483,18 @@ function advance()
function nreverse(list, reversed_head, tail)
{
while (is_pair(list)) { #** speed?
tail = cdr[list];
cdr[list] = reversed_head;
reversed_head = list;
list = tail;
tail = cdr[list]
cdr[list] = reversed_head
reversed_head = list
list = tail
}
if (list != NIL)
error("Not a proper list - reverse!");
return reversed_head;
error("Not a proper list - reverse!")
return reversed_head
}
function error(reason)
{
print "ERROR: " reason >"/dev/stderr";
exit(1);
print "ERROR: " reason >"/dev/stderr"
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-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
rcalc.awk!!!--newline=on -v target=89000
quicksort.awk!quicksort.dat!!
@ -179,8 +179,17 @@ PROGS="
wordfreq.awk!wordfreq.awk!!
hanoi.awk!!!
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}" ] ||
{
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)
{
qse_env_t* env;
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("%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("%d\n"), qse_env_insertsys (env, QSE_T("WHAT")));
qse_printf (QSE_T("inserting PATH => %d\n"), qse_env_insertsys (env, QSE_T("PATH")));
qse_printf (QSE_T("inserting HOME => %d\n"), qse_env_insertsysm (env, QSE_MT("HOME")));
qse_printf (QSE_T("inserting USER => %d\n"), qse_env_insertsysw (env, QSE_WT("USER")));
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);

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

@ -400,7 +400,7 @@ static int test5 ()
for (i = 0; i < 25; i++)
{
j = random () % 100;
j = rand () % 100;
qse_lda_pushheap (s1, &j, 1);
}
@ -415,7 +415,7 @@ static int test5 ()
for (i = 0; i < 25; i++)
{
j = random () % 100;
j = rand () % 100;
qse_lda_pushheap (s1, &j, 1);
}
@ -431,7 +431,7 @@ static int test5 ()
qse_lda_setcomper (s1, default_comparator);
for (i = 0; i < 25; i++)
{
j = random () % 100;
j = rand () % 100;
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)
{
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;
int x;
@ -272,7 +298,7 @@ static int test9 (void)
qse_printf (QSE_T("sleeping for %d seconds\n"), n);
Sleep (n * 1000);
qse_printf (QSE_T("WaitForSingleObject....%d\n"),
WaitForSingleObject (pio->child, 0));
(int)WaitForSingleObject (pio->child, 0));
}
#elif defined(__OS2__)
{
@ -282,7 +308,7 @@ static int test9 (void)
qse_printf (QSE_T("sleeping for %d seconds\n"), n);
DosSleep (n * 1000);
qse_printf (QSE_T("WaitForSingleObject....%d\n"),
WaitForSingleObject (pio->child, 0));
(int)WaitForSingleObject (pio->child, 0));
DosWaitChild (DCWA_PROCESS, DCWW_WAIT,..);
}
#else
@ -324,6 +350,8 @@ int main ()
R (test7);
R (test8);
R (test9);
R (test10);
R (test11);
return 0;
}