diff --git a/qse/cmd/awk/awk.c b/qse/cmd/awk/awk.c index 92952d1a..94f169fc 100644 --- a/qse/cmd/awk/awk.c +++ b/qse/cmd/awk/awk.c @@ -29,7 +29,6 @@ #include #include #include -#include #include #include @@ -56,10 +55,6 @@ # include #endif - - -#include - static qse_awk_rtx_t* app_rtx = QSE_NULL; static int app_debug = 0; @@ -98,11 +93,6 @@ struct gvmv_t qse_size_t len; }; -struct rtx_xtn_t -{ - qse_awk_rio_fun_t old_pipe_handler; -}; - static void dprint (const qse_char_t* fmt, ...) { if (app_debug) @@ -894,143 +884,6 @@ static qse_mmgr_t debug_mmgr = }; #endif -static qse_ssize_t nwio_handler_open ( - qse_awk_rtx_t* rtx, qse_awk_rio_arg_t* riod, int flags, qse_nwad_t* nwad) -{ - qse_nwio_t* handle; - - handle = qse_nwio_open ( - qse_awk_rtx_getmmgr(rtx), 0, nwad, - flags | QSE_NWIO_TEXT | QSE_NWIO_IGNOREMBWCERR | - QSE_NWIO_READNORETRY | QSE_NWIO_WRITENORETRY - ); - if (handle == QSE_NULL) return -1; - -#if defined(QSE_CHAR_IS_WCHAR) - { - qse_cmgr_t* cmgr = qse_awk_rtx_getcmgrstd (rtx, riod->name); - if (cmgr) qse_nwio_setcmgr (handle, cmgr); - } -#endif - - riod->handle2 = (void*)handle; - return 1; -} - -static qse_ssize_t nwio_handler_rest ( - qse_awk_rtx_t* rtx, qse_awk_rio_cmd_t cmd, qse_awk_rio_arg_t* riod, - qse_char_t* data, qse_size_t size) -{ - switch (cmd) - { - case QSE_AWK_RIO_OPEN: - { - qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); - return -1; - } - - case QSE_AWK_RIO_CLOSE: - { - qse_nwio_close ((qse_nwio_t*)riod->handle2); - riod->handle2 = QSE_NULL; - return 0; - } - - case QSE_AWK_RIO_READ: - { - return qse_nwio_read ((qse_nwio_t*)riod->handle2, data, size); - } - - case QSE_AWK_RIO_WRITE: - { - return qse_nwio_write ((qse_nwio_t*)riod->handle2, data, size); - } - - case QSE_AWK_RIO_FLUSH: - { - /*if (riod->mode == QSE_AWK_RIO_PIPE_READ) return -1;*/ - return qse_nwio_flush ((qse_nwio_t*)riod->handle2); - } - - case QSE_AWK_RIO_NEXT: - { - qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); - return -1; - } - } - - qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); - return -1; -} - -static int parse_pipe_uri (const qse_char_t* uri, int* flags, qse_nwad_t* nwad) -{ - static struct - { - qse_char_t* prefix; - qse_size_t len; - int flags; - } x[] = - { - { QSE_T("tcp://"), 6, QSE_NWIO_TCP }, - { QSE_T("udp://"), 6, QSE_NWIO_UDP }, - { QSE_T("tcpd://"), 7, QSE_NWIO_TCP | QSE_NWIO_PASSIVE }, - { QSE_T("udpd://"), 7, QSE_NWIO_UDP | QSE_NWIO_PASSIVE } - }; - int i; - - - for (i = 0; i < QSE_COUNTOF(x); i++) - { - if (qse_strzcmp (uri, x[i].prefix, x[i].len) == 0) - { - if (qse_strtonwad (uri + x[i].len, nwad) <= -1) return -1; - *flags = x[i].flags; - return 0; - } - } - - return -1; -} - -static qse_ssize_t new_pipe_handler ( - qse_awk_rtx_t* rtx, qse_awk_rio_cmd_t cmd, qse_awk_rio_arg_t* riod, - qse_char_t* data, qse_size_t size) -{ - struct rtx_xtn_t* xtn; - int flags; - qse_nwad_t nwad; - - xtn = qse_awk_rtx_getxtnstd (rtx); - - if (cmd == QSE_AWK_RIO_OPEN && parse_pipe_uri (riod->name, &flags, &nwad) >= 0) - return nwio_handler_open (rtx, riod, flags, &nwad); - else if (riod->handle2) - return nwio_handler_rest (rtx, cmd, riod, data, size); - else - return xtn->old_pipe_handler (rtx, cmd, riod, data, size); -} - -static void extend_pipe_handler (qse_awk_rtx_t* rtx) -{ - struct rtx_xtn_t* xtn; - qse_awk_rio_t rio; - - xtn = qse_awk_rtx_getxtnstd (rtx); - - /* get the previous handler functions */ - qse_awk_rtx_getrio (rtx, &rio); - - /* remember the old pipe handler function */ - xtn->old_pipe_handler = rio.pipe; - - /* change the pipe handler to a new one */ - rio.pipe = new_pipe_handler; - - /* changes the handlers with a new set */ - qse_awk_rtx_setrio (rtx, &rio); -} - static int awk_main (int argc, qse_char_t* argv[]) { qse_awk_t* awk = QSE_NULL; @@ -1146,7 +999,7 @@ static int awk_main (int argc, qse_char_t* argv[]) #endif rtx = qse_awk_rtx_openstd ( - awk, QSE_SIZEOF(struct rtx_xtn_t), QSE_T("qseawk"), + awk, 0, QSE_T("qseawk"), (const qse_char_t*const*)arg.icf, QSE_NULL, arg.console_cmgr); if (rtx == QSE_NULL) { @@ -1160,8 +1013,6 @@ static int awk_main (int argc, qse_char_t* argv[]) goto oops; } - extend_pipe_handler (rtx); - app_rtx = rtx; #ifdef ENABLE_CALLBACK qse_awk_rtx_pushrcb (rtx, &rcb); @@ -1213,9 +1064,14 @@ oops: int qse_main (int argc, qse_achar_t* argv[]) { + int ret; + #if defined(_WIN32) char locale[100]; - UINT codepage = GetConsoleOutputCP(); + UINT codepage; + WSADATA wsadata; + + codepage = GetConsoleOutputCP(); if (codepage == CP_UTF8) { /*SetConsoleOUtputCP (CP_UTF8);*/ @@ -1227,10 +1083,24 @@ int qse_main (int argc, qse_achar_t* argv[]) setlocale (LC_ALL, locale); qse_setdflcmgr (qse_slmbcmgr); } + + if (WSAStartup (MAKEWORD(2,0), &wsadata) != 0) + { + print_error (QSE_T("Failed to start up winsock\n")); + return -1; + } + #else setlocale (LC_ALL, ""); qse_setdflcmgr (qse_slmbcmgr); #endif - return qse_runmain (argc, argv, awk_main); + + ret = qse_runmain (argc, argv, awk_main); + +#if defined(_WIN32) + WSACleanup (); +#endif + + return ret; } diff --git a/qse/configure b/qse/configure index b91098fb..94a2e5ca 100755 --- a/qse/configure +++ b/qse/configure @@ -16326,6 +16326,10 @@ if test "x$ac_cv_lib_socket_connect" = xyes; then : fi fi +if test "${platform_win32}" = "yes" +then + SOCKET_LIBS="$SOCKET_LIBS -lws2_32" +fi for ac_func in sendfile sendfile64 sendfilev sendfilev64 diff --git a/qse/configure.ac b/qse/configure.ac index c0679957..3e8b65c6 100644 --- a/qse/configure.ac +++ b/qse/configure.ac @@ -137,6 +137,10 @@ then AC_DEFINE(HAVE_CONNECT, 1) ]) fi +if test "${platform_win32}" = "yes" +then + SOCKET_LIBS="$SOCKET_LIBS -lws2_32" +fi AC_SUBST(SOCKET_LIBS) dnl check if sendfile and its variants exist in the standard c library diff --git a/qse/doc/page/awk.doc b/qse/doc/page/awk.doc index 331e3ec4..4215e957 100644 --- a/qse/doc/page/awk.doc +++ b/qse/doc/page/awk.doc @@ -1,14 +1,26 @@ /** @page awk AWK +@section awk_content CONTENTS +- @ref awk_intro "INTRODUCTION" +- @ref awk_lang "AWK LANGUAGE" +- @ref awk_ext "AWK LANGUAGE EXTENSIONS" + - @ref awk_ext_vardecl " VARIABLE DECLARATION" + - @ref awk_ext_include "INCLUDE" + - @ref awk_ext_rwpipe "TWO-WAY PIPE" + - @ref awk_ext_return "RETURN" + - @ref awk_ext_comment "COMMENT" + - @ref awk_ext_fnc "EXTENDED FUNCTIONS" + - @ref awk_ext_fs "EXTENDED FS" + - @ref awk_ext_binnum "BINARY NUMBER" + - @ref awk_ext_unicode "UNICODE ESCAPE SEQUENCE" + - @ref awk_ext_ioenc "I/O ENCODING" + + @section awk_intro INTRODUCTION QSEAWK is an embeddable AWK interpreter and is a part of the @ref qse_intro -"QSE" library. The interpreter implements the language described in the book - -The AWK Proramming Language -with @ref awk_ext "extensions". Its design focuses on building a flexible -and robust embedding API with minimal platform dependency. An embedding -application is capable of +"QSE" library. Its design focuses on building a flexible and robust embedding +API with minimal platform dependency. An embedding application is capable of - adding new global variables and functions. - getting and set the value of a global variable. - calling a function with or without parameters and getting its return value. @@ -39,40 +51,42 @@ The code example below demonstrates the steps in C. It executes the one liner int main () { - qse_awk_t* awk = QSE_NULL; - qse_awk_rtx_t* rtx = QSE_NULL; - qse_awk_val_t* retv; - qse_awk_parsestd_in_t psin; - int ret = -1; + qse_awk_t* awk = QSE_NULL; + qse_awk_rtx_t* rtx = QSE_NULL; + qse_awk_val_t* retv; + qse_awk_parsestd_t psin; + int ret = -1; - awk = qse_awk_openstd (0); /* open a new interpreter */ - if (!awk) FAIL ("cannot open awk"); + awk = qse_awk_openstd (0); /* open a new interpreter */ + if (!awk) FAIL ("cannot open awk"); - /* parse the hello world script from a string */ - psin.type = QSE_AWK_PARSESTD_CP; - psin.u.cp = QSE_T("BEGIN { print \"hello, world\" }"); - if (qse_awk_parsestd (awk, &psin, QSE_NULL) <= -1) - FAIL (qse_awk_geterrmsg(awk)); + /* parse the hello world script from a string */ + psin.type = QSE_AWK_PARSESTD_STR; + psin.u.str.ptr = QSE_T("BEGIN { print \"hello, world\" }"); + psin.u.str.len = qse_strlen(psin.u.str.ptr); + if (qse_awk_parsestd (awk, &psin, QSE_NULL) <= -1) + FAIL (qse_awk_geterrmsg(awk)); - rtx = qse_awk_rtx_openstd ( /* open a runtime context */ - awk, 0, /* no extension */ - QSE_T("hello"), /* ARGV[0] */ - QSE_NULL, /* stdin */ - QSE_NULL /* stdout */ - ); - if (!rtx) FAIL (qse_awk_geterrmsg(awk)); + rtx = qse_awk_rtx_openstd ( /* open a runtime context */ + awk, 0, /* no extension */ + QSE_T("hello"), /* ARGV[0] */ + QSE_NULL, /* stdin */ + QSE_NULL, /* stdout */ + QSE_NULL /* default cmgr */ + ); + if (!rtx) FAIL (qse_awk_geterrmsg(awk)); - /* exeucte BEGIN,pattern-action,END blocks */ - retv = qse_awk_rtx_loop (rtx); - if (!retv) FAIL (qse_awk_rtx_geterrmsg(rtx)); + /* exeucte BEGIN,pattern-action,END blocks */ + retv = qse_awk_rtx_loop (rtx); + if (!retv) FAIL (qse_awk_rtx_geterrmsg(rtx)); - qse_awk_rtx_refdownval (rtx, retv); /* destroy the return value */ - ret = 0; + qse_awk_rtx_refdownval (rtx, retv); /* destroy the return value */ + ret = 0; oops: - if (rtx) qse_awk_rtx_close (rtx); /* close the runtime context */ - if (awk) qse_awk_close (awk); /* close the interpreter */ - return ret; + if (rtx) qse_awk_rtx_close (rtx); /* close the runtime context */ + if (awk) qse_awk_close (awk); /* close the interpreter */ + return ret; } @endcode @@ -119,9 +133,63 @@ int main (int argc, char* argv[]) } @endcode -@section awk_ext EXTENSIONS -Some language extensions are implemented and they can be enabled by setting the -corresponding options. +This library also provides a stand-alone AWK interpreter that you can use +in a console environment. The source code is located under the +/cmd/awk subdirectory. + +@code +$ qseawk +USAGE: qseawk [options] -f sourcefile [ -- ] [datafile]* + qseawk [options] [ -- ] sourcestring [datafile]* +Where options are: + -h/--help print this message + --version print version + -D show extra information + -c/--call name call a function instead of entering + the pattern-action loop + -f/--file sourcefile set the source script file + -d/--deparsed-file deparsedfile set the deparsing output file + -F/--field-separator string set a field separator(FS) + -v/--assign var=value add a global variable with a value + -m/--memory-limit number limit the memory usage (bytes) + -X number fail the number'th memory allocation + --script-encoding string specify script file encoding name + --console-encoding string specify console encoding name + --implicit on/off allow undeclared variables + --explicit on/off allow declared variables(local,global) + --extraops on/off enable extra operators(<<,>>,^^,\) + --rio on/off enable builtin I/O including getline & print + --rwpipe on/off allow a dual-directional pipe + --newline on/off enable a newline to terminate a statement + --striprecspc on/off strip spaces in splitting a record + --stripstrspc on/off strip spaces in converting a string to a number + --nextofile on/off enable 'nextofile' + --reset on/off enable 'reset' + --crlf on/off use CRLF for a newline + --maptovar on/off allow a map to be assigned or returned + --pablock on/off enable pattern-action loop + --rexbound on/off enable {n,m} in a regular expression + --ncmponstr on/off perform numeric comparsion on numeric strings + --strictnaming on/off enable the strict naming rule + --include on/off enable 'include' +@endcode + +@section awk_lang AWK LANGUAGE +QSEAWK implements the language described in the book + +The AWK Proramming Language with various @ref awk_ext "extensions". + +- BEGIN block +- END block +- Pattern-action block +- User-defined functions +- Expressions +- Statements +- Streams + +@section awk_ext AWK LANGUAGE EXTENSIONS +Some language extensions are implemented and those can be enabled by setting +the corresponding options. @subsection awk_ext_vardecl VARIABLE DECLARATION @@ -186,6 +254,29 @@ BEGIN { } @endcode +This two-way pipe can create a TCP or UDP connection if the pipe command +string is prefixed with one of the followings: + +- tcp:// - establishes a TCP connection to a specified IP address/port. +- udp:// - establishes a TCP connection to a specified IP address/port. +- tcpd:// - binds a TCP socket to a specified IP address/port and waits for the first connection. +- udpd:// - binds a TCP socket to a specified IP address/port and waits for the first sender. + +@code +BEGIN { + # it binds a TCP socket to the IPv6 address :: and the port number + # 9999 and waits for the first coming connection. It repeats writing + # "hello world" to the first connected peer and reading a line from + # it until the session is torn down. + do { + print "hello world" || "tcpd://[::]:9999"; + if (("tcpd://[::]:9999" || getline x) <= 0) break; + print x; + } + while(1); +} +@endcode + @subsection awk_ext_return RETURN The return statement is valid in BEGIN blocks, END blocks, and pattern-action blocks as well as in functions. The execution of a calling block is aborted @@ -232,24 +323,123 @@ BEGIN { @endcode @subsection awk_ext_fs EXTENDED FS + +If the value for FS begins with a question mark followed by 4 +additional letters, QSEAWK can split a record with quoted fields +delimited by a single-letter separator. + +The 4 additional letters are composed of a field separator, +an escaper, a opening quote, and a closing quote. + @code -BEGIN { FS="?:\\\"\""; } +$ cat x.awk +BEGIN { FS="?:\\[]"; } +{ + for (i = 1; i <= NF; i++) + print "$" i ": " $i; + print "---------------"; +} @endcode +The value of FS above means the following. +- : is a field separator. +- a backslash is an escaper. +- a left bracket is an opening quote. +- a right bracket is a closing quote. + +See the following output. +@code +$ cat x.dat +[fx1]:[fx2]:[f\[x\]3] +abc:def:[a b c] +$ qseawk -f x.awk x.dat +$1: fx1 +$2: fx2 +$3: f[x]3 +--------------- +$1: abc +$2: def +$3: a b c +--------------- +@endcode + + @subsection awk_ext_binnum BINARY NUMBER Use 0b to begin a binary number sequence. @code -BEGIN { print 0b1101; } +$ qseawk 'BEGIN { printf ("%b %o %d %x\n", 0b1101, 0b1101, 0b1101, 0b1101); }' +1101 15 13 d @endcode + + @subsection awk_ext_unicode UNICODE ESCAPE SEQUENCE If QSE is compiled for #QSE_CHAR_IS_WCHAR, you can use \\u and \\U in a string to specify a character by unicode. @code -BEGIN { print "string=>[\uB313\U0000B313]"; } +$ qseawk 'BEGIN { print "\uC720\uB2C8\uCF54\uB4DC \U00007D71\U00004E00\U000078BC"; }' +유니코드 統一碼 @endcode + + +@subsection awk_ext_ioenc I/O ENCODING +You can call setenc() to set the character encoding of a stream resource like +a pipe or a file. See qse_findcmgr() for a list of supported encoding names. + +Let's say you run this simple echoing script on a WIN32 platform that has +the active code page of 949 and is reachable at the IP address 192.168.2.8. + +@code +C:\> chcp +Active code page: 949 +C:\> type s.awk +BEGIN { + sock = "tcpd://0.0.0.0:9999"; + setenc (sock, "cp949"); # this is not needed since the active + # code page is already 949. + do { + + if ((sock || getline x) <= 0) break; + print "PEER: " x; + print x || sock; + } + while(1); +} +C:\> qseawk --rwpipe=on -f r.awk +PEER: 안녕 +PEER: ?好! +@endcode + +Now you run the following script on a UTF-8 console of a Linux box. + +@code +$ echo $LANG +en_US.UTF-8 +$ cat c.awk +BEGIN { + peer = "tcp://192.168.2.8:9999"; + setenc (peer, "cp949"); + do + { + printf "> "; + if ((getline x) <= 0) break; + print x || peer; + if ((peer || getline line) <= -1) break; + print "PEER: " line; + } + while (1); +} +$ qseawk --rwpipe=on -f c.awk +> 안녕 +PEER: 안녕 +> 你好! +PEER: ?好! +@endcode + +Note that 你 has been converted to a question mark since the letter is +not supported by cp949. */ diff --git a/qse/doc/page/io.doc b/qse/doc/page/io.doc index 92664569..6429f249 100644 --- a/qse/doc/page/io.doc +++ b/qse/doc/page/io.doc @@ -4,5 +4,5 @@ - Generic text stream interface #qse_tio_t - Simple text stream over a file #qse_sio_t - Pipe stream to/from a process #qse_pio_t - +- Network stream to/from a remote/local host #qse_nwio_t */ diff --git a/qse/include/qse/Makefile.am b/qse/include/qse/Makefile.am index b2e353b0..6909e9c8 100644 --- a/qse/include/qse/Makefile.am +++ b/qse/include/qse/Makefile.am @@ -11,10 +11,10 @@ pkginclude_HEADERS += Types.hpp endif install-data-hook: - @$(ECHO) "#ifndef _QSE_CONFIG_H_" > "$(DESTDIR)$(pkgincludedir)/config.h" - @$(ECHO) "#define _QSE_CONFIG_H_" >> "$(DESTDIR)$(pkgincludedir)/config.h" + @echo "#ifndef _QSE_CONFIG_H_" > "$(DESTDIR)$(pkgincludedir)/config.h" + @echo "#define _QSE_CONFIG_H_" >> "$(DESTDIR)$(pkgincludedir)/config.h" @$(EGREP) "#define[ ]+QSE_" "$(top_builddir)/include/qse/config.h" >> "$(DESTDIR)$(pkgincludedir)/config.h" - @$(ECHO) "#endif" >> "$(DESTDIR)$(pkgincludedir)/config.h" + @echo "#endif" >> "$(DESTDIR)$(pkgincludedir)/config.h" @$(RM) "$(DESTDIR)$(pkgincludedir)/config.h.in" @$(SED) 's|/\*#define QSE_HAVE_CONFIG_H\*/|#define QSE_HAVE_CONFIG_H|' "$(srcdir)/types.h" > "$(DESTDIR)$(pkgincludedir)/types.h" diff --git a/qse/include/qse/Makefile.in b/qse/include/qse/Makefile.in index 966876f5..e6b091e5 100644 --- a/qse/include/qse/Makefile.in +++ b/qse/include/qse/Makefile.in @@ -661,10 +661,10 @@ uninstall-am: uninstall-pkgincludeHEADERS install-data-hook: - @$(ECHO) "#ifndef _QSE_CONFIG_H_" > "$(DESTDIR)$(pkgincludedir)/config.h" - @$(ECHO) "#define _QSE_CONFIG_H_" >> "$(DESTDIR)$(pkgincludedir)/config.h" + @echo "#ifndef _QSE_CONFIG_H_" > "$(DESTDIR)$(pkgincludedir)/config.h" + @echo "#define _QSE_CONFIG_H_" >> "$(DESTDIR)$(pkgincludedir)/config.h" @$(EGREP) "#define[ ]+QSE_" "$(top_builddir)/include/qse/config.h" >> "$(DESTDIR)$(pkgincludedir)/config.h" - @$(ECHO) "#endif" >> "$(DESTDIR)$(pkgincludedir)/config.h" + @echo "#endif" >> "$(DESTDIR)$(pkgincludedir)/config.h" @$(RM) "$(DESTDIR)$(pkgincludedir)/config.h.in" @$(SED) 's|/\*#define QSE_HAVE_CONFIG_H\*/|#define QSE_HAVE_CONFIG_H|' "$(srcdir)/types.h" > "$(DESTDIR)$(pkgincludedir)/types.h" diff --git a/qse/include/qse/awk/awk.h b/qse/include/qse/awk/awk.h index bc082a4c..5706f4a5 100644 --- a/qse/include/qse/awk/awk.h +++ b/qse/include/qse/awk/awk.h @@ -56,6 +56,7 @@ * @example awk10.c * This programs shows how to manipuate a map using qse_awk_rtx_makemapval() * and qse_awk_rtx_setmapvalfld(). + * */ /** @struct qse_awk_t diff --git a/qse/include/qse/awk/std.h b/qse/include/qse/awk/std.h index dbbb5ea6..fe9995ed 100644 --- a/qse/include/qse/awk/std.h +++ b/qse/include/qse/awk/std.h @@ -37,6 +37,11 @@ /** * @example awk09.c * This programs shows how to specify multiple console output files. + * + * @example awk11.c + * This programs shows how to extend an I/O handler implemented by + * qse_awk_rtx_openstd(). + * */ /** @@ -44,9 +49,9 @@ */ enum qse_awk_parsestd_type_t { - QSE_AWK_PARSESTD_NULL = 0, /* invalid type */ - QSE_AWK_PARSESTD_FILE = 1, - QSE_AWK_PARSESTD_STR = 2 + QSE_AWK_PARSESTD_NULL = 0, /**< invalid type */ + QSE_AWK_PARSESTD_FILE = 1, /**< file */ + QSE_AWK_PARSESTD_STR = 2 /**< length-bounded string */ }; typedef enum qse_awk_parsestd_type_t qse_awk_parsestd_type_t; diff --git a/qse/include/qse/cmn/mbwc.h b/qse/include/qse/cmn/mbwc.h index 5ae23041..d89559d5 100644 --- a/qse/include/qse/cmn/mbwc.h +++ b/qse/include/qse/cmn/mbwc.h @@ -45,8 +45,9 @@ extern qse_cmgr_t* qse_cp950cmgr; /** * The qse_getfindcmgr() function find a builtin cmgr matching a given * @a name and returns it. It returns #QSE_NULL if no match is found. - * The @a name can be one of "utf8", "slmb", and an empty string. Calling this - * function with an empty string is the same as calling qse_getdflcmgr(). + * The @a name can be one of "utf8", "slmb", "cp949", "cp950", and an + * empty string. Calling this function with an empty string is the same + * as calling qse_getdflcmgr(). */ qse_cmgr_t* qse_findcmgr ( const qse_char_t* name diff --git a/qse/include/qse/cmn/nwio.h b/qse/include/qse/cmn/nwio.h index e4f29a79..56ee216c 100644 --- a/qse/include/qse/cmn/nwio.h +++ b/qse/include/qse/cmn/nwio.h @@ -22,7 +22,7 @@ #define _QSE_CMN_NWIO_H_ /** @file - * This file defines a generic text I/O interface. + * This file defines a network-based text I/O interface. */ #include @@ -70,18 +70,20 @@ enum qse_nwio_errnum_t typedef enum qse_nwio_errnum_t qse_nwio_errnum_t; #if defined(_WIN32) -/* TODO: */ + typedef qse_intptr_t qse_nwio_hnd_t; #elif defined(__OS2__) /* TODO: */ #elif defined(__DOS__) /* TODO: */ #else typedef int qse_nwio_hnd_t; /**< defines a pipe handle type */ -# define QSE_NWIO_HND_NIL ((qse_nwio_hnd_t)-1) #endif typedef struct qse_nwio_t qse_nwio_t; +/** + * The qse_nwio_t type defines a structure for a network-based stream. + */ struct qse_nwio_t { QSE_DEFINE_COMMON_FIELDS (nwio) diff --git a/qse/lib/awk/std.c b/qse/lib/awk/std.c index 45e16e1d..b925a9c3 100644 --- a/qse/lib/awk/std.c +++ b/qse/lib/awk/std.c @@ -22,6 +22,7 @@ #include #include #include +#include #include #include #include @@ -734,6 +735,10 @@ static qse_ssize_t sf_out ( break; } + + default: + /* other code must not trigger this function */ + break; } qse_awk_seterrnum (awk, QSE_AWK_EINTERN, QSE_NULL); @@ -793,7 +798,30 @@ int qse_awk_parsestd ( /*** RTX_OPENSTD ***/ -static qse_ssize_t awk_rio_pipe ( +static qse_ssize_t nwio_handler_open ( + qse_awk_rtx_t* rtx, qse_awk_rio_arg_t* riod, int flags, qse_nwad_t* nwad) +{ + qse_nwio_t* handle; + + handle = qse_nwio_open ( + qse_awk_rtx_getmmgr(rtx), 0, nwad, + flags | QSE_NWIO_TEXT | QSE_NWIO_IGNOREMBWCERR | + QSE_NWIO_READNORETRY | QSE_NWIO_WRITENORETRY + ); + if (handle == QSE_NULL) return -1; + +#if defined(QSE_CHAR_IS_WCHAR) + { + qse_cmgr_t* cmgr = qse_awk_rtx_getcmgrstd (rtx, riod->name); + if (cmgr) qse_nwio_setcmgr (handle, cmgr); + } +#endif + + riod->handle2 = (void*)handle; + return 1; +} + +static qse_ssize_t nwio_handler_rest ( qse_awk_rtx_t* rtx, qse_awk_rio_cmd_t cmd, qse_awk_rio_arg_t* riod, qse_char_t* data, qse_size_t size) { @@ -801,55 +829,135 @@ static qse_ssize_t awk_rio_pipe ( { case QSE_AWK_RIO_OPEN: { - qse_pio_t* handle; - int flags; + qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); + return -1; + } - if (riod->mode == QSE_AWK_RIO_PIPE_READ) - { - /* TODO: should ERRTOOUT be unset? */ - flags = QSE_PIO_READOUT | - QSE_PIO_ERRTOOUT; - } - else if (riod->mode == QSE_AWK_RIO_PIPE_WRITE) - { - flags = QSE_PIO_WRITEIN; - } - else if (riod->mode == QSE_AWK_RIO_PIPE_RW) - { - flags = QSE_PIO_READOUT | - QSE_PIO_ERRTOOUT | - QSE_PIO_WRITEIN; - } - else - { - /* this must not happen */ - qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); - return -1; - } + case QSE_AWK_RIO_CLOSE: + { + qse_nwio_close ((qse_nwio_t*)riod->handle2); + riod->handle2 = QSE_NULL; + return 0; + } - handle = qse_pio_open ( - rtx->awk->mmgr, - 0, - riod->name, - QSE_NULL, - flags|QSE_PIO_SHELL|QSE_PIO_TEXT|QSE_PIO_IGNOREMBWCERR - ); - if (handle == QSE_NULL) return -1; + case QSE_AWK_RIO_READ: + { + return qse_nwio_read ((qse_nwio_t*)riod->handle2, data, size); + } + + case QSE_AWK_RIO_WRITE: + { + return qse_nwio_write ((qse_nwio_t*)riod->handle2, data, size); + } + + case QSE_AWK_RIO_FLUSH: + { + /*if (riod->mode == QSE_AWK_RIO_PIPE_READ) return -1;*/ + return qse_nwio_flush ((qse_nwio_t*)riod->handle2); + } + + case QSE_AWK_RIO_NEXT: + break; + } + + qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); + return -1; +} + +static int parse_rwpipe_uri (const qse_char_t* uri, int* flags, qse_nwad_t* nwad) +{ + static struct + { + qse_char_t* prefix; + qse_size_t len; + int flags; + } x[] = + { + { QSE_T("tcp://"), 6, QSE_NWIO_TCP }, + { QSE_T("udp://"), 6, QSE_NWIO_UDP }, + { QSE_T("tcpd://"), 7, QSE_NWIO_TCP | QSE_NWIO_PASSIVE }, + { QSE_T("udpd://"), 7, QSE_NWIO_UDP | QSE_NWIO_PASSIVE } + }; + int i; + + + for (i = 0; i < QSE_COUNTOF(x); i++) + { + if (qse_strzcmp (uri, x[i].prefix, x[i].len) == 0) + { + if (qse_strtonwad (uri + x[i].len, nwad) <= -1) return -1; + *flags = x[i].flags; + return 0; + } + } + + return -1; +} + +static qse_ssize_t pio_handler_open ( + qse_awk_rtx_t* rtx, qse_awk_rio_arg_t* riod) +{ + qse_pio_t* handle; + int flags; + + if (riod->mode == QSE_AWK_RIO_PIPE_READ) + { + /* TODO: should ERRTOOUT be unset? */ + flags = QSE_PIO_READOUT | + QSE_PIO_ERRTOOUT; + } + else if (riod->mode == QSE_AWK_RIO_PIPE_WRITE) + { + flags = QSE_PIO_WRITEIN; + } + else if (riod->mode == QSE_AWK_RIO_PIPE_RW) + { + flags = QSE_PIO_READOUT | + QSE_PIO_ERRTOOUT | + QSE_PIO_WRITEIN; + } + else + { + /* this must not happen */ + qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); + return -1; + } + + handle = qse_pio_open ( + rtx->awk->mmgr, + 0, + riod->name, + QSE_NULL, + flags|QSE_PIO_SHELL|QSE_PIO_TEXT|QSE_PIO_IGNOREMBWCERR + ); + if (handle == QSE_NULL) return -1; #if defined(QSE_CHAR_IS_WCHAR) - { - qse_cmgr_t* cmgr = qse_awk_rtx_getcmgrstd (rtx, riod->name); - if (cmgr) - { - qse_pio_setcmgr (handle, QSE_PIO_IN, cmgr); - qse_pio_setcmgr (handle, QSE_PIO_OUT, cmgr); - qse_pio_setcmgr (handle, QSE_PIO_ERR, cmgr); - } - } + { + qse_cmgr_t* cmgr = qse_awk_rtx_getcmgrstd (rtx, riod->name); + if (cmgr) + { + qse_pio_setcmgr (handle, QSE_PIO_IN, cmgr); + qse_pio_setcmgr (handle, QSE_PIO_OUT, cmgr); + qse_pio_setcmgr (handle, QSE_PIO_ERR, cmgr); + } + } #endif - riod->handle = (void*)handle; - return 1; + riod->handle = (void*)handle; + return 1; +} + +static qse_ssize_t pio_handler_rest ( + qse_awk_rtx_t* rtx, qse_awk_rio_cmd_t cmd, qse_awk_rio_arg_t* riod, + qse_char_t* data, qse_size_t size) +{ + switch (cmd) + { + case QSE_AWK_RIO_OPEN: + { + qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); + return -1; } case QSE_AWK_RIO_CLOSE: @@ -900,14 +1008,34 @@ static qse_ssize_t awk_rio_pipe ( } case QSE_AWK_RIO_NEXT: - { - return -1; - } + break; } + qse_awk_rtx_seterrnum (rtx, QSE_AWK_EINTERN, QSE_NULL); return -1; } +static qse_ssize_t awk_rio_pipe ( + qse_awk_rtx_t* rtx, qse_awk_rio_cmd_t cmd, qse_awk_rio_arg_t* riod, + qse_char_t* data, qse_size_t size) +{ + if (cmd == QSE_AWK_RIO_OPEN) + { + int flags; + qse_nwad_t nwad; + + if (riod->mode != QSE_AWK_RIO_PIPE_RW || + parse_rwpipe_uri (riod->name, &flags, &nwad) <= -1) + return pio_handler_open (rtx, riod); + else + return nwio_handler_open (rtx, riod, flags, &nwad); + } + else if (riod->handle2) + return nwio_handler_rest (rtx, cmd, riod, data, size); + else + return pio_handler_rest (rtx, cmd, riod, data, size); +} + static qse_ssize_t awk_rio_file ( qse_awk_rtx_t* rtx, qse_awk_rio_cmd_t cmd, qse_awk_rio_arg_t* riod, qse_char_t* data, qse_size_t size) diff --git a/qse/lib/cmn/Makefile.am b/qse/lib/cmn/Makefile.am index d0c80524..f7d4f40a 100644 --- a/qse/lib/cmn/Makefile.am +++ b/qse/lib/cmn/Makefile.am @@ -104,10 +104,7 @@ libqsecmn_la_SOURCES = \ xma.c libqsecmn_la_LDFLAGS = -L$(libdir) -version-info 1:0:0 -no-undefined - -#if WIN32 -#libqsecmn_la_LIBADD = -lpsapi -#endif +libqsecmn_la_LIBADD = $(SOCKET_LIBS) if ENABLE_CXX @@ -115,6 +112,7 @@ lib_LTLIBRARIES += libqsecmnxx.la libqsecmnxx_la_SOURCES = \ Mmgr.cpp StdMmgr.cpp libqsecmnxx_la_LDFLAGS = -L$(libdir) -version-info 1:0:0 -no-undefined +libqsecmnxx_la_LIBADD = endif diff --git a/qse/lib/cmn/Makefile.in b/qse/lib/cmn/Makefile.in index fce9e5db..b29b1212 100644 --- a/qse/lib/cmn/Makefile.in +++ b/qse/lib/cmn/Makefile.in @@ -35,10 +35,6 @@ PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ - -#if WIN32 -#libqsecmn_la_LIBADD = -lpsapi -#endif @ENABLE_CXX_TRUE@am__append_1 = libqsecmnxx.la subdir = lib/cmn DIST_COMMON = $(noinst_HEADERS) $(srcdir)/Makefile.am \ @@ -78,7 +74,8 @@ am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' am__installdirs = "$(DESTDIR)$(libdir)" LTLIBRARIES = $(lib_LTLIBRARIES) -libqsecmn_la_LIBADD = +am__DEPENDENCIES_1 = +libqsecmn_la_DEPENDENCIES = $(am__DEPENDENCIES_1) am_libqsecmn_la_OBJECTS = alg-rand.lo alg-search.lo alg-sort.lo \ assert.lo chr.lo cp949.lo cp950.lo dll.lo env.lo gdl.lo htb.lo \ lda.lo fio.lo fma.lo fmt.lo fs.lo fs-err.lo fs-move.lo hton.lo \ @@ -98,7 +95,7 @@ libqsecmn_la_OBJECTS = $(am_libqsecmn_la_OBJECTS) libqsecmn_la_LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(libqsecmn_la_LDFLAGS) $(LDFLAGS) -o $@ -libqsecmnxx_la_LIBADD = +libqsecmnxx_la_DEPENDENCIES = am__libqsecmnxx_la_SOURCES_DIST = Mmgr.cpp StdMmgr.cpp @ENABLE_CXX_TRUE@am_libqsecmnxx_la_OBJECTS = Mmgr.lo StdMmgr.lo libqsecmnxx_la_OBJECTS = $(am_libqsecmnxx_la_OBJECTS) @@ -384,10 +381,12 @@ libqsecmn_la_SOURCES = \ xma.c libqsecmn_la_LDFLAGS = -L$(libdir) -version-info 1:0:0 -no-undefined +libqsecmn_la_LIBADD = $(SOCKET_LIBS) @ENABLE_CXX_TRUE@libqsecmnxx_la_SOURCES = \ @ENABLE_CXX_TRUE@ Mmgr.cpp StdMmgr.cpp @ENABLE_CXX_TRUE@libqsecmnxx_la_LDFLAGS = -L$(libdir) -version-info 1:0:0 -no-undefined +@ENABLE_CXX_TRUE@libqsecmnxx_la_LIBADD = all: all-am .SUFFIXES: diff --git a/qse/lib/cmn/nwio.c b/qse/lib/cmn/nwio.c index 164cfba6..2b71df5f 100644 --- a/qse/lib/cmn/nwio.c +++ b/qse/lib/cmn/nwio.c @@ -22,7 +22,9 @@ #include "mem.h" #if defined(_WIN32) -/* TODO: */ +# include +# include /* sockaddr_in6 */ +# include #elif defined(__OS2__) /* TODO: */ #elif defined(__DOS__) @@ -97,28 +99,24 @@ static qse_nwio_errnum_t syserr_to_errnum (DWORD e) { switch (e) { - case ERROR_NOT_ENOUGH_MEMORY: - case ERROR_OUTOFMEMORY: + case WSA_NOT_ENOUGH_MEMORY: return QSE_NWIO_ENOMEM; - case ERROR_INVALID_PARAMETER: - case ERROR_INVALID_HANDLE: - case ERROR_INVALID_NAME: + case WSA_INVALID_PARAMETER: + case WSA_INVALID_HANDLE: return QSE_NWIO_EINVAL; - case ERROR_ACCESS_DENIED: + case WSAEACCES: return QSE_NWIO_EACCES; - case ERROR_FILE_NOT_FOUND: - case ERROR_PATH_NOT_FOUND: - return QSE_NWIO_ENOENT; + case WSAEINTR: + return QSE_NWIO_EINTR; - case ERROR_ALREADY_EXISTS: - case ERROR_FILE_EXISTS: - return QSE_NWIO_EEXIST; - - case ERROR_BROKEN_PIPE: - return QSE_NWIO_EPIPE; + case WSAECONNREFUSED: + case WSAENETUNREACH: + case WSAEHOSTUNREACH: + case WSAEHOSTDOWN: + return QSE_NWIO_ECONN; default: return QSE_NWIO_ESYSERR; @@ -205,12 +203,18 @@ static qse_nwio_errnum_t syserr_to_errnum (int e) case EPIPE: return QSE_NWIO_EPIPE; -#if defined(ECONNREFUSED) || defined(ENETUNREACH) +#if defined(ECONNREFUSED) || defined(ENETUNREACH) || defined(EHOSTUNREACH) || defined(EHOSTDOWN) #if defined(ECONNREFUSED) case ECONNREFUSED: #endif #if defined(ENETUNREACH) case ENETUNREACH: + #endif + #if defined(EHOSTUNREACH) + case EHOSTUNREACH: + #endif + #if defined(EHOSTDOWN) + case EHOSTDOWN: #endif return QSE_NWIO_ECONN; #endif @@ -285,13 +289,6 @@ int qse_nwio_init ( addrlen = nwad_to_sockaddr (nwad, &family, &addr); -#if defined(_WIN32) -/* TODO: */ -#elif defined(__OS2__) -/* TODO: */ -#elif defined(__DOS__) -/* TODO: */ -#else if (flags & QSE_NWIO_TCP) type = SOCK_STREAM; else if (flags & QSE_NWIO_UDP) type = SOCK_DGRAM; else @@ -300,6 +297,65 @@ int qse_nwio_init ( return -1; } +#if defined(_WIN32) + nwio->handle = socket (family, type, 0); + if (nwio->handle == INVALID_SOCKET) + { + nwio->errnum = syserr_to_errnum (WSAGetLastError()); + goto oops; + } + + if (flags & QSE_NWIO_PASSIVE) + { + qse_nwio_hnd_t handle; + + if (bind (nwio->handle, (struct sockaddr*)&addr, addrlen) == SOCKET_ERROR) + { + nwio->errnum = syserr_to_errnum (WSAGetLastError()); + goto oops; + } + + if (flags & QSE_NWIO_TCP) + { + if (listen (nwio->handle, 10) == SOCKET_ERROR) + { + nwio->errnum = syserr_to_errnum (WSAGetLastError()); + goto oops; + } + + handle = accept (nwio->handle, (struct sockaddr*)&addr, &addrlen); + if (handle == INVALID_SOCKET) + { + nwio->errnum = syserr_to_errnum (WSAGetLastError()); + goto oops; + } + + closesocket (nwio->handle); + nwio->handle = handle; + } + else if (flags & QSE_NWIO_UDP) + { + nwio->status |= UDP_CONNECT_NEEDED; + } + } + else + { + if (connect (nwio->handle, (struct sockaddr*)&addr, addrlen) == SOCKET_ERROR) + { + nwio->errnum = syserr_to_errnum (WSAGetLastError()); + goto oops; + } + } + +#elif defined(__OS2__) + nwio->errnum = QSE_NWIO_ENOIMPL; + return -1; + +#elif defined(__DOS__) + nwio->errnum = QSE_NWIO_ENOIMPL; + return -1; + +#else nwio->handle = socket (family, type, 0); if (nwio->handle <= -1) { @@ -307,12 +363,12 @@ int qse_nwio_init ( goto oops; } -#if defined(FD_CLOEXEC) + #if defined(FD_CLOEXEC) { int tmp = fcntl (nwio->handle, F_GETFD); if (tmp >= 0) fcntl (nwio->handle, F_SETFD, tmp | FD_CLOEXEC); } -#endif + #endif if (flags & QSE_NWIO_PASSIVE) { @@ -339,7 +395,15 @@ int qse_nwio_init ( goto oops; } +#if defined(_WIN32) + closesocket (nwio->handle); +#elif defined(__OS2__) +/* TODO: */ +#elif defined(__DOS__) +/* TODO: */ +#else QSE_CLOSE (nwio->handle); +#endif nwio->handle = handle; } else if (flags & QSE_NWIO_UDP) @@ -386,16 +450,22 @@ int qse_nwio_init ( return 0; oops: - if (nwio->tio) qse_tio_close (nwio->tio); + if (nwio->tio) + { + qse_tio_close (nwio->tio); + nwio->tio = QSE_NULL; + } #if defined(_WIN32) -/* TODO: */ + if (nwio->handle != INVALID_SOCKET) closesocket (nwio->handle); + #elif defined(__OS2__) /* TODO: */ + #elif defined(__DOS__) /* TODO: */ #else - QSE_CLOSE (nwio->handle); + if (nwio->handle >= 0) QSE_CLOSE (nwio->handle); #endif return -1; } @@ -409,6 +479,16 @@ void qse_nwio_fini (qse_nwio_t* nwio) qse_tio_close (nwio->tio); nwio->tio = QSE_NULL; } + +#if defined(_WIN32) + closesocket (nwio->handle); +#elif defined(__OS2__) + /* TODO: */ +#elif defined(__DOS__) + /* TODO: */ +#else + QSE_CLOSE (nwio->handle); +#endif } qse_nwio_errnum_t qse_nwio_geterrnum (const qse_nwio_t* nwio) @@ -428,7 +508,7 @@ void qse_nwio_setcmgr (qse_nwio_t* nwio, qse_cmgr_t* cmgr) qse_nwio_hnd_t qse_nwio_gethandle (const qse_nwio_t* nwio) { - return QSE_NWIO_HANDLE(nwio); + return nwio->handle; } qse_ubi_t qse_nwio_gethandleasubi (const qse_nwio_t* nwio) @@ -436,11 +516,11 @@ qse_ubi_t qse_nwio_gethandleasubi (const qse_nwio_t* nwio) qse_ubi_t ubi; #if defined(_WIN32) -/* TODO: */ + ubi.intptr = nwio->handle; #elif defined(__OS2__) -/* TODO: */ + /* TODO: */ #elif defined(__DOS__) -/* TODO: */ + /* TODO: */ #else ubi.i = nwio->handle; #endif @@ -473,7 +553,7 @@ void qse_nwio_purge (qse_nwio_t* nwio) static qse_ssize_t nwio_read (qse_nwio_t* nwio, void* buf, qse_size_t size) { #if defined(_WIN32) - DWORD count; + int count; #elif defined(__OS2__) ULONG count; APIRET rc; @@ -484,13 +564,48 @@ static qse_ssize_t nwio_read (qse_nwio_t* nwio, void* buf, qse_size_t size) #endif #if defined(_WIN32) - /* TODO: */ + if (size > (QSE_TYPE_MAX(qse_ssize_t) & QSE_TYPE_MAX(int))) + size = QSE_TYPE_MAX(qse_ssize_t) & QSE_TYPE_MAX(int); + + if (nwio->status & UDP_CONNECT_NEEDED) + { + union sockaddr_t addr; + int addrlen; + + addrlen = QSE_SIZEOF(addr); + count = recvfrom ( + nwio->handle, buf, size, 0, + (struct sockaddr*)&addr, &addrlen); + if (count == SOCKET_ERROR) nwio->errnum = syserr_to_errnum (WSAGetLastError()); + else if (count >= 1) + { + /* for udp, it just creates a stream with the + * first sender */ + if (connect (nwio->handle, (struct sockaddr*)&addr, addrlen) <= -1) + { + nwio->errnum = syserr_to_errnum (WSAGetLastError()); + return -1; + } + nwio->status &= ~UDP_CONNECT_NEEDED; + } + } + else + { + count = recv (nwio->handle, buf, size, 0); + if (count == SOCKET_ERROR) nwio->errnum = syserr_to_errnum (WSAGetLastError()); + } + + return count; #elif defined(__OS2__) - /* TODO: */ + nwio->errnum = QSE_NWIO_ENOIMPL; + return -1; #elif defined(__DOS__) - /* TODO: */ + + nwio->errnum = QSE_NWIO_ENOIMPL; + return -1; + #else if (size > (QSE_TYPE_MAX(qse_ssize_t) & QSE_TYPE_MAX(size_t))) @@ -577,7 +692,7 @@ qse_ssize_t qse_nwio_read (qse_nwio_t* nwio, void* buf, qse_size_t size) static qse_ssize_t nwio_write (qse_nwio_t* nwio, const void* data, qse_size_t size) { #if defined(_WIN32) - DWORD count; + int count; #elif defined(__OS2__) ULONG count; APIRET rc; @@ -589,15 +704,22 @@ static qse_ssize_t nwio_write (qse_nwio_t* nwio, const void* data, qse_size_t si #if defined(_WIN32) - /* TODO: */ + if (size > (QSE_TYPE_MAX(qse_ssize_t) & QSE_TYPE_MAX(int))) + size = QSE_TYPE_MAX(qse_ssize_t) & QSE_TYPE_MAX(int); + + count = send (nwio->handle, data, size, 0); + if (count == SOCKET_ERROR) nwio->errnum = syserr_to_errnum (WSAGetLastError()); + return count; #elif defined(__OS2__) - /* TODO: */ + nwio->errnum = QSE_NWIO_ENOIMPL; + return -1; #elif defined(__DOS__) - /* TODO: */ + nwio->errnum = QSE_NWIO_ENOIMPL; + return -1; #else diff --git a/qse/regress/awk/regress.out b/qse/regress/awk/regress.out index 9b89dc96..e2831e6e 100644 --- a/qse/regress/awk/regress.out +++ b/qse/regress/awk/regress.out @@ -144,19 +144,19 @@ USA 3615 237 North America -------------------------------------------------------------------------------- [CMD] qseawk -f cou-019.awk cou.dat &1 -------------------------------------------------------------------------------- -cou.dat: USSR 8649 275 Asia -cou.dat: Canada 3852 25 North America -cou.dat: China 3705 1032 Asia -cou.dat: USA 3615 237 North America -cou.dat: Brazil 3286 134 South America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: USSR 8649 275 Asia +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: Canada 3852 25 North America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: China 3705 1032 Asia +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: USA 3615 237 North America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: Brazil 3286 134 South America -------------------------------------------------------------------------------- [CMD] qseawk -f cou-020.awk cou.dat &1 -------------------------------------------------------------------------------- -cou.dat: USSR 8649 275 Asia -cou.dat: Canada 3852 25 North America -cou.dat: China 3705 1032 Asia -cou.dat: USA 3615 237 North America -cou.dat: Brazil 3286 134 South America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: USSR 8649 275 Asia +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: Canada 3852 25 North America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: China 3705 1032 Asia +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: USA 3615 237 North America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: Brazil 3286 134 South America -------------------------------------------------------------------------------- [CMD] qseawk -f cou-021.awk cou.dat &1 -------------------------------------------------------------------------------- @@ -937,7 +937,7 @@ my hello my hello my hello my hello -ERROR: CODE 15 LINE 6 COLUMN 1 - block nested too deeply +ERROR: CODE 14 LINE 6 COLUMN 1 - block nested too deeply -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-003.awk &1 -------------------------------------------------------------------------------- @@ -956,7 +956,7 @@ BEGIN { -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-004.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 42 LINE 3 COLUMN 9 - function 'a' redefined +ERROR: CODE 41 LINE 3 COLUMN 9 - function 'a' redefined -------------------------------------------------------------------------------- [CMD] qseawk --implicit=off --explicit=on --newline=on -d- -f lang-005.awk &1 -------------------------------------------------------------------------------- @@ -984,7 +984,7 @@ BEGIN { -------------------------------------------------------------------------------- [CMD] qseawk --implicit=off --explicit=on --newline=on -d- -f lang-006.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 43 LINE 5 COLUMN 10 - global variable 'a' redefined +ERROR: CODE 42 LINE 5 COLUMN 10 - global variable 'a' redefined -------------------------------------------------------------------------------- [CMD] qseawk --implicit=on --explicit=on --newline=on -d- -f lang-007.awk &1 -------------------------------------------------------------------------------- @@ -1072,7 +1072,7 @@ BEGIN { if ((ARGC >= 0)) printf ("ARGC [%++#10.10f] is positive\n",10124.1123); printf ("[%d], [%f], [%s]\n",10124.1123,10124.1123,10124.1123); - printf ("[%-10c] [% 0*.*d]\n",65,45,48,(-(1))); + printf ("[%-10c] [% 0*.*d]\n",65,45,48,-1); print sprintf("abc%d %*.*d %c %s %c",10,20,30,40,"good","good",75.34); } @@ -1147,7 +1147,7 @@ BEGIN { [CMD] qseawk --newline=on -d- -f lang-012.awk &1 -------------------------------------------------------------------------------- BEGIN { - OFS = " "; + OFS = "\t\t"; print "1==1 :",(1 == 1); print "1==0 :",(1 == 0); print "1.0==1 :",(1.0 == 1); @@ -1236,15 +1236,15 @@ BEGIN { print "\"10\" <= 10.1",("10" <= 10.1); print "\"10\" > 10.1",("10" > 10.1); print "\"10\" < 10.1",("10" < 10.1); - print (0.234 + 1.01123); + print 1.245230; print 12345678901234567890E20; print .123; - print (+(.123)); - print (-(.123)); + print 0.123000; + print -0.123000; print .123E-; - print (+(.123E-)); - print (-(.123E-)); - print ((-(.123E-)) + "123"); + print 0.123000; + print -0.123000; + print (-0.123000 + "123"); } 1==1 : 1 @@ -1352,14 +1352,14 @@ BEGIN { printf ("%s\n",10.34); } -ERROR: CODE 103 LINE 3 COLUMN 2 - recursion detected in format conversion +ERROR: CODE 102 LINE 3 COLUMN 2 - recursion detected in format conversion -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-014.awk &1 -------------------------------------------------------------------------------- BEGIN { - a = (10 + 20); - b = (10 + 20); - c = (10 + 20); + a = 30; + b = 30; + c = 30; print a,b,c; } @@ -1367,7 +1367,7 @@ BEGIN { -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-015.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 15 LINE 3 COLUMN 50 - block nested too deeply +ERROR: CODE 14 LINE 3 COLUMN 50 - block nested too deeply -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-016.awk &1 -------------------------------------------------------------------------------- @@ -1481,27 +1481,27 @@ END { -------------------------------------------------------------------------------- [CMD] qseawk --explicit=on --newline=on -d- -f lang-018.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 47 LINE 1 COLUMN 8 - duplicate global variable 'ARGV' +ERROR: CODE 46 LINE 1 COLUMN 8 - duplicate global variable 'ARGV' -------------------------------------------------------------------------------- [CMD] qseawk --explicit=on --newline=on -d- -f lang-019.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 49 LINE 1 COLUMN 15 - '+' not a valid parameter name +ERROR: CODE 48 LINE 1 COLUMN 15 - '+' not a valid parameter name -------------------------------------------------------------------------------- [CMD] qseawk --explicit=on --newline=on -d- -f lang-020.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 50 LINE 1 COLUMN 8 - '+' not a valid variable name +ERROR: CODE 49 LINE 1 COLUMN 8 - '+' not a valid variable name -------------------------------------------------------------------------------- [CMD] qseawk --explicit=on --newline=on -d- -f lang-021.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 50 LINE 3 COLUMN 8 - '+' not a valid variable name +ERROR: CODE 49 LINE 3 COLUMN 8 - '+' not a valid variable name -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-022.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 23 LINE 2 COLUMN 9 - left parenthesis expected in place of '=' +ERROR: CODE 22 LINE 2 COLUMN 9 - left parenthesis expected in place of '=' -------------------------------------------------------------------------------- [CMD] qseawk --explicit=on --newline=on -d- -f lang-023.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 28 LINE 5 COLUMN 20 - colon expected in place of ';' +ERROR: CODE 27 LINE 5 COLUMN 20 - colon expected in place of ';' -------------------------------------------------------------------------------- [CMD] qseawk --explicit=on --newline=on -d- -f lang-024.awk &1 -------------------------------------------------------------------------------- @@ -1509,9 +1509,22 @@ BEGIN { local __l0; __l0 = 21; print ((__l0 > 20))?1:2; + c = ((__l0)++ ++(b)); + print __l0; + print b; + print c; + print (99 ++(c)); + x = (("he" "ll") "o"); + x >>= " world"; + print x; } 1 +22 +1 +211 +99212 +hello world -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-025.awk &1 -------------------------------------------------------------------------------- @@ -1520,7 +1533,7 @@ BEGIN { delete iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiix; } -ERROR: CODE 78 LINE 3 COLUMN 9 - variable 'iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiix' not deletable +ERROR: CODE 77 LINE 3 COLUMN 9 - variable 'iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiix' not deletable -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-026.awk &1 -------------------------------------------------------------------------------- @@ -1532,46 +1545,46 @@ BEGIN { } abc -ERROR: CODE 86 LINE 4 COLUMN 2 - map 'abc' not assignable with a scalar +ERROR: CODE 85 LINE 4 COLUMN 2 - map 'abc' not assignable with a scalar -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-027.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 17 LINE 2 COLUMN 1 - invalid character '' +ERROR: CODE 16 LINE 2 COLUMN 1 - invalid character '' -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-028.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 41 LINE 2 COLUMN 10 - intrinsic function 'substr' redefined +ERROR: CODE 40 LINE 2 COLUMN 10 - intrinsic function 'substr' redefined -------------------------------------------------------------------------------- [CMD] qseawk --explicit=on --newline=on -d- -f lang-029.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 42 LINE 9 COLUMN 9 - function 'abc' redefined +ERROR: CODE 41 LINE 9 COLUMN 9 - function 'abc' redefined -------------------------------------------------------------------------------- [CMD] qseawk --newline=on -d- -f lang-030.awk &1 -------------------------------------------------------------------------------- BEGIN { - print (1 + 0); - print (0B11111111 + 0); - print (10 + 0); - print (0x10 + 0); - print (0b00000010 + 0); - print (0b + 0); - print (0x + 0); + print 1; + print 255; + print 10; + print 16; + print 2; + print 0; + print 0; print "-----------------------"; - print ((+(1)) + 0); - print ((+(0B11111111)) + 0); - print ((+(10)) + 0); - print ((+(0x10)) + 0); - print ((+(0b00000010)) + 0); - print ((+(0b)) + 0); - print ((+(0x)) + 0); + print 1; + print 255; + print 10; + print 16; + print 2; + print 0; + print 0; print "-----------------------"; - print ((-(1)) + 0); - print ((-(0B11111111)) + 0); - print ((-(10)) + 0); - print ((-(0x10)) + 0); - print ((-(0b00000010)) + 0); - print ((-(0b)) + 0); - print ((-(0x)) + 0); + print -1; + print -255; + print -10; + print -16; + print -2; + print 0; + print 0; } 1 @@ -1657,14 +1670,50 @@ BEGIN { [CMD] qseawk --newline=on -d- -f lang-033.awk &1 -------------------------------------------------------------------------------- BEGIN { - while ((("cat lang-033.awk" | getline x) > 0)) + while ((("cat /etc/passwd" | getline x) > 0)) print x; } -BEGIN { - while ("cat lang-033.awk" | getline x > 0) - print x -} +root:x:0:0:root:/root:/bin/bash +daemon:x:1:1:daemon:/usr/sbin:/bin/sh +bin:x:2:2:bin:/bin:/bin/sh +sys:x:3:3:sys:/dev:/bin/sh +sync:x:4:65534:sync:/bin:/bin/sync +games:x:5:60:games:/usr/games:/bin/sh +man:x:6:12:man:/var/cache/man:/bin/sh +lp:x:7:7:lp:/var/spool/lpd:/bin/sh +mail:x:8:8:mail:/var/mail:/bin/sh +news:x:9:9:news:/var/spool/news:/bin/sh +uucp:x:10:10:uucp:/var/spool/uucp:/bin/sh +proxy:x:13:13:proxy:/bin:/bin/sh +www-data:x:33:33:www-data:/var/www:/bin/sh +backup:x:34:34:backup:/var/backups:/bin/sh +list:x:38:38:Mailing List Manager:/var/list:/bin/sh +irc:x:39:39:ircd:/var/run/ircd:/bin/sh +gnats:x:41:41:Gnats Bug-Reporting System (admin):/var/lib/gnats:/bin/sh +nobody:x:65534:65534:nobody:/nonexistent:/bin/sh +libuuid:x:100:101::/var/lib/libuuid:/bin/sh +syslog:x:101:103::/home/syslog:/bin/false +messagebus:x:102:105::/var/run/dbus:/bin/false +avahi-autoipd:x:103:108:Avahi autoip daemon,,,:/var/lib/avahi-autoipd:/bin/false +avahi:x:104:109:Avahi mDNS daemon,,,:/var/run/avahi-daemon:/bin/false +couchdb:x:105:113:CouchDB Administrator,,,:/var/lib/couchdb:/bin/bash +usbmux:x:106:46:usbmux daemon,,,:/home/usbmux:/bin/false +speech-dispatcher:x:107:29:Speech Dispatcher,,,:/var/run/speech-dispatcher:/bin/sh +kernoops:x:108:65534:Kernel Oops Tracking Daemon,,,:/:/bin/false +pulse:x:109:114:PulseAudio daemon,,,:/var/run/pulse:/bin/false +rtkit:x:110:117:RealtimeKit,,,:/proc:/bin/false +saned:x:111:118::/home/saned:/bin/false +hplip:x:112:7:HPLIP system user,,,:/var/run/hplip:/bin/false +gdm:x:113:120:Gnome Display Manager:/var/lib/gdm:/bin/false +hyung-hwan:x:1000:1000:Hyung-Hwan Chung,,,:/home/hyung-hwan:/bin/bash +sshd:x:114:65534::/var/run/sshd:/usr/sbin/nologin +haldaemon:x:115:123:Hardware abstraction layer,,,:/var/run/hald:/bin/false +statd:x:116:65534::/var/lib/nfs:/bin/false +freerad:x:117:124::/etc/freeradius:/bin/false +lightdm:x:118:128:Light Display Manager:/var/lib/lightdm:/bin/false +colord:x:119:129:colord colour management daemon,,,:/var/lib/colord:/bin/false +uml-net:x:120:132::/home/uml-net:/bin/false -------------------------------------------------------------------------------- [CMD] qseawk --newline=on --rwpipe=on -d- -f lang-034.awk &1 -------------------------------------------------------------------------------- @@ -1766,7 +1815,6 @@ lease 20.1.20.57 { next binding state free; hardware ethernet 00:13:5e:50:23:6b; info awk.groupname "lang-035"; - info awk.voice-no-0 "68599021"; option agent.circuit-id "BLM1500_AR3_ILAB ONT/9/1/1 /0.0"; option agent.unknown-9 0:0:0:c1:8:45:52:49:43:53:53:4f:4e; } @@ -1778,7 +1826,6 @@ lease 20.1.20.54 { next binding state free; hardware ethernet 00:13:5e:50:25:aa; info awk.groupname "lang-035"; - info awk.voice-no-0 "68599011"; option agent.circuit-id "BLM1500_AR3_ILAB ONT/9/1/2 /0.0"; option agent.unknown-9 0:0:0:c1:8:45:52:49:43:53:53:4f:4e; } @@ -1790,7 +1837,6 @@ lease 20.1.20.55 { next binding state free; hardware ethernet 00:13:5e:50:20:af; info awk.groupname "lang-035"; - info awk.voice-no-0 "68599012"; option agent.circuit-id "BLM1500_AR3_ILAB ONT/9/2/1 /0.0"; option agent.unknown-9 0:0:0:c1:8:45:52:49:43:53:53:4f:4e; } @@ -1802,7 +1848,6 @@ lease 20.1.20.56 { next binding state free; hardware ethernet 00:13:5e:50:20:29; info awk.groupname "lang-035"; - info awk.voice-no-0 "68599022"; option agent.circuit-id "BLM1500_AR3_ILAB ONT/9/2/2 /0.0"; option agent.unknown-9 0:0:0:c1:8:45:52:49:43:53:53:4f:4e; } @@ -1855,8 +1900,6 @@ lease 10.218.255.55 { hardware ethernet 00:1b:5b:9c:90:00; info awk.groupname "lang-035"; uid "\001\000\033[\234\220\000"; - info awk.voice-no-0 "68599019"; - info awk.voice-no-1 "68599014"; option agent.circuit-id "AR_Remote atm 1/1/03/12:2.100"; option agent.remote-id "22M-fast"; } @@ -1899,7 +1942,6 @@ lease 10.218.255.66 { hardware ethernet 00:1a:04:f9:e2:90; info awk.groupname "lang-035"; uid "\001\000\032\004\371\342\220"; - info awk.voice-no-0 "68599018"; option agent.circuit-id "AR_Remote atm 1/1/03/02:2.100"; option agent.remote-id "3play"; } @@ -1912,8 +1954,6 @@ lease 10.218.255.60 { hardware ethernet 00:1e:c7:fb:29:1d; info awk.groupname "lang-035"; uid "\001\000\036\307\373)\035"; - info awk.voice-no-0 "68599017"; - info awk.voice-no-1 "68599013"; option agent.circuit-id "AL_AM3_LAB atm 1/1/01/01:2.100"; option agent.remote-id "Testing DHCP"; } @@ -2090,7 +2130,7 @@ IGNORECASE= 1 [CMD] qseawk --newline=on -d- -f lang-043.awk lang-043.dat &1 -------------------------------------------------------------------------------- BEGIN { - RS = "[ \n\v\f\r ]*[\r\n]+[ \n\v\f\r ]*"; + RS = "[\t\n\v\f\r ]*[\r\n]+[\t\n\v\f\r ]*"; } { @@ -2122,7 +2162,7 @@ killer] [CMD] qseawk --newline=on -d- -f lang-045.awk &1 -------------------------------------------------------------------------------- BEGIN { - for (i = (-(10.0)); (i < 10.0); (i)++) + for (i = -10.000000; (i < 10.0); (i)++) { print sin(i); print cos(i); @@ -2296,7 +2336,7 @@ nan 8103.08 3 -------------------------------------------------------------------------------- -[CMD] qseawk --newline=on -F: -f columnate.awk ./passwd.dat &1 +[CMD] qseawk --newline=on -F: -f columnate.awk passwd.dat &1 -------------------------------------------------------------------------------- root x 0 0 root /root /bin/bash daemon x 1 1 daemon /usr/sbin /bin/sh @@ -2382,7 +2422,7 @@ Result Ra Rb Connect Error 1.E12 99X -------------------------------------------------------------------------------- -[CMD] qseawk -f quicksort2.awk quicksort2.dat &1 +[CMD] qseawk -vQSEAWK="/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/cmd/awk/qseawk" -vSCRIPT_PATH="/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk" -f quicksort2.awk quicksort2.dat &1 -------------------------------------------------------------------------------- 0.0000000000 0.11111111111111111111111111111 @@ -2416,7 +2456,7 @@ int main () printf ("hello, world\n"); return 0; } --------------------------------------------------------------------------------- + -------------------------------------------------------------------------------- [CMD] qseawk -f wordfreq.awk wordfreq.awk &1 -------------------------------------------------------------------------------- _ 2 @@ -2590,3 +2630,2295 @@ while true do sleep 20 done +-------------------------------------------------------------------------------- +[CMD] qseawk -d- -f lisp/awklisp lisp/startup lisp/fib.lsp &1 +-------------------------------------------------------------------------------- +function eval_rands (__p0) +{ + for (; (__p0 != NIL); __p0 = cdr[__p0]) + stack[(stack_ptr)++] = eval(car[__p0]); +} + +function def_prim (__p0, __p1, __p2) +{ + __p2 = string_to_symbol(__p0); + value[__p2] = string_to_symbol(sprintf("#",__p0)); + if ((__p1 != "")) + num_params[value[__p2]] = __p1; + return value[__p2]; +} + +function is_symbol (__p0) +{ + return ((__p0 % 4) == 2); +} + +function is_number (__p0) +{ + return ((__p0 % 4) == 0); +} + +function read (__p0, __p1) +{ + skip_blanks(); + if ((token == eof)) + if (__p0) + error("Unexpected EOF"); + else + return THE_EOF_OBJECT; + if ((token == "(")) + { + advance(); + __p1 = NIL; + for (; ; ) + { + skip_blanks(); + if ((token == ".")) + { + advance(); + after_dot = read(1); + skip_blanks(); + if ((token != ")")) + error("')' expected"); + advance(); + return nreverse(__p1,after_dot); + } + else + if ((token == ")")) + { + advance(); + return nreverse(__p1,NIL); + } + else + { + protect(__p1); + __p1 = cons(read(1),__p1); + unprotect(); + } + } + } + else + if ((token == "'")) + { + advance(); + return cons(QUOTE,cons(read(1),NIL)); + } + else + if ((token ~ /^-?[0-9]+$/)) + { + __p1 = make_number(token); + advance(); + return __p1; + } + else + { + __p1 = string_to_symbol(token); + advance(); + return __p1; + } +} + +function protect (__p0) +{ + protected[++(protected_ptr)] = __p0; +} + +function mark (__p0) +{ + while ((is_pair(__p0) && (!((__p0 in marks))))) + { + marks[__p0] = 1; + mark(car[__p0]); + __p0 = cdr[__p0]; + } +} + +function write_expr (__p0) +{ + if (is_atom(__p0)) + { + if ((!(is_symbol(__p0)))) + printf ("%d",numeric_value(__p0)); + else + { + if ((!((__p0 in printname)))) + error((("BUG: " __p0) " has no printname")); + printf ("%s",printname[__p0]); + } + } + else + { + printf "("; + write_expr(car[__p0]); + for (__p0 = cdr[__p0]; is_pair(__p0); __p0 = cdr[__p0]) + { + printf " "; + write_expr(car[__p0]); + } + if ((__p0 != NIL)) + { + printf " . "; + write_expr(__p0); + } + printf ")"; + } +} + +function make_number (__p0) +{ + return (__p0 * 4); +} + +function print_expr (__p0) +{ + write_expr(__p0); + print ""; +} + +function progn (__p0) +{ + for (; (cdr[__p0] != NIL); __p0 = cdr[__p0]) + eval(car[__p0]); + return eval(car[__p0]); +} + +function string_to_symbol (__p0) +{ + if ((__p0 in intern)) + return intern[__p0]; + symbol_ptr += 4; + intern[__p0] = symbol_ptr; + printname[symbol_ptr] = __p0; + return symbol_ptr; +} + +function cons (__p0, __p1) +{ + while ((pair_ptr in marks)) + { + delete marks[pair_ptr]; + pair_ptr += 4; + } + if ((pair_ptr == pair_limit)) + gc(__p0,__p1); + car[pair_ptr] = __p0; + cdr[pair_ptr] = __p1; + pair_ptr += 4; + return (pair_ptr - 4); +} + +function listify_args (__p0, __p1) +{ + __p1 = NIL; + for (__p0 = (stack_ptr - 1); (frame_ptr <= __p0); --(__p0)) + __p1 = cons(stack[__p0],__p1); + return __p1; +} + +function numeric_value (__p0) +{ + if (((__p0 % 4) != 0)) + error("Not a number"); + return (__p0 / 4); +} + +function skip_blanks () +{ + while ((token ~ /^[ ]*$/)) + advance(); +} + +function apply (__p0) +{ + if (profiling) + ++(call_count[__p0]); + if ((car[__p0] == LAMBDA)) + { + extend_env(car[cdr[__p0]]); + result = progn(cdr[cdr[__p0]]); + unwind_env(car[cdr[__p0]]); + return result; + } + if (((__p0 in num_params) && (num_params[__p0] != (stack_ptr - frame_ptr)))) + error(("Wrong number of arguments to " printname[cdr[__p0]])); + if ((__p0 == CAR)) + return car[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CDR)) + return cdr[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CONS)) + return cons(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == NULL)) + return ((stack[frame_ptr] == NIL))?T:NIL; + if ((__p0 == EQ)) + return ((stack[frame_ptr] == stack[(frame_ptr + 1)]))?T:NIL; + if ((__p0 == ATOMP)) + return (is_atom(stack[frame_ptr]))?T:NIL; + if ((__p0 == ADD)) + return (is(a_number,stack[frame_ptr]) + is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == SUB)) + return (is(a_number,stack[frame_ptr]) - is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == MUL)) + return make_number((numeric_value(stack[frame_ptr]) * numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == DIV)) + return make_number(int((numeric_value(stack[frame_ptr]) / numeric_value(stack[(frame_ptr + 1)])))); + if ((__p0 == MOD)) + return make_number((numeric_value(stack[frame_ptr]) % numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == LT)) + return (((stack[frame_ptr] + 0) < (stack[(frame_ptr + 1)] + 0)))?T:NIL; + if ((__p0 == GET)) + return (((stack[frame_ptr],stack[(frame_ptr + 1)]) in property))?property[stack[frame_ptr],stack[(frame_ptr + 1)]]:NIL; + if ((__p0 == PUT)) + return property[stack[frame_ptr],stack[(frame_ptr + 1)]] = stack[(frame_ptr + 2)]; + if ((__p0 == CADR)) + return car[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == CDDR)) + return cdr[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == LIST)) + return listify_args(); + if ((__p0 == SYMBOLP)) + return (is_symbol(stack[frame_ptr]))?T:NIL; + if ((__p0 == PAIRP)) + return (is_pair(stack[frame_ptr]))?T:NIL; + if ((__p0 == NUMBERP)) + return (is_number(stack[frame_ptr]))?T:NIL; + if ((__p0 == SETCAR)) + return car[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == SETCDR)) + return cdr[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == APPLY)) + return do_apply(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == EVAL)) + return eval(stack[frame_ptr]); + if ((__p0 == NREV)) + return nreverse(stack[frame_ptr],NIL); + if ((__p0 == WRITE)) + { + write_expr(stack[frame_ptr]); + printf " "; + return NIL; + } + if ((__p0 == NEWLINE)) + { + printf "\n"; + return NIL; + } + if ((__p0 == READ)) + return read(); + if ((__p0 == RANDOM)) + return make_number(int((rand() * numeric_value(stack[frame_ptr])))); + if ((__p0 == GENSYM)) + return string_to_symbol(("#G" ++(gensym_counter))); + if ((__p0 == ERROR)) + { + printf "Error!\n"; + print_expr(listify_args()); + exit 1; + } + error("Unknown procedure type"); +} + +function error (__p0) +{ + print ("ERROR: " __p0) > "/dev/stderr"; + exit 1; +} + +function gc (__p0, __p1, __p2, __p3) +{ + if (loud_gc) + printf "\nGC..." > "/dev/stderr"; + mark(__p0); + mark(__p1); + for (__p2 in protected) + mark(protected[__p2]); + for (__p2 in stack) + mark(stack[__p2]); + for (__p2 in value) + mark(value[__p2]); + for (__p2 in property) + { + __p3 = index(SUBSEP,__p2); + mark(substr(__p2,1,(__p3 - 1))); + mark(substr(__p2,(__p3 + 1))); + mark(property[__p2]); + } + 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); + } +} + +function extend_env (__p0, __p1, __p2) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((__p1 == stack_ptr)) + error("Too many arguments to procedure"); + __p2 = value[car[__p0]]; + value[car[__p0]] = stack[__p1]; + stack[__p1] = __p2; + ++(__p1); + } + if ((__p1 != stack_ptr)) + error("Not enough arguments to procedure"); +} + +function is_atom (__p0) +{ + return ((__p0 % 4) != 1); +} + +function is_pair (__p0) +{ + return ((__p0 % 4) == 1); +} + +function eval (__p0, __p1) +{ + if (is_atom(__p0)) + if (is_symbol(__p0)) + { + if ((!((__p0 in value)))) + error(("Unbound variable: " printname[__p0])); + return value[__p0]; + } + else + return __p0; + op = car[__p0]; + if ((!((op in is_special)))) + { + __p1 = frame_ptr; + frame_ptr = stack_ptr; + eval_rands(cdr[__p0]); + protect(proc = eval(car[__p0])); + result = apply(proc); + unprotect(); + stack_ptr = frame_ptr; + frame_ptr = __p1; + return result; + } + if ((op == QUOTE)) + return car[cdr[__p0]]; + if ((op == LAMBDA)) + return __p0; + if ((op == IF)) + return ((eval(car[cdr[__p0]]) != NIL))?eval(car[cdr[cdr[__p0]]]):eval(car[cdr[cdr[cdr[__p0]]]]); + if ((op == PROGN)) + return progn(cdr[__p0]); + if ((op == SETQ)) + { + if ((!((car[cdr[__p0]] in value)))) + error(("Unbound variable: " printname[car[cdr[__p0]]])); + return value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + } + if ((op == WHILE)) + { + while ((eval(car[cdr[__p0]]) != NIL)) + progn(cdr[cdr[__p0]]); + return NIL; + } + if ((op == DEFINE)) + { + value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + return car[cdr[__p0]]; + } + error("BUG: Unknown special form"); +} + +function is (__p0, __p1) +{ + if (((__p1 % 4) != __p0)) + error(((("Expected a " type_name[__p0]) ", not a ") type_name[(__p1 % 4)])); + return __p1; +} + +function unwind_env (__p0, __p1) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((stack[__p1] == "")) + delete value[car[__p0]]; + else + value[car[__p0]] = stack[__p1]; + ++(__p1); + } +} + +function nreverse (__p0, __p1, __p2) +{ + while (is_pair(__p0)) + { + __p2 = cdr[__p0]; + cdr[__p0] = __p1; + __p1 = __p0; + __p0 = __p2; + } + if ((__p0 != NIL)) + error("Not a proper list - reverse!"); + return __p1; +} + +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 = ""; + else + error(("Lexical error starting at " line)); +} + +function do_apply (__p0, __p1, __p2) +{ + __p2 = frame_ptr; + frame_ptr = stack_ptr; + for (; is_pair(__p1); __p1 = cdr[__p1]) + stack[(stack_ptr)++] = car[__p1]; + if ((__p1 != NIL)) + error("Bad argument to APPLY: not a proper list"); + result = apply(__p0); + stack_ptr = frame_ptr; + frame_ptr = __p2; + return result; +} + +function unprotect () +{ + --(protected_ptr); +} + +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"; +} + +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; + 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"); +} + +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); + } +} + +-------------------------------------------------------------------------------- +[CMD] qseawk -d- -f lisp/awklisp lisp/startup lisp/numbers lisp/numbers.dat &1 +-------------------------------------------------------------------------------- +function eval_rands (__p0) +{ + for (; (__p0 != NIL); __p0 = cdr[__p0]) + stack[(stack_ptr)++] = eval(car[__p0]); +} + +function def_prim (__p0, __p1, __p2) +{ + __p2 = string_to_symbol(__p0); + value[__p2] = string_to_symbol(sprintf("#",__p0)); + if ((__p1 != "")) + num_params[value[__p2]] = __p1; + return value[__p2]; +} + +function is_symbol (__p0) +{ + return ((__p0 % 4) == 2); +} + +function is_number (__p0) +{ + return ((__p0 % 4) == 0); +} + +function read (__p0, __p1) +{ + skip_blanks(); + if ((token == eof)) + if (__p0) + error("Unexpected EOF"); + else + return THE_EOF_OBJECT; + if ((token == "(")) + { + advance(); + __p1 = NIL; + for (; ; ) + { + skip_blanks(); + if ((token == ".")) + { + advance(); + after_dot = read(1); + skip_blanks(); + if ((token != ")")) + error("')' expected"); + advance(); + return nreverse(__p1,after_dot); + } + else + if ((token == ")")) + { + advance(); + return nreverse(__p1,NIL); + } + else + { + protect(__p1); + __p1 = cons(read(1),__p1); + unprotect(); + } + } + } + else + if ((token == "'")) + { + advance(); + return cons(QUOTE,cons(read(1),NIL)); + } + else + if ((token ~ /^-?[0-9]+$/)) + { + __p1 = make_number(token); + advance(); + return __p1; + } + else + { + __p1 = string_to_symbol(token); + advance(); + return __p1; + } +} + +function protect (__p0) +{ + protected[++(protected_ptr)] = __p0; +} + +function mark (__p0) +{ + while ((is_pair(__p0) && (!((__p0 in marks))))) + { + marks[__p0] = 1; + mark(car[__p0]); + __p0 = cdr[__p0]; + } +} + +function write_expr (__p0) +{ + if (is_atom(__p0)) + { + if ((!(is_symbol(__p0)))) + printf ("%d",numeric_value(__p0)); + else + { + if ((!((__p0 in printname)))) + error((("BUG: " __p0) " has no printname")); + printf ("%s",printname[__p0]); + } + } + else + { + printf "("; + write_expr(car[__p0]); + for (__p0 = cdr[__p0]; is_pair(__p0); __p0 = cdr[__p0]) + { + printf " "; + write_expr(car[__p0]); + } + if ((__p0 != NIL)) + { + printf " . "; + write_expr(__p0); + } + printf ")"; + } +} + +function make_number (__p0) +{ + return (__p0 * 4); +} + +function print_expr (__p0) +{ + write_expr(__p0); + print ""; +} + +function progn (__p0) +{ + for (; (cdr[__p0] != NIL); __p0 = cdr[__p0]) + eval(car[__p0]); + return eval(car[__p0]); +} + +function string_to_symbol (__p0) +{ + if ((__p0 in intern)) + return intern[__p0]; + symbol_ptr += 4; + intern[__p0] = symbol_ptr; + printname[symbol_ptr] = __p0; + return symbol_ptr; +} + +function cons (__p0, __p1) +{ + while ((pair_ptr in marks)) + { + delete marks[pair_ptr]; + pair_ptr += 4; + } + if ((pair_ptr == pair_limit)) + gc(__p0,__p1); + car[pair_ptr] = __p0; + cdr[pair_ptr] = __p1; + pair_ptr += 4; + return (pair_ptr - 4); +} + +function listify_args (__p0, __p1) +{ + __p1 = NIL; + for (__p0 = (stack_ptr - 1); (frame_ptr <= __p0); --(__p0)) + __p1 = cons(stack[__p0],__p1); + return __p1; +} + +function numeric_value (__p0) +{ + if (((__p0 % 4) != 0)) + error("Not a number"); + return (__p0 / 4); +} + +function skip_blanks () +{ + while ((token ~ /^[ ]*$/)) + advance(); +} + +function apply (__p0) +{ + if (profiling) + ++(call_count[__p0]); + if ((car[__p0] == LAMBDA)) + { + extend_env(car[cdr[__p0]]); + result = progn(cdr[cdr[__p0]]); + unwind_env(car[cdr[__p0]]); + return result; + } + if (((__p0 in num_params) && (num_params[__p0] != (stack_ptr - frame_ptr)))) + error(("Wrong number of arguments to " printname[cdr[__p0]])); + if ((__p0 == CAR)) + return car[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CDR)) + return cdr[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CONS)) + return cons(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == NULL)) + return ((stack[frame_ptr] == NIL))?T:NIL; + if ((__p0 == EQ)) + return ((stack[frame_ptr] == stack[(frame_ptr + 1)]))?T:NIL; + if ((__p0 == ATOMP)) + return (is_atom(stack[frame_ptr]))?T:NIL; + if ((__p0 == ADD)) + return (is(a_number,stack[frame_ptr]) + is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == SUB)) + return (is(a_number,stack[frame_ptr]) - is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == MUL)) + return make_number((numeric_value(stack[frame_ptr]) * numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == DIV)) + return make_number(int((numeric_value(stack[frame_ptr]) / numeric_value(stack[(frame_ptr + 1)])))); + if ((__p0 == MOD)) + return make_number((numeric_value(stack[frame_ptr]) % numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == LT)) + return (((stack[frame_ptr] + 0) < (stack[(frame_ptr + 1)] + 0)))?T:NIL; + if ((__p0 == GET)) + return (((stack[frame_ptr],stack[(frame_ptr + 1)]) in property))?property[stack[frame_ptr],stack[(frame_ptr + 1)]]:NIL; + if ((__p0 == PUT)) + return property[stack[frame_ptr],stack[(frame_ptr + 1)]] = stack[(frame_ptr + 2)]; + if ((__p0 == CADR)) + return car[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == CDDR)) + return cdr[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == LIST)) + return listify_args(); + if ((__p0 == SYMBOLP)) + return (is_symbol(stack[frame_ptr]))?T:NIL; + if ((__p0 == PAIRP)) + return (is_pair(stack[frame_ptr]))?T:NIL; + if ((__p0 == NUMBERP)) + return (is_number(stack[frame_ptr]))?T:NIL; + if ((__p0 == SETCAR)) + return car[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == SETCDR)) + return cdr[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == APPLY)) + return do_apply(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == EVAL)) + return eval(stack[frame_ptr]); + if ((__p0 == NREV)) + return nreverse(stack[frame_ptr],NIL); + if ((__p0 == WRITE)) + { + write_expr(stack[frame_ptr]); + printf " "; + return NIL; + } + if ((__p0 == NEWLINE)) + { + printf "\n"; + return NIL; + } + if ((__p0 == READ)) + return read(); + if ((__p0 == RANDOM)) + return make_number(int((rand() * numeric_value(stack[frame_ptr])))); + if ((__p0 == GENSYM)) + return string_to_symbol(("#G" ++(gensym_counter))); + if ((__p0 == ERROR)) + { + printf "Error!\n"; + print_expr(listify_args()); + exit 1; + } + error("Unknown procedure type"); +} + +function error (__p0) +{ + print ("ERROR: " __p0) > "/dev/stderr"; + exit 1; +} + +function gc (__p0, __p1, __p2, __p3) +{ + if (loud_gc) + printf "\nGC..." > "/dev/stderr"; + mark(__p0); + mark(__p1); + for (__p2 in protected) + mark(protected[__p2]); + for (__p2 in stack) + mark(stack[__p2]); + for (__p2 in value) + mark(value[__p2]); + for (__p2 in property) + { + __p3 = index(SUBSEP,__p2); + mark(substr(__p2,1,(__p3 - 1))); + mark(substr(__p2,(__p3 + 1))); + mark(property[__p2]); + } + 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); + } +} + +function extend_env (__p0, __p1, __p2) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((__p1 == stack_ptr)) + error("Too many arguments to procedure"); + __p2 = value[car[__p0]]; + value[car[__p0]] = stack[__p1]; + stack[__p1] = __p2; + ++(__p1); + } + if ((__p1 != stack_ptr)) + error("Not enough arguments to procedure"); +} + +function is_atom (__p0) +{ + return ((__p0 % 4) != 1); +} + +function is_pair (__p0) +{ + return ((__p0 % 4) == 1); +} + +function eval (__p0, __p1) +{ + if (is_atom(__p0)) + if (is_symbol(__p0)) + { + if ((!((__p0 in value)))) + error(("Unbound variable: " printname[__p0])); + return value[__p0]; + } + else + return __p0; + op = car[__p0]; + if ((!((op in is_special)))) + { + __p1 = frame_ptr; + frame_ptr = stack_ptr; + eval_rands(cdr[__p0]); + protect(proc = eval(car[__p0])); + result = apply(proc); + unprotect(); + stack_ptr = frame_ptr; + frame_ptr = __p1; + return result; + } + if ((op == QUOTE)) + return car[cdr[__p0]]; + if ((op == LAMBDA)) + return __p0; + if ((op == IF)) + return ((eval(car[cdr[__p0]]) != NIL))?eval(car[cdr[cdr[__p0]]]):eval(car[cdr[cdr[cdr[__p0]]]]); + if ((op == PROGN)) + return progn(cdr[__p0]); + if ((op == SETQ)) + { + if ((!((car[cdr[__p0]] in value)))) + error(("Unbound variable: " printname[car[cdr[__p0]]])); + return value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + } + if ((op == WHILE)) + { + while ((eval(car[cdr[__p0]]) != NIL)) + progn(cdr[cdr[__p0]]); + return NIL; + } + if ((op == DEFINE)) + { + value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + return car[cdr[__p0]]; + } + error("BUG: Unknown special form"); +} + +function is (__p0, __p1) +{ + if (((__p1 % 4) != __p0)) + error(((("Expected a " type_name[__p0]) ", not a ") type_name[(__p1 % 4)])); + return __p1; +} + +function unwind_env (__p0, __p1) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((stack[__p1] == "")) + delete value[car[__p0]]; + else + value[car[__p0]] = stack[__p1]; + ++(__p1); + } +} + +function nreverse (__p0, __p1, __p2) +{ + while (is_pair(__p0)) + { + __p2 = cdr[__p0]; + cdr[__p0] = __p1; + __p1 = __p0; + __p0 = __p2; + } + if ((__p0 != NIL)) + error("Not a proper list - reverse!"); + return __p1; +} + +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 = ""; + else + error(("Lexical error starting at " line)); +} + +function do_apply (__p0, __p1, __p2) +{ + __p2 = frame_ptr; + frame_ptr = stack_ptr; + for (; is_pair(__p1); __p1 = cdr[__p1]) + stack[(stack_ptr)++] = car[__p1]; + if ((__p1 != NIL)) + error("Bad argument to APPLY: not a proper list"); + result = apply(__p0); + stack_ptr = frame_ptr; + frame_ptr = __p2; + return result; +} + +function unprotect () +{ + --(protected_ptr); +} + +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"; +} + +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; + 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"); +} + +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); + } +} + +-------------------------------------------------------------------------------- +[CMD] qseawk -d- -f lisp/awklisp lisp/startup lisp/scmhelp.lsp lisp/tail.lsp &1 +-------------------------------------------------------------------------------- +function eval_rands (__p0) +{ + for (; (__p0 != NIL); __p0 = cdr[__p0]) + stack[(stack_ptr)++] = eval(car[__p0]); +} + +function def_prim (__p0, __p1, __p2) +{ + __p2 = string_to_symbol(__p0); + value[__p2] = string_to_symbol(sprintf("#",__p0)); + if ((__p1 != "")) + num_params[value[__p2]] = __p1; + return value[__p2]; +} + +function is_symbol (__p0) +{ + return ((__p0 % 4) == 2); +} + +function is_number (__p0) +{ + return ((__p0 % 4) == 0); +} + +function read (__p0, __p1) +{ + skip_blanks(); + if ((token == eof)) + if (__p0) + error("Unexpected EOF"); + else + return THE_EOF_OBJECT; + if ((token == "(")) + { + advance(); + __p1 = NIL; + for (; ; ) + { + skip_blanks(); + if ((token == ".")) + { + advance(); + after_dot = read(1); + skip_blanks(); + if ((token != ")")) + error("')' expected"); + advance(); + return nreverse(__p1,after_dot); + } + else + if ((token == ")")) + { + advance(); + return nreverse(__p1,NIL); + } + else + { + protect(__p1); + __p1 = cons(read(1),__p1); + unprotect(); + } + } + } + else + if ((token == "'")) + { + advance(); + return cons(QUOTE,cons(read(1),NIL)); + } + else + if ((token ~ /^-?[0-9]+$/)) + { + __p1 = make_number(token); + advance(); + return __p1; + } + else + { + __p1 = string_to_symbol(token); + advance(); + return __p1; + } +} + +function protect (__p0) +{ + protected[++(protected_ptr)] = __p0; +} + +function mark (__p0) +{ + while ((is_pair(__p0) && (!((__p0 in marks))))) + { + marks[__p0] = 1; + mark(car[__p0]); + __p0 = cdr[__p0]; + } +} + +function write_expr (__p0) +{ + if (is_atom(__p0)) + { + if ((!(is_symbol(__p0)))) + printf ("%d",numeric_value(__p0)); + else + { + if ((!((__p0 in printname)))) + error((("BUG: " __p0) " has no printname")); + printf ("%s",printname[__p0]); + } + } + else + { + printf "("; + write_expr(car[__p0]); + for (__p0 = cdr[__p0]; is_pair(__p0); __p0 = cdr[__p0]) + { + printf " "; + write_expr(car[__p0]); + } + if ((__p0 != NIL)) + { + printf " . "; + write_expr(__p0); + } + printf ")"; + } +} + +function make_number (__p0) +{ + return (__p0 * 4); +} + +function print_expr (__p0) +{ + write_expr(__p0); + print ""; +} + +function progn (__p0) +{ + for (; (cdr[__p0] != NIL); __p0 = cdr[__p0]) + eval(car[__p0]); + return eval(car[__p0]); +} + +function string_to_symbol (__p0) +{ + if ((__p0 in intern)) + return intern[__p0]; + symbol_ptr += 4; + intern[__p0] = symbol_ptr; + printname[symbol_ptr] = __p0; + return symbol_ptr; +} + +function cons (__p0, __p1) +{ + while ((pair_ptr in marks)) + { + delete marks[pair_ptr]; + pair_ptr += 4; + } + if ((pair_ptr == pair_limit)) + gc(__p0,__p1); + car[pair_ptr] = __p0; + cdr[pair_ptr] = __p1; + pair_ptr += 4; + return (pair_ptr - 4); +} + +function listify_args (__p0, __p1) +{ + __p1 = NIL; + for (__p0 = (stack_ptr - 1); (frame_ptr <= __p0); --(__p0)) + __p1 = cons(stack[__p0],__p1); + return __p1; +} + +function numeric_value (__p0) +{ + if (((__p0 % 4) != 0)) + error("Not a number"); + return (__p0 / 4); +} + +function skip_blanks () +{ + while ((token ~ /^[ ]*$/)) + advance(); +} + +function apply (__p0) +{ + if (profiling) + ++(call_count[__p0]); + if ((car[__p0] == LAMBDA)) + { + extend_env(car[cdr[__p0]]); + result = progn(cdr[cdr[__p0]]); + unwind_env(car[cdr[__p0]]); + return result; + } + if (((__p0 in num_params) && (num_params[__p0] != (stack_ptr - frame_ptr)))) + error(("Wrong number of arguments to " printname[cdr[__p0]])); + if ((__p0 == CAR)) + return car[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CDR)) + return cdr[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CONS)) + return cons(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == NULL)) + return ((stack[frame_ptr] == NIL))?T:NIL; + if ((__p0 == EQ)) + return ((stack[frame_ptr] == stack[(frame_ptr + 1)]))?T:NIL; + if ((__p0 == ATOMP)) + return (is_atom(stack[frame_ptr]))?T:NIL; + if ((__p0 == ADD)) + return (is(a_number,stack[frame_ptr]) + is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == SUB)) + return (is(a_number,stack[frame_ptr]) - is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == MUL)) + return make_number((numeric_value(stack[frame_ptr]) * numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == DIV)) + return make_number(int((numeric_value(stack[frame_ptr]) / numeric_value(stack[(frame_ptr + 1)])))); + if ((__p0 == MOD)) + return make_number((numeric_value(stack[frame_ptr]) % numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == LT)) + return (((stack[frame_ptr] + 0) < (stack[(frame_ptr + 1)] + 0)))?T:NIL; + if ((__p0 == GET)) + return (((stack[frame_ptr],stack[(frame_ptr + 1)]) in property))?property[stack[frame_ptr],stack[(frame_ptr + 1)]]:NIL; + if ((__p0 == PUT)) + return property[stack[frame_ptr],stack[(frame_ptr + 1)]] = stack[(frame_ptr + 2)]; + if ((__p0 == CADR)) + return car[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == CDDR)) + return cdr[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == LIST)) + return listify_args(); + if ((__p0 == SYMBOLP)) + return (is_symbol(stack[frame_ptr]))?T:NIL; + if ((__p0 == PAIRP)) + return (is_pair(stack[frame_ptr]))?T:NIL; + if ((__p0 == NUMBERP)) + return (is_number(stack[frame_ptr]))?T:NIL; + if ((__p0 == SETCAR)) + return car[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == SETCDR)) + return cdr[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == APPLY)) + return do_apply(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == EVAL)) + return eval(stack[frame_ptr]); + if ((__p0 == NREV)) + return nreverse(stack[frame_ptr],NIL); + if ((__p0 == WRITE)) + { + write_expr(stack[frame_ptr]); + printf " "; + return NIL; + } + if ((__p0 == NEWLINE)) + { + printf "\n"; + return NIL; + } + if ((__p0 == READ)) + return read(); + if ((__p0 == RANDOM)) + return make_number(int((rand() * numeric_value(stack[frame_ptr])))); + if ((__p0 == GENSYM)) + return string_to_symbol(("#G" ++(gensym_counter))); + if ((__p0 == ERROR)) + { + printf "Error!\n"; + print_expr(listify_args()); + exit 1; + } + error("Unknown procedure type"); +} + +function error (__p0) +{ + print ("ERROR: " __p0) > "/dev/stderr"; + exit 1; +} + +function gc (__p0, __p1, __p2, __p3) +{ + if (loud_gc) + printf "\nGC..." > "/dev/stderr"; + mark(__p0); + mark(__p1); + for (__p2 in protected) + mark(protected[__p2]); + for (__p2 in stack) + mark(stack[__p2]); + for (__p2 in value) + mark(value[__p2]); + for (__p2 in property) + { + __p3 = index(SUBSEP,__p2); + mark(substr(__p2,1,(__p3 - 1))); + mark(substr(__p2,(__p3 + 1))); + mark(property[__p2]); + } + 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); + } +} + +function extend_env (__p0, __p1, __p2) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((__p1 == stack_ptr)) + error("Too many arguments to procedure"); + __p2 = value[car[__p0]]; + value[car[__p0]] = stack[__p1]; + stack[__p1] = __p2; + ++(__p1); + } + if ((__p1 != stack_ptr)) + error("Not enough arguments to procedure"); +} + +function is_atom (__p0) +{ + return ((__p0 % 4) != 1); +} + +function is_pair (__p0) +{ + return ((__p0 % 4) == 1); +} + +function eval (__p0, __p1) +{ + if (is_atom(__p0)) + if (is_symbol(__p0)) + { + if ((!((__p0 in value)))) + error(("Unbound variable: " printname[__p0])); + return value[__p0]; + } + else + return __p0; + op = car[__p0]; + if ((!((op in is_special)))) + { + __p1 = frame_ptr; + frame_ptr = stack_ptr; + eval_rands(cdr[__p0]); + protect(proc = eval(car[__p0])); + result = apply(proc); + unprotect(); + stack_ptr = frame_ptr; + frame_ptr = __p1; + return result; + } + if ((op == QUOTE)) + return car[cdr[__p0]]; + if ((op == LAMBDA)) + return __p0; + if ((op == IF)) + return ((eval(car[cdr[__p0]]) != NIL))?eval(car[cdr[cdr[__p0]]]):eval(car[cdr[cdr[cdr[__p0]]]]); + if ((op == PROGN)) + return progn(cdr[__p0]); + if ((op == SETQ)) + { + if ((!((car[cdr[__p0]] in value)))) + error(("Unbound variable: " printname[car[cdr[__p0]]])); + return value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + } + if ((op == WHILE)) + { + while ((eval(car[cdr[__p0]]) != NIL)) + progn(cdr[cdr[__p0]]); + return NIL; + } + if ((op == DEFINE)) + { + value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + return car[cdr[__p0]]; + } + error("BUG: Unknown special form"); +} + +function is (__p0, __p1) +{ + if (((__p1 % 4) != __p0)) + error(((("Expected a " type_name[__p0]) ", not a ") type_name[(__p1 % 4)])); + return __p1; +} + +function unwind_env (__p0, __p1) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((stack[__p1] == "")) + delete value[car[__p0]]; + else + value[car[__p0]] = stack[__p1]; + ++(__p1); + } +} + +function nreverse (__p0, __p1, __p2) +{ + while (is_pair(__p0)) + { + __p2 = cdr[__p0]; + cdr[__p0] = __p1; + __p1 = __p0; + __p0 = __p2; + } + if ((__p0 != NIL)) + error("Not a proper list - reverse!"); + return __p1; +} + +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 = ""; + else + error(("Lexical error starting at " line)); +} + +function do_apply (__p0, __p1, __p2) +{ + __p2 = frame_ptr; + frame_ptr = stack_ptr; + for (; is_pair(__p1); __p1 = cdr[__p1]) + stack[(stack_ptr)++] = car[__p1]; + if ((__p1 != NIL)) + error("Bad argument to APPLY: not a proper list"); + result = apply(__p0); + stack_ptr = frame_ptr; + frame_ptr = __p2; + return result; +} + +function unprotect () +{ + --(protected_ptr); +} + +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"; +} + +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; + 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"); +} + +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); + } +} + +-------------------------------------------------------------------------------- +[CMD] qseawk -d- -f lisp/awklisp lisp/startup lisp/scmhelp.lsp lisp/scheme.lsp &1 +-------------------------------------------------------------------------------- +function eval_rands (__p0) +{ + for (; (__p0 != NIL); __p0 = cdr[__p0]) + stack[(stack_ptr)++] = eval(car[__p0]); +} + +function def_prim (__p0, __p1, __p2) +{ + __p2 = string_to_symbol(__p0); + value[__p2] = string_to_symbol(sprintf("#",__p0)); + if ((__p1 != "")) + num_params[value[__p2]] = __p1; + return value[__p2]; +} + +function is_symbol (__p0) +{ + return ((__p0 % 4) == 2); +} + +function is_number (__p0) +{ + return ((__p0 % 4) == 0); +} + +function read (__p0, __p1) +{ + skip_blanks(); + if ((token == eof)) + if (__p0) + error("Unexpected EOF"); + else + return THE_EOF_OBJECT; + if ((token == "(")) + { + advance(); + __p1 = NIL; + for (; ; ) + { + skip_blanks(); + if ((token == ".")) + { + advance(); + after_dot = read(1); + skip_blanks(); + if ((token != ")")) + error("')' expected"); + advance(); + return nreverse(__p1,after_dot); + } + else + if ((token == ")")) + { + advance(); + return nreverse(__p1,NIL); + } + else + { + protect(__p1); + __p1 = cons(read(1),__p1); + unprotect(); + } + } + } + else + if ((token == "'")) + { + advance(); + return cons(QUOTE,cons(read(1),NIL)); + } + else + if ((token ~ /^-?[0-9]+$/)) + { + __p1 = make_number(token); + advance(); + return __p1; + } + else + { + __p1 = string_to_symbol(token); + advance(); + return __p1; + } +} + +function protect (__p0) +{ + protected[++(protected_ptr)] = __p0; +} + +function mark (__p0) +{ + while ((is_pair(__p0) && (!((__p0 in marks))))) + { + marks[__p0] = 1; + mark(car[__p0]); + __p0 = cdr[__p0]; + } +} + +function write_expr (__p0) +{ + if (is_atom(__p0)) + { + if ((!(is_symbol(__p0)))) + printf ("%d",numeric_value(__p0)); + else + { + if ((!((__p0 in printname)))) + error((("BUG: " __p0) " has no printname")); + printf ("%s",printname[__p0]); + } + } + else + { + printf "("; + write_expr(car[__p0]); + for (__p0 = cdr[__p0]; is_pair(__p0); __p0 = cdr[__p0]) + { + printf " "; + write_expr(car[__p0]); + } + if ((__p0 != NIL)) + { + printf " . "; + write_expr(__p0); + } + printf ")"; + } +} + +function make_number (__p0) +{ + return (__p0 * 4); +} + +function print_expr (__p0) +{ + write_expr(__p0); + print ""; +} + +function progn (__p0) +{ + for (; (cdr[__p0] != NIL); __p0 = cdr[__p0]) + eval(car[__p0]); + return eval(car[__p0]); +} + +function string_to_symbol (__p0) +{ + if ((__p0 in intern)) + return intern[__p0]; + symbol_ptr += 4; + intern[__p0] = symbol_ptr; + printname[symbol_ptr] = __p0; + return symbol_ptr; +} + +function cons (__p0, __p1) +{ + while ((pair_ptr in marks)) + { + delete marks[pair_ptr]; + pair_ptr += 4; + } + if ((pair_ptr == pair_limit)) + gc(__p0,__p1); + car[pair_ptr] = __p0; + cdr[pair_ptr] = __p1; + pair_ptr += 4; + return (pair_ptr - 4); +} + +function listify_args (__p0, __p1) +{ + __p1 = NIL; + for (__p0 = (stack_ptr - 1); (frame_ptr <= __p0); --(__p0)) + __p1 = cons(stack[__p0],__p1); + return __p1; +} + +function numeric_value (__p0) +{ + if (((__p0 % 4) != 0)) + error("Not a number"); + return (__p0 / 4); +} + +function skip_blanks () +{ + while ((token ~ /^[ ]*$/)) + advance(); +} + +function apply (__p0) +{ + if (profiling) + ++(call_count[__p0]); + if ((car[__p0] == LAMBDA)) + { + extend_env(car[cdr[__p0]]); + result = progn(cdr[cdr[__p0]]); + unwind_env(car[cdr[__p0]]); + return result; + } + if (((__p0 in num_params) && (num_params[__p0] != (stack_ptr - frame_ptr)))) + error(("Wrong number of arguments to " printname[cdr[__p0]])); + if ((__p0 == CAR)) + return car[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CDR)) + return cdr[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CONS)) + return cons(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == NULL)) + return ((stack[frame_ptr] == NIL))?T:NIL; + if ((__p0 == EQ)) + return ((stack[frame_ptr] == stack[(frame_ptr + 1)]))?T:NIL; + if ((__p0 == ATOMP)) + return (is_atom(stack[frame_ptr]))?T:NIL; + if ((__p0 == ADD)) + return (is(a_number,stack[frame_ptr]) + is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == SUB)) + return (is(a_number,stack[frame_ptr]) - is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == MUL)) + return make_number((numeric_value(stack[frame_ptr]) * numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == DIV)) + return make_number(int((numeric_value(stack[frame_ptr]) / numeric_value(stack[(frame_ptr + 1)])))); + if ((__p0 == MOD)) + return make_number((numeric_value(stack[frame_ptr]) % numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == LT)) + return (((stack[frame_ptr] + 0) < (stack[(frame_ptr + 1)] + 0)))?T:NIL; + if ((__p0 == GET)) + return (((stack[frame_ptr],stack[(frame_ptr + 1)]) in property))?property[stack[frame_ptr],stack[(frame_ptr + 1)]]:NIL; + if ((__p0 == PUT)) + return property[stack[frame_ptr],stack[(frame_ptr + 1)]] = stack[(frame_ptr + 2)]; + if ((__p0 == CADR)) + return car[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == CDDR)) + return cdr[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == LIST)) + return listify_args(); + if ((__p0 == SYMBOLP)) + return (is_symbol(stack[frame_ptr]))?T:NIL; + if ((__p0 == PAIRP)) + return (is_pair(stack[frame_ptr]))?T:NIL; + if ((__p0 == NUMBERP)) + return (is_number(stack[frame_ptr]))?T:NIL; + if ((__p0 == SETCAR)) + return car[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == SETCDR)) + return cdr[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == APPLY)) + return do_apply(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == EVAL)) + return eval(stack[frame_ptr]); + if ((__p0 == NREV)) + return nreverse(stack[frame_ptr],NIL); + if ((__p0 == WRITE)) + { + write_expr(stack[frame_ptr]); + printf " "; + return NIL; + } + if ((__p0 == NEWLINE)) + { + printf "\n"; + return NIL; + } + if ((__p0 == READ)) + return read(); + if ((__p0 == RANDOM)) + return make_number(int((rand() * numeric_value(stack[frame_ptr])))); + if ((__p0 == GENSYM)) + return string_to_symbol(("#G" ++(gensym_counter))); + if ((__p0 == ERROR)) + { + printf "Error!\n"; + print_expr(listify_args()); + exit 1; + } + error("Unknown procedure type"); +} + +function error (__p0) +{ + print ("ERROR: " __p0) > "/dev/stderr"; + exit 1; +} + +function gc (__p0, __p1, __p2, __p3) +{ + if (loud_gc) + printf "\nGC..." > "/dev/stderr"; + mark(__p0); + mark(__p1); + for (__p2 in protected) + mark(protected[__p2]); + for (__p2 in stack) + mark(stack[__p2]); + for (__p2 in value) + mark(value[__p2]); + for (__p2 in property) + { + __p3 = index(SUBSEP,__p2); + mark(substr(__p2,1,(__p3 - 1))); + mark(substr(__p2,(__p3 + 1))); + mark(property[__p2]); + } + 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); + } +} + +function extend_env (__p0, __p1, __p2) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((__p1 == stack_ptr)) + error("Too many arguments to procedure"); + __p2 = value[car[__p0]]; + value[car[__p0]] = stack[__p1]; + stack[__p1] = __p2; + ++(__p1); + } + if ((__p1 != stack_ptr)) + error("Not enough arguments to procedure"); +} + +function is_atom (__p0) +{ + return ((__p0 % 4) != 1); +} + +function is_pair (__p0) +{ + return ((__p0 % 4) == 1); +} + +function eval (__p0, __p1) +{ + if (is_atom(__p0)) + if (is_symbol(__p0)) + { + if ((!((__p0 in value)))) + error(("Unbound variable: " printname[__p0])); + return value[__p0]; + } + else + return __p0; + op = car[__p0]; + if ((!((op in is_special)))) + { + __p1 = frame_ptr; + frame_ptr = stack_ptr; + eval_rands(cdr[__p0]); + protect(proc = eval(car[__p0])); + result = apply(proc); + unprotect(); + stack_ptr = frame_ptr; + frame_ptr = __p1; + return result; + } + if ((op == QUOTE)) + return car[cdr[__p0]]; + if ((op == LAMBDA)) + return __p0; + if ((op == IF)) + return ((eval(car[cdr[__p0]]) != NIL))?eval(car[cdr[cdr[__p0]]]):eval(car[cdr[cdr[cdr[__p0]]]]); + if ((op == PROGN)) + return progn(cdr[__p0]); + if ((op == SETQ)) + { + if ((!((car[cdr[__p0]] in value)))) + error(("Unbound variable: " printname[car[cdr[__p0]]])); + return value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + } + if ((op == WHILE)) + { + while ((eval(car[cdr[__p0]]) != NIL)) + progn(cdr[cdr[__p0]]); + return NIL; + } + if ((op == DEFINE)) + { + value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + return car[cdr[__p0]]; + } + error("BUG: Unknown special form"); +} + +function is (__p0, __p1) +{ + if (((__p1 % 4) != __p0)) + error(((("Expected a " type_name[__p0]) ", not a ") type_name[(__p1 % 4)])); + return __p1; +} + +function unwind_env (__p0, __p1) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((stack[__p1] == "")) + delete value[car[__p0]]; + else + value[car[__p0]] = stack[__p1]; + ++(__p1); + } +} + +function nreverse (__p0, __p1, __p2) +{ + while (is_pair(__p0)) + { + __p2 = cdr[__p0]; + cdr[__p0] = __p1; + __p1 = __p0; + __p0 = __p2; + } + if ((__p0 != NIL)) + error("Not a proper list - reverse!"); + return __p1; +} + +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 = ""; + else + error(("Lexical error starting at " line)); +} + +function do_apply (__p0, __p1, __p2) +{ + __p2 = frame_ptr; + frame_ptr = stack_ptr; + for (; is_pair(__p1); __p1 = cdr[__p1]) + stack[(stack_ptr)++] = car[__p1]; + if ((__p1 != NIL)) + error("Bad argument to APPLY: not a proper list"); + result = apply(__p0); + stack_ptr = frame_ptr; + frame_ptr = __p2; + return result; +} + +function unprotect () +{ + --(protected_ptr); +} + +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"; +} + +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; + 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"); +} + +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); + } +} + diff --git a/qse/regress/awk/regress.out.xma b/qse/regress/awk/regress.out.xma index 77a09e68..aa7cf449 100644 --- a/qse/regress/awk/regress.out.xma +++ b/qse/regress/awk/regress.out.xma @@ -144,19 +144,19 @@ USA 3615 237 North America -------------------------------------------------------------------------------- [CMD] qseawk -m 500000 -f cou-019.awk cou.dat &1 -------------------------------------------------------------------------------- -cou.dat: USSR 8649 275 Asia -cou.dat: Canada 3852 25 North America -cou.dat: China 3705 1032 Asia -cou.dat: USA 3615 237 North America -cou.dat: Brazil 3286 134 South America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: USSR 8649 275 Asia +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: Canada 3852 25 North America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: China 3705 1032 Asia +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: USA 3615 237 North America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: Brazil 3286 134 South America -------------------------------------------------------------------------------- [CMD] qseawk -m 500000 -f cou-020.awk cou.dat &1 -------------------------------------------------------------------------------- -cou.dat: USSR 8649 275 Asia -cou.dat: Canada 3852 25 North America -cou.dat: China 3705 1032 Asia -cou.dat: USA 3615 237 North America -cou.dat: Brazil 3286 134 South America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: USSR 8649 275 Asia +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: Canada 3852 25 North America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: China 3705 1032 Asia +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: USA 3615 237 North America +/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk/cou.dat: Brazil 3286 134 South America -------------------------------------------------------------------------------- [CMD] qseawk -m 500000 -f cou-021.awk cou.dat &1 -------------------------------------------------------------------------------- @@ -413,7 +413,7 @@ Mark 5.00 20 Mary 5.5 22 Susie 4.25 18 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --strictnaming=off --newline=on -o- -f lang-001.awk &1 +[CMD] qseawk -m 500000 --strictnaming=off --newline=on -d- -f lang-001.awk &1 -------------------------------------------------------------------------------- function f (__p0) { @@ -426,7 +426,7 @@ BEGIN { hello -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-002.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-002.awk &1 -------------------------------------------------------------------------------- function f (__p0) { @@ -937,9 +937,9 @@ my hello my hello my hello my hello -ERROR: CODE 15 LINE 6 COLUMN 1 - block nested too deeply +ERROR: CODE 14 LINE 6 COLUMN 1 - block nested too deeply -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-003.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-003.awk &1 -------------------------------------------------------------------------------- function fn (__p0) { @@ -954,11 +954,11 @@ BEGIN { 50 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-004.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-004.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 42 LINE 3 COLUMN 9 - function 'a' redefined +ERROR: CODE 41 LINE 3 COLUMN 9 - function 'a' redefined -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --implicit=off --explicit=on --newline=on -o- -f lang-005.awk &1 +[CMD] qseawk -m 500000 --implicit=off --explicit=on --newline=on -d- -f lang-005.awk &1 -------------------------------------------------------------------------------- function a (__p0) { @@ -982,11 +982,11 @@ BEGIN { 50 100 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --implicit=off --explicit=on --newline=on -o- -f lang-006.awk &1 +[CMD] qseawk -m 500000 --implicit=off --explicit=on --newline=on -d- -f lang-006.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 43 LINE 5 COLUMN 10 - global variable 'a' redefined +ERROR: CODE 42 LINE 5 COLUMN 10 - global variable 'a' redefined -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --implicit=on --explicit=on --newline=on -o- -f lang-007.awk &1 +[CMD] qseawk -m 500000 --implicit=on --explicit=on --newline=on -d- -f lang-007.awk &1 -------------------------------------------------------------------------------- global __g17; @@ -1005,7 +1005,7 @@ BEGIN { 20 30 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --implicit=off --explicit=on --newline=on -o- -f lang-008.awk &1 +[CMD] qseawk -m 500000 --implicit=off --explicit=on --newline=on -d- -f lang-008.awk &1 -------------------------------------------------------------------------------- global x; @@ -1027,7 +1027,7 @@ BEGIN { 2 1 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --implicit=off --explicit=on --newline=on --strictnaming=off -o- -f lang-009.awk lang-009.awk &1 +[CMD] qseawk -m 500000 --implicit=off --explicit=on --newline=on --strictnaming=off -d- -f lang-009.awk lang-009.awk &1 -------------------------------------------------------------------------------- function a (__p0) { @@ -1044,7 +1044,7 @@ END { } 1000 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-010.awk this is just a test &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-010.awk this is just a test &1 -------------------------------------------------------------------------------- BEGIN { print "ARGC=",ARGC; @@ -1072,7 +1072,7 @@ BEGIN { if ((ARGC >= 0)) printf ("ARGC [%++#10.10f] is positive\n",10124.1123); printf ("[%d], [%f], [%s]\n",10124.1123,10124.1123,10124.1123); - printf ("[%-10c] [% 0*.*d]\n",65,45,48,(-(1))); + printf ("[%-10c] [% 0*.*d]\n",65,45,48,-1); print sprintf("abc%d %*.*d %c %s %c",10,20,30,40,"good","good",75.34); } @@ -1101,7 +1101,7 @@ ARGC [+10124.1123000000] is positive [A ] [-000000000000000000000000000000000000000000000001] abc10 000000000000000000000000000040 g good K -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-011.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-011.awk &1 -------------------------------------------------------------------------------- BEGIN { a[1,2,3] = 20; @@ -1144,10 +1144,10 @@ BEGIN { (1,2,3) in a ==> 20 (4,5) not in a -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-012.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-012.awk &1 -------------------------------------------------------------------------------- BEGIN { - OFS = " "; + OFS = "\t\t"; print "1==1 :",(1 == 1); print "1==0 :",(1 == 0); print "1.0==1 :",(1.0 == 1); @@ -1236,15 +1236,15 @@ BEGIN { print "\"10\" <= 10.1",("10" <= 10.1); print "\"10\" > 10.1",("10" > 10.1); print "\"10\" < 10.1",("10" < 10.1); - print (0.234 + 1.01123); + print 1.245230; print 12345678901234567890E20; print .123; - print (+(.123)); - print (-(.123)); + print 0.123000; + print -0.123000; print .123E-; - print (+(.123E-)); - print (-(.123E-)); - print ((-(.123E-)) + "123"); + print 0.123000; + print -0.123000; + print (-0.123000 + "123"); } 1==1 : 1 @@ -1345,31 +1345,31 @@ a < " " : 1 -0.123 122.877 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-013.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-013.awk &1 -------------------------------------------------------------------------------- BEGIN { CONVFMT = "%s"; printf ("%s\n",10.34); } -ERROR: CODE 103 LINE 3 COLUMN 2 - recursion detected in format conversion +ERROR: CODE 102 LINE 3 COLUMN 2 - recursion detected in format conversion -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-014.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-014.awk &1 -------------------------------------------------------------------------------- BEGIN { - a = (10 + 20); - b = (10 + 20); - c = (10 + 20); + a = 30; + b = 30; + c = 30; print a,b,c; } 30 30 30 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-015.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-015.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 15 LINE 3 COLUMN 50 - block nested too deeply +ERROR: CODE 14 LINE 3 COLUMN 50 - block nested too deeply -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-016.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-016.awk &1 -------------------------------------------------------------------------------- BEGIN { printf "[[[[[%s]]]]\n",sprintf("abc %s abc",sprintf("def %s %s",sprintf("%s %s %s","xyz",1.2342,"xyz"),sprintf("ttt %s tttt",123.12))); @@ -1379,7 +1379,7 @@ BEGIN { [[[[[abc def xyz 1.2342 xyz ttt 123.12 tttt abc]]]] [[[[ttt 123.12 tttt]]]] -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-017.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-017.awk &1 -------------------------------------------------------------------------------- function gety () { @@ -1430,7 +1430,7 @@ END { END OF PROGRAM END OF PROGRAM 2 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --call main --newline=on -o- -f lang-017.awk &1 +[CMD] qseawk -m 500000 --call main --newline=on -d- -f lang-017.awk &1 -------------------------------------------------------------------------------- function gety () { @@ -1479,50 +1479,63 @@ END { 0 2 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --explicit=on --newline=on -o- -f lang-018.awk &1 +[CMD] qseawk -m 500000 --explicit=on --newline=on -d- -f lang-018.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 47 LINE 1 COLUMN 8 - duplicate global variable 'ARGV' +ERROR: CODE 46 LINE 1 COLUMN 8 - duplicate global variable 'ARGV' -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --explicit=on --newline=on -o- -f lang-019.awk &1 +[CMD] qseawk -m 500000 --explicit=on --newline=on -d- -f lang-019.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 49 LINE 1 COLUMN 15 - '+' not a valid parameter name +ERROR: CODE 48 LINE 1 COLUMN 15 - '+' not a valid parameter name -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --explicit=on --newline=on -o- -f lang-020.awk &1 +[CMD] qseawk -m 500000 --explicit=on --newline=on -d- -f lang-020.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 50 LINE 1 COLUMN 8 - '+' not a valid variable name +ERROR: CODE 49 LINE 1 COLUMN 8 - '+' not a valid variable name -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --explicit=on --newline=on -o- -f lang-021.awk &1 +[CMD] qseawk -m 500000 --explicit=on --newline=on -d- -f lang-021.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 50 LINE 3 COLUMN 8 - '+' not a valid variable name +ERROR: CODE 49 LINE 3 COLUMN 8 - '+' not a valid variable name -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-022.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-022.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 23 LINE 2 COLUMN 9 - left parenthesis expected in place of '=' +ERROR: CODE 22 LINE 2 COLUMN 9 - left parenthesis expected in place of '=' -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --explicit=on --newline=on -o- -f lang-023.awk &1 +[CMD] qseawk -m 500000 --explicit=on --newline=on -d- -f lang-023.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 28 LINE 5 COLUMN 20 - colon expected in place of ';' +ERROR: CODE 27 LINE 5 COLUMN 20 - colon expected in place of ';' -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --explicit=on --newline=on -o- -f lang-024.awk &1 +[CMD] qseawk -m 500000 --explicit=on --newline=on -d- -f lang-024.awk &1 -------------------------------------------------------------------------------- BEGIN { local __l0; __l0 = 21; print ((__l0 > 20))?1:2; + c = ((__l0)++ ++(b)); + print __l0; + print b; + print c; + print (99 ++(c)); + x = (("he" "ll") "o"); + x >>= " world"; + print x; } 1 +22 +1 +211 +99212 +hello world -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-025.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-025.awk &1 -------------------------------------------------------------------------------- BEGIN { iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiix = 20; delete iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiix; } -ERROR: CODE 78 LINE 3 COLUMN 9 - variable 'iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiix' not deletable +ERROR: CODE 77 LINE 3 COLUMN 9 - variable 'iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiix' not deletable -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-026.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-026.awk &1 -------------------------------------------------------------------------------- BEGIN { abc[20] = "abc"; @@ -1532,46 +1545,46 @@ BEGIN { } abc -ERROR: CODE 86 LINE 4 COLUMN 2 - map 'abc' not assignable with a scalar +ERROR: CODE 85 LINE 4 COLUMN 2 - map 'abc' not assignable with a scalar -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-027.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-027.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 17 LINE 2 COLUMN 1 - invalid character '' +ERROR: CODE 16 LINE 2 COLUMN 1 - invalid character '' -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-028.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-028.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 41 LINE 2 COLUMN 10 - intrinsic function 'substr' redefined +ERROR: CODE 40 LINE 2 COLUMN 10 - intrinsic function 'substr' redefined -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --explicit=on --newline=on -o- -f lang-029.awk &1 +[CMD] qseawk -m 500000 --explicit=on --newline=on -d- -f lang-029.awk &1 -------------------------------------------------------------------------------- -ERROR: CODE 42 LINE 9 COLUMN 9 - function 'abc' redefined +ERROR: CODE 41 LINE 9 COLUMN 9 - function 'abc' redefined -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-030.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-030.awk &1 -------------------------------------------------------------------------------- BEGIN { - print (1 + 0); - print (0B11111111 + 0); - print (10 + 0); - print (0x10 + 0); - print (0b00000010 + 0); - print (0b + 0); - print (0x + 0); + print 1; + print 255; + print 10; + print 16; + print 2; + print 0; + print 0; print "-----------------------"; - print ((+(1)) + 0); - print ((+(0B11111111)) + 0); - print ((+(10)) + 0); - print ((+(0x10)) + 0); - print ((+(0b00000010)) + 0); - print ((+(0b)) + 0); - print ((+(0x)) + 0); + print 1; + print 255; + print 10; + print 16; + print 2; + print 0; + print 0; print "-----------------------"; - print ((-(1)) + 0); - print ((-(0B11111111)) + 0); - print ((-(10)) + 0); - print ((-(0x10)) + 0); - print ((-(0b00000010)) + 0); - print ((-(0b)) + 0); - print ((-(0x)) + 0); + print -1; + print -255; + print -10; + print -16; + print -2; + print 0; + print 0; } 1 @@ -1598,7 +1611,7 @@ BEGIN { 0 0 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-031.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-031.awk &1 -------------------------------------------------------------------------------- BEGIN { print match("hhhheeeo",/e+/); @@ -1632,7 +1645,7 @@ BEGIN { 0 -1 -------------------------- -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-032.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-032.awk &1 -------------------------------------------------------------------------------- BEGIN { a = 91; @@ -1654,19 +1667,55 @@ BEGIN { --------------------- 9210 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-033.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-033.awk &1 -------------------------------------------------------------------------------- BEGIN { - while ((("cat lang-033.awk" | getline x) > 0)) + while ((("cat /etc/passwd" | getline x) > 0)) print x; } -BEGIN { - while ("cat lang-033.awk" | getline x > 0) - print x -} +root:x:0:0:root:/root:/bin/bash +daemon:x:1:1:daemon:/usr/sbin:/bin/sh +bin:x:2:2:bin:/bin:/bin/sh +sys:x:3:3:sys:/dev:/bin/sh +sync:x:4:65534:sync:/bin:/bin/sync +games:x:5:60:games:/usr/games:/bin/sh +man:x:6:12:man:/var/cache/man:/bin/sh +lp:x:7:7:lp:/var/spool/lpd:/bin/sh +mail:x:8:8:mail:/var/mail:/bin/sh +news:x:9:9:news:/var/spool/news:/bin/sh +uucp:x:10:10:uucp:/var/spool/uucp:/bin/sh +proxy:x:13:13:proxy:/bin:/bin/sh +www-data:x:33:33:www-data:/var/www:/bin/sh +backup:x:34:34:backup:/var/backups:/bin/sh +list:x:38:38:Mailing List Manager:/var/list:/bin/sh +irc:x:39:39:ircd:/var/run/ircd:/bin/sh +gnats:x:41:41:Gnats Bug-Reporting System (admin):/var/lib/gnats:/bin/sh +nobody:x:65534:65534:nobody:/nonexistent:/bin/sh +libuuid:x:100:101::/var/lib/libuuid:/bin/sh +syslog:x:101:103::/home/syslog:/bin/false +messagebus:x:102:105::/var/run/dbus:/bin/false +avahi-autoipd:x:103:108:Avahi autoip daemon,,,:/var/lib/avahi-autoipd:/bin/false +avahi:x:104:109:Avahi mDNS daemon,,,:/var/run/avahi-daemon:/bin/false +couchdb:x:105:113:CouchDB Administrator,,,:/var/lib/couchdb:/bin/bash +usbmux:x:106:46:usbmux daemon,,,:/home/usbmux:/bin/false +speech-dispatcher:x:107:29:Speech Dispatcher,,,:/var/run/speech-dispatcher:/bin/sh +kernoops:x:108:65534:Kernel Oops Tracking Daemon,,,:/:/bin/false +pulse:x:109:114:PulseAudio daemon,,,:/var/run/pulse:/bin/false +rtkit:x:110:117:RealtimeKit,,,:/proc:/bin/false +saned:x:111:118::/home/saned:/bin/false +hplip:x:112:7:HPLIP system user,,,:/var/run/hplip:/bin/false +gdm:x:113:120:Gnome Display Manager:/var/lib/gdm:/bin/false +hyung-hwan:x:1000:1000:Hyung-Hwan Chung,,,:/home/hyung-hwan:/bin/bash +sshd:x:114:65534::/var/run/sshd:/usr/sbin/nologin +haldaemon:x:115:123:Hardware abstraction layer,,,:/var/run/hald:/bin/false +statd:x:116:65534::/var/lib/nfs:/bin/false +freerad:x:117:124::/etc/freeradius:/bin/false +lightdm:x:118:128:Light Display Manager:/var/lib/lightdm:/bin/false +colord:x:119:129:colord colour management daemon,,,:/var/lib/colord:/bin/false +uml-net:x:120:132::/home/uml-net:/bin/false -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on --rwpipe=on -o- -f lang-034.awk &1 +[CMD] qseawk -m 500000 --newline=on --rwpipe=on -d- -f lang-034.awk &1 -------------------------------------------------------------------------------- BEGIN { print "15" || "sort"; @@ -1687,7 +1736,7 @@ xx: 13 xx: 14 xx: 15 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -vdatafile=lang-035.dat1 -vgroupname=lang-035 -f lang-035.awk lang-035.dat2 &1 +[CMD] qseawk -m 500000 --newline=on -d- -vdatafile=lang-035.dat1 -vgroupname=lang-035 -f lang-035.awk lang-035.dat2 &1 -------------------------------------------------------------------------------- BEGIN { max_cid_vars = 100; @@ -1766,7 +1815,6 @@ lease 20.1.20.57 { next binding state free; hardware ethernet 00:13:5e:50:23:6b; info awk.groupname "lang-035"; - info awk.voice-no-0 "68599021"; option agent.circuit-id "BLM1500_AR3_ILAB ONT/9/1/1 /0.0"; option agent.unknown-9 0:0:0:c1:8:45:52:49:43:53:53:4f:4e; } @@ -1778,7 +1826,6 @@ lease 20.1.20.54 { next binding state free; hardware ethernet 00:13:5e:50:25:aa; info awk.groupname "lang-035"; - info awk.voice-no-0 "68599011"; option agent.circuit-id "BLM1500_AR3_ILAB ONT/9/1/2 /0.0"; option agent.unknown-9 0:0:0:c1:8:45:52:49:43:53:53:4f:4e; } @@ -1790,7 +1837,6 @@ lease 20.1.20.55 { next binding state free; hardware ethernet 00:13:5e:50:20:af; info awk.groupname "lang-035"; - info awk.voice-no-0 "68599012"; option agent.circuit-id "BLM1500_AR3_ILAB ONT/9/2/1 /0.0"; option agent.unknown-9 0:0:0:c1:8:45:52:49:43:53:53:4f:4e; } @@ -1802,7 +1848,6 @@ lease 20.1.20.56 { next binding state free; hardware ethernet 00:13:5e:50:20:29; info awk.groupname "lang-035"; - info awk.voice-no-0 "68599022"; option agent.circuit-id "BLM1500_AR3_ILAB ONT/9/2/2 /0.0"; option agent.unknown-9 0:0:0:c1:8:45:52:49:43:53:53:4f:4e; } @@ -1855,8 +1900,6 @@ lease 10.218.255.55 { hardware ethernet 00:1b:5b:9c:90:00; info awk.groupname "lang-035"; uid "\001\000\033[\234\220\000"; - info awk.voice-no-0 "68599019"; - info awk.voice-no-1 "68599014"; option agent.circuit-id "AR_Remote atm 1/1/03/12:2.100"; option agent.remote-id "22M-fast"; } @@ -1899,7 +1942,6 @@ lease 10.218.255.66 { hardware ethernet 00:1a:04:f9:e2:90; info awk.groupname "lang-035"; uid "\001\000\032\004\371\342\220"; - info awk.voice-no-0 "68599018"; option agent.circuit-id "AR_Remote atm 1/1/03/02:2.100"; option agent.remote-id "3play"; } @@ -1912,8 +1954,6 @@ lease 10.218.255.60 { hardware ethernet 00:1e:c7:fb:29:1d; info awk.groupname "lang-035"; uid "\001\000\036\307\373)\035"; - info awk.voice-no-0 "68599017"; - info awk.voice-no-1 "68599013"; option agent.circuit-id "AL_AM3_LAB atm 1/1/01/01:2.100"; option agent.remote-id "Testing DHCP"; } @@ -1931,7 +1971,7 @@ lease 10.218.255.151 { uid "\001\000\033[\234\220\000"; } -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-036.awk lang-036.dat &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-036.awk lang-036.dat &1 -------------------------------------------------------------------------------- { if (($0 ~ /^-+$/)) @@ -1963,7 +2003,7 @@ pq...r AAA2 kbs ddd dif cccc -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-037.awk lang-037.dat &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-037.awk lang-037.dat &1 -------------------------------------------------------------------------------- BEGIN { RS = "\n-+\n"; @@ -1991,7 +2031,7 @@ pq...r AAA2 kbs ddd dif cccc -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-038.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-038.awk &1 -------------------------------------------------------------------------------- BEGIN { xstr = "abcdefabcdefabcdef"; @@ -2020,7 +2060,7 @@ BEGIN { 7 abc 13 abc -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-039.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-039.awk &1 -------------------------------------------------------------------------------- BEGIN { print (length() 11); @@ -2030,7 +2070,7 @@ BEGIN { 011 2 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-040.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-040.awk &1 -------------------------------------------------------------------------------- BEGIN { for (x in y) @@ -2038,7 +2078,7 @@ BEGIN { } -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-041.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-041.awk &1 -------------------------------------------------------------------------------- BEGIN { abc = 20; @@ -2047,7 +2087,7 @@ BEGIN { 2010 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-042.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-042.awk &1 -------------------------------------------------------------------------------- BEGIN { print //; @@ -2087,10 +2127,10 @@ IGNORECASE= 1 1 1 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-043.awk lang-043.dat &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-043.awk lang-043.dat &1 -------------------------------------------------------------------------------- BEGIN { - RS = "[ \n\v\f\r ]*[\r\n]+[ \n\v\f\r ]*"; + RS = "[\t\n\v\f\r ]*[\r\n]+[\t\n\v\f\r ]*"; } { @@ -2101,7 +2141,7 @@ abcd dcba j -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-044.awk lang-044.dat &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-044.awk lang-044.dat &1 -------------------------------------------------------------------------------- BEGIN { RS = ""; @@ -2119,10 +2159,10 @@ this is the second second line] [ ttttt killer] -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -o- -f lang-045.awk &1 +[CMD] qseawk -m 500000 --newline=on -d- -f lang-045.awk &1 -------------------------------------------------------------------------------- BEGIN { - for (i = (-(10.0)); (i < 10.0); (i)++) + for (i = -10.000000; (i < 10.0); (i)++) { print sin(i); print cos(i); @@ -2296,7 +2336,7 @@ nan 8103.08 3 -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 --newline=on -F: -f columnate.awk ./passwd.dat &1 +[CMD] qseawk -m 500000 --newline=on -F: -f columnate.awk passwd.dat &1 -------------------------------------------------------------------------------- root x 0 0 root /root /bin/bash daemon x 1 1 daemon /usr/sbin /bin/sh @@ -2382,7 +2422,7 @@ Result Ra Rb Connect Error 1.E12 99X -------------------------------------------------------------------------------- -[CMD] qseawk -m 500000 -f quicksort2.awk quicksort2.dat &1 +[CMD] qseawk -m 500000 -vQSEAWK="/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/cmd/awk/qseawk" -vSCRIPT_PATH="/home/hyung-hwan/nfs.exports/workspace/qse/x86_64/linux-wchar-debug/../../src/regress/awk" -f quicksort2.awk quicksort2.dat &1 -------------------------------------------------------------------------------- 0.0000000000 0.11111111111111111111111111111 @@ -2416,7 +2456,7 @@ int main () printf ("hello, world\n"); return 0; } --------------------------------------------------------------------------------- + -------------------------------------------------------------------------------- [CMD] qseawk -m 500000 -f wordfreq.awk wordfreq.awk &1 -------------------------------------------------------------------------------- _ 2 @@ -2590,3 +2630,2295 @@ while true do sleep 20 done +-------------------------------------------------------------------------------- +[CMD] qseawk -m 500000 -d- -f lisp/awklisp lisp/startup lisp/fib.lsp &1 +-------------------------------------------------------------------------------- +function eval_rands (__p0) +{ + for (; (__p0 != NIL); __p0 = cdr[__p0]) + stack[(stack_ptr)++] = eval(car[__p0]); +} + +function def_prim (__p0, __p1, __p2) +{ + __p2 = string_to_symbol(__p0); + value[__p2] = string_to_symbol(sprintf("#",__p0)); + if ((__p1 != "")) + num_params[value[__p2]] = __p1; + return value[__p2]; +} + +function is_symbol (__p0) +{ + return ((__p0 % 4) == 2); +} + +function is_number (__p0) +{ + return ((__p0 % 4) == 0); +} + +function read (__p0, __p1) +{ + skip_blanks(); + if ((token == eof)) + if (__p0) + error("Unexpected EOF"); + else + return THE_EOF_OBJECT; + if ((token == "(")) + { + advance(); + __p1 = NIL; + for (; ; ) + { + skip_blanks(); + if ((token == ".")) + { + advance(); + after_dot = read(1); + skip_blanks(); + if ((token != ")")) + error("')' expected"); + advance(); + return nreverse(__p1,after_dot); + } + else + if ((token == ")")) + { + advance(); + return nreverse(__p1,NIL); + } + else + { + protect(__p1); + __p1 = cons(read(1),__p1); + unprotect(); + } + } + } + else + if ((token == "'")) + { + advance(); + return cons(QUOTE,cons(read(1),NIL)); + } + else + if ((token ~ /^-?[0-9]+$/)) + { + __p1 = make_number(token); + advance(); + return __p1; + } + else + { + __p1 = string_to_symbol(token); + advance(); + return __p1; + } +} + +function protect (__p0) +{ + protected[++(protected_ptr)] = __p0; +} + +function mark (__p0) +{ + while ((is_pair(__p0) && (!((__p0 in marks))))) + { + marks[__p0] = 1; + mark(car[__p0]); + __p0 = cdr[__p0]; + } +} + +function write_expr (__p0) +{ + if (is_atom(__p0)) + { + if ((!(is_symbol(__p0)))) + printf ("%d",numeric_value(__p0)); + else + { + if ((!((__p0 in printname)))) + error((("BUG: " __p0) " has no printname")); + printf ("%s",printname[__p0]); + } + } + else + { + printf "("; + write_expr(car[__p0]); + for (__p0 = cdr[__p0]; is_pair(__p0); __p0 = cdr[__p0]) + { + printf " "; + write_expr(car[__p0]); + } + if ((__p0 != NIL)) + { + printf " . "; + write_expr(__p0); + } + printf ")"; + } +} + +function make_number (__p0) +{ + return (__p0 * 4); +} + +function print_expr (__p0) +{ + write_expr(__p0); + print ""; +} + +function progn (__p0) +{ + for (; (cdr[__p0] != NIL); __p0 = cdr[__p0]) + eval(car[__p0]); + return eval(car[__p0]); +} + +function string_to_symbol (__p0) +{ + if ((__p0 in intern)) + return intern[__p0]; + symbol_ptr += 4; + intern[__p0] = symbol_ptr; + printname[symbol_ptr] = __p0; + return symbol_ptr; +} + +function cons (__p0, __p1) +{ + while ((pair_ptr in marks)) + { + delete marks[pair_ptr]; + pair_ptr += 4; + } + if ((pair_ptr == pair_limit)) + gc(__p0,__p1); + car[pair_ptr] = __p0; + cdr[pair_ptr] = __p1; + pair_ptr += 4; + return (pair_ptr - 4); +} + +function listify_args (__p0, __p1) +{ + __p1 = NIL; + for (__p0 = (stack_ptr - 1); (frame_ptr <= __p0); --(__p0)) + __p1 = cons(stack[__p0],__p1); + return __p1; +} + +function numeric_value (__p0) +{ + if (((__p0 % 4) != 0)) + error("Not a number"); + return (__p0 / 4); +} + +function skip_blanks () +{ + while ((token ~ /^[ ]*$/)) + advance(); +} + +function apply (__p0) +{ + if (profiling) + ++(call_count[__p0]); + if ((car[__p0] == LAMBDA)) + { + extend_env(car[cdr[__p0]]); + result = progn(cdr[cdr[__p0]]); + unwind_env(car[cdr[__p0]]); + return result; + } + if (((__p0 in num_params) && (num_params[__p0] != (stack_ptr - frame_ptr)))) + error(("Wrong number of arguments to " printname[cdr[__p0]])); + if ((__p0 == CAR)) + return car[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CDR)) + return cdr[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CONS)) + return cons(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == NULL)) + return ((stack[frame_ptr] == NIL))?T:NIL; + if ((__p0 == EQ)) + return ((stack[frame_ptr] == stack[(frame_ptr + 1)]))?T:NIL; + if ((__p0 == ATOMP)) + return (is_atom(stack[frame_ptr]))?T:NIL; + if ((__p0 == ADD)) + return (is(a_number,stack[frame_ptr]) + is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == SUB)) + return (is(a_number,stack[frame_ptr]) - is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == MUL)) + return make_number((numeric_value(stack[frame_ptr]) * numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == DIV)) + return make_number(int((numeric_value(stack[frame_ptr]) / numeric_value(stack[(frame_ptr + 1)])))); + if ((__p0 == MOD)) + return make_number((numeric_value(stack[frame_ptr]) % numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == LT)) + return (((stack[frame_ptr] + 0) < (stack[(frame_ptr + 1)] + 0)))?T:NIL; + if ((__p0 == GET)) + return (((stack[frame_ptr],stack[(frame_ptr + 1)]) in property))?property[stack[frame_ptr],stack[(frame_ptr + 1)]]:NIL; + if ((__p0 == PUT)) + return property[stack[frame_ptr],stack[(frame_ptr + 1)]] = stack[(frame_ptr + 2)]; + if ((__p0 == CADR)) + return car[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == CDDR)) + return cdr[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == LIST)) + return listify_args(); + if ((__p0 == SYMBOLP)) + return (is_symbol(stack[frame_ptr]))?T:NIL; + if ((__p0 == PAIRP)) + return (is_pair(stack[frame_ptr]))?T:NIL; + if ((__p0 == NUMBERP)) + return (is_number(stack[frame_ptr]))?T:NIL; + if ((__p0 == SETCAR)) + return car[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == SETCDR)) + return cdr[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == APPLY)) + return do_apply(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == EVAL)) + return eval(stack[frame_ptr]); + if ((__p0 == NREV)) + return nreverse(stack[frame_ptr],NIL); + if ((__p0 == WRITE)) + { + write_expr(stack[frame_ptr]); + printf " "; + return NIL; + } + if ((__p0 == NEWLINE)) + { + printf "\n"; + return NIL; + } + if ((__p0 == READ)) + return read(); + if ((__p0 == RANDOM)) + return make_number(int((rand() * numeric_value(stack[frame_ptr])))); + if ((__p0 == GENSYM)) + return string_to_symbol(("#G" ++(gensym_counter))); + if ((__p0 == ERROR)) + { + printf "Error!\n"; + print_expr(listify_args()); + exit 1; + } + error("Unknown procedure type"); +} + +function error (__p0) +{ + print ("ERROR: " __p0) > "/dev/stderr"; + exit 1; +} + +function gc (__p0, __p1, __p2, __p3) +{ + if (loud_gc) + printf "\nGC..." > "/dev/stderr"; + mark(__p0); + mark(__p1); + for (__p2 in protected) + mark(protected[__p2]); + for (__p2 in stack) + mark(stack[__p2]); + for (__p2 in value) + mark(value[__p2]); + for (__p2 in property) + { + __p3 = index(SUBSEP,__p2); + mark(substr(__p2,1,(__p3 - 1))); + mark(substr(__p2,(__p3 + 1))); + mark(property[__p2]); + } + 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); + } +} + +function extend_env (__p0, __p1, __p2) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((__p1 == stack_ptr)) + error("Too many arguments to procedure"); + __p2 = value[car[__p0]]; + value[car[__p0]] = stack[__p1]; + stack[__p1] = __p2; + ++(__p1); + } + if ((__p1 != stack_ptr)) + error("Not enough arguments to procedure"); +} + +function is_atom (__p0) +{ + return ((__p0 % 4) != 1); +} + +function is_pair (__p0) +{ + return ((__p0 % 4) == 1); +} + +function eval (__p0, __p1) +{ + if (is_atom(__p0)) + if (is_symbol(__p0)) + { + if ((!((__p0 in value)))) + error(("Unbound variable: " printname[__p0])); + return value[__p0]; + } + else + return __p0; + op = car[__p0]; + if ((!((op in is_special)))) + { + __p1 = frame_ptr; + frame_ptr = stack_ptr; + eval_rands(cdr[__p0]); + protect(proc = eval(car[__p0])); + result = apply(proc); + unprotect(); + stack_ptr = frame_ptr; + frame_ptr = __p1; + return result; + } + if ((op == QUOTE)) + return car[cdr[__p0]]; + if ((op == LAMBDA)) + return __p0; + if ((op == IF)) + return ((eval(car[cdr[__p0]]) != NIL))?eval(car[cdr[cdr[__p0]]]):eval(car[cdr[cdr[cdr[__p0]]]]); + if ((op == PROGN)) + return progn(cdr[__p0]); + if ((op == SETQ)) + { + if ((!((car[cdr[__p0]] in value)))) + error(("Unbound variable: " printname[car[cdr[__p0]]])); + return value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + } + if ((op == WHILE)) + { + while ((eval(car[cdr[__p0]]) != NIL)) + progn(cdr[cdr[__p0]]); + return NIL; + } + if ((op == DEFINE)) + { + value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + return car[cdr[__p0]]; + } + error("BUG: Unknown special form"); +} + +function is (__p0, __p1) +{ + if (((__p1 % 4) != __p0)) + error(((("Expected a " type_name[__p0]) ", not a ") type_name[(__p1 % 4)])); + return __p1; +} + +function unwind_env (__p0, __p1) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((stack[__p1] == "")) + delete value[car[__p0]]; + else + value[car[__p0]] = stack[__p1]; + ++(__p1); + } +} + +function nreverse (__p0, __p1, __p2) +{ + while (is_pair(__p0)) + { + __p2 = cdr[__p0]; + cdr[__p0] = __p1; + __p1 = __p0; + __p0 = __p2; + } + if ((__p0 != NIL)) + error("Not a proper list - reverse!"); + return __p1; +} + +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 = ""; + else + error(("Lexical error starting at " line)); +} + +function do_apply (__p0, __p1, __p2) +{ + __p2 = frame_ptr; + frame_ptr = stack_ptr; + for (; is_pair(__p1); __p1 = cdr[__p1]) + stack[(stack_ptr)++] = car[__p1]; + if ((__p1 != NIL)) + error("Bad argument to APPLY: not a proper list"); + result = apply(__p0); + stack_ptr = frame_ptr; + frame_ptr = __p2; + return result; +} + +function unprotect () +{ + --(protected_ptr); +} + +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"; +} + +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; + 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"); +} + +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); + } +} + +-------------------------------------------------------------------------------- +[CMD] qseawk -m 500000 -d- -f lisp/awklisp lisp/startup lisp/numbers lisp/numbers.dat &1 +-------------------------------------------------------------------------------- +function eval_rands (__p0) +{ + for (; (__p0 != NIL); __p0 = cdr[__p0]) + stack[(stack_ptr)++] = eval(car[__p0]); +} + +function def_prim (__p0, __p1, __p2) +{ + __p2 = string_to_symbol(__p0); + value[__p2] = string_to_symbol(sprintf("#",__p0)); + if ((__p1 != "")) + num_params[value[__p2]] = __p1; + return value[__p2]; +} + +function is_symbol (__p0) +{ + return ((__p0 % 4) == 2); +} + +function is_number (__p0) +{ + return ((__p0 % 4) == 0); +} + +function read (__p0, __p1) +{ + skip_blanks(); + if ((token == eof)) + if (__p0) + error("Unexpected EOF"); + else + return THE_EOF_OBJECT; + if ((token == "(")) + { + advance(); + __p1 = NIL; + for (; ; ) + { + skip_blanks(); + if ((token == ".")) + { + advance(); + after_dot = read(1); + skip_blanks(); + if ((token != ")")) + error("')' expected"); + advance(); + return nreverse(__p1,after_dot); + } + else + if ((token == ")")) + { + advance(); + return nreverse(__p1,NIL); + } + else + { + protect(__p1); + __p1 = cons(read(1),__p1); + unprotect(); + } + } + } + else + if ((token == "'")) + { + advance(); + return cons(QUOTE,cons(read(1),NIL)); + } + else + if ((token ~ /^-?[0-9]+$/)) + { + __p1 = make_number(token); + advance(); + return __p1; + } + else + { + __p1 = string_to_symbol(token); + advance(); + return __p1; + } +} + +function protect (__p0) +{ + protected[++(protected_ptr)] = __p0; +} + +function mark (__p0) +{ + while ((is_pair(__p0) && (!((__p0 in marks))))) + { + marks[__p0] = 1; + mark(car[__p0]); + __p0 = cdr[__p0]; + } +} + +function write_expr (__p0) +{ + if (is_atom(__p0)) + { + if ((!(is_symbol(__p0)))) + printf ("%d",numeric_value(__p0)); + else + { + if ((!((__p0 in printname)))) + error((("BUG: " __p0) " has no printname")); + printf ("%s",printname[__p0]); + } + } + else + { + printf "("; + write_expr(car[__p0]); + for (__p0 = cdr[__p0]; is_pair(__p0); __p0 = cdr[__p0]) + { + printf " "; + write_expr(car[__p0]); + } + if ((__p0 != NIL)) + { + printf " . "; + write_expr(__p0); + } + printf ")"; + } +} + +function make_number (__p0) +{ + return (__p0 * 4); +} + +function print_expr (__p0) +{ + write_expr(__p0); + print ""; +} + +function progn (__p0) +{ + for (; (cdr[__p0] != NIL); __p0 = cdr[__p0]) + eval(car[__p0]); + return eval(car[__p0]); +} + +function string_to_symbol (__p0) +{ + if ((__p0 in intern)) + return intern[__p0]; + symbol_ptr += 4; + intern[__p0] = symbol_ptr; + printname[symbol_ptr] = __p0; + return symbol_ptr; +} + +function cons (__p0, __p1) +{ + while ((pair_ptr in marks)) + { + delete marks[pair_ptr]; + pair_ptr += 4; + } + if ((pair_ptr == pair_limit)) + gc(__p0,__p1); + car[pair_ptr] = __p0; + cdr[pair_ptr] = __p1; + pair_ptr += 4; + return (pair_ptr - 4); +} + +function listify_args (__p0, __p1) +{ + __p1 = NIL; + for (__p0 = (stack_ptr - 1); (frame_ptr <= __p0); --(__p0)) + __p1 = cons(stack[__p0],__p1); + return __p1; +} + +function numeric_value (__p0) +{ + if (((__p0 % 4) != 0)) + error("Not a number"); + return (__p0 / 4); +} + +function skip_blanks () +{ + while ((token ~ /^[ ]*$/)) + advance(); +} + +function apply (__p0) +{ + if (profiling) + ++(call_count[__p0]); + if ((car[__p0] == LAMBDA)) + { + extend_env(car[cdr[__p0]]); + result = progn(cdr[cdr[__p0]]); + unwind_env(car[cdr[__p0]]); + return result; + } + if (((__p0 in num_params) && (num_params[__p0] != (stack_ptr - frame_ptr)))) + error(("Wrong number of arguments to " printname[cdr[__p0]])); + if ((__p0 == CAR)) + return car[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CDR)) + return cdr[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CONS)) + return cons(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == NULL)) + return ((stack[frame_ptr] == NIL))?T:NIL; + if ((__p0 == EQ)) + return ((stack[frame_ptr] == stack[(frame_ptr + 1)]))?T:NIL; + if ((__p0 == ATOMP)) + return (is_atom(stack[frame_ptr]))?T:NIL; + if ((__p0 == ADD)) + return (is(a_number,stack[frame_ptr]) + is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == SUB)) + return (is(a_number,stack[frame_ptr]) - is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == MUL)) + return make_number((numeric_value(stack[frame_ptr]) * numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == DIV)) + return make_number(int((numeric_value(stack[frame_ptr]) / numeric_value(stack[(frame_ptr + 1)])))); + if ((__p0 == MOD)) + return make_number((numeric_value(stack[frame_ptr]) % numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == LT)) + return (((stack[frame_ptr] + 0) < (stack[(frame_ptr + 1)] + 0)))?T:NIL; + if ((__p0 == GET)) + return (((stack[frame_ptr],stack[(frame_ptr + 1)]) in property))?property[stack[frame_ptr],stack[(frame_ptr + 1)]]:NIL; + if ((__p0 == PUT)) + return property[stack[frame_ptr],stack[(frame_ptr + 1)]] = stack[(frame_ptr + 2)]; + if ((__p0 == CADR)) + return car[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == CDDR)) + return cdr[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == LIST)) + return listify_args(); + if ((__p0 == SYMBOLP)) + return (is_symbol(stack[frame_ptr]))?T:NIL; + if ((__p0 == PAIRP)) + return (is_pair(stack[frame_ptr]))?T:NIL; + if ((__p0 == NUMBERP)) + return (is_number(stack[frame_ptr]))?T:NIL; + if ((__p0 == SETCAR)) + return car[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == SETCDR)) + return cdr[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == APPLY)) + return do_apply(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == EVAL)) + return eval(stack[frame_ptr]); + if ((__p0 == NREV)) + return nreverse(stack[frame_ptr],NIL); + if ((__p0 == WRITE)) + { + write_expr(stack[frame_ptr]); + printf " "; + return NIL; + } + if ((__p0 == NEWLINE)) + { + printf "\n"; + return NIL; + } + if ((__p0 == READ)) + return read(); + if ((__p0 == RANDOM)) + return make_number(int((rand() * numeric_value(stack[frame_ptr])))); + if ((__p0 == GENSYM)) + return string_to_symbol(("#G" ++(gensym_counter))); + if ((__p0 == ERROR)) + { + printf "Error!\n"; + print_expr(listify_args()); + exit 1; + } + error("Unknown procedure type"); +} + +function error (__p0) +{ + print ("ERROR: " __p0) > "/dev/stderr"; + exit 1; +} + +function gc (__p0, __p1, __p2, __p3) +{ + if (loud_gc) + printf "\nGC..." > "/dev/stderr"; + mark(__p0); + mark(__p1); + for (__p2 in protected) + mark(protected[__p2]); + for (__p2 in stack) + mark(stack[__p2]); + for (__p2 in value) + mark(value[__p2]); + for (__p2 in property) + { + __p3 = index(SUBSEP,__p2); + mark(substr(__p2,1,(__p3 - 1))); + mark(substr(__p2,(__p3 + 1))); + mark(property[__p2]); + } + 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); + } +} + +function extend_env (__p0, __p1, __p2) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((__p1 == stack_ptr)) + error("Too many arguments to procedure"); + __p2 = value[car[__p0]]; + value[car[__p0]] = stack[__p1]; + stack[__p1] = __p2; + ++(__p1); + } + if ((__p1 != stack_ptr)) + error("Not enough arguments to procedure"); +} + +function is_atom (__p0) +{ + return ((__p0 % 4) != 1); +} + +function is_pair (__p0) +{ + return ((__p0 % 4) == 1); +} + +function eval (__p0, __p1) +{ + if (is_atom(__p0)) + if (is_symbol(__p0)) + { + if ((!((__p0 in value)))) + error(("Unbound variable: " printname[__p0])); + return value[__p0]; + } + else + return __p0; + op = car[__p0]; + if ((!((op in is_special)))) + { + __p1 = frame_ptr; + frame_ptr = stack_ptr; + eval_rands(cdr[__p0]); + protect(proc = eval(car[__p0])); + result = apply(proc); + unprotect(); + stack_ptr = frame_ptr; + frame_ptr = __p1; + return result; + } + if ((op == QUOTE)) + return car[cdr[__p0]]; + if ((op == LAMBDA)) + return __p0; + if ((op == IF)) + return ((eval(car[cdr[__p0]]) != NIL))?eval(car[cdr[cdr[__p0]]]):eval(car[cdr[cdr[cdr[__p0]]]]); + if ((op == PROGN)) + return progn(cdr[__p0]); + if ((op == SETQ)) + { + if ((!((car[cdr[__p0]] in value)))) + error(("Unbound variable: " printname[car[cdr[__p0]]])); + return value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + } + if ((op == WHILE)) + { + while ((eval(car[cdr[__p0]]) != NIL)) + progn(cdr[cdr[__p0]]); + return NIL; + } + if ((op == DEFINE)) + { + value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + return car[cdr[__p0]]; + } + error("BUG: Unknown special form"); +} + +function is (__p0, __p1) +{ + if (((__p1 % 4) != __p0)) + error(((("Expected a " type_name[__p0]) ", not a ") type_name[(__p1 % 4)])); + return __p1; +} + +function unwind_env (__p0, __p1) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((stack[__p1] == "")) + delete value[car[__p0]]; + else + value[car[__p0]] = stack[__p1]; + ++(__p1); + } +} + +function nreverse (__p0, __p1, __p2) +{ + while (is_pair(__p0)) + { + __p2 = cdr[__p0]; + cdr[__p0] = __p1; + __p1 = __p0; + __p0 = __p2; + } + if ((__p0 != NIL)) + error("Not a proper list - reverse!"); + return __p1; +} + +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 = ""; + else + error(("Lexical error starting at " line)); +} + +function do_apply (__p0, __p1, __p2) +{ + __p2 = frame_ptr; + frame_ptr = stack_ptr; + for (; is_pair(__p1); __p1 = cdr[__p1]) + stack[(stack_ptr)++] = car[__p1]; + if ((__p1 != NIL)) + error("Bad argument to APPLY: not a proper list"); + result = apply(__p0); + stack_ptr = frame_ptr; + frame_ptr = __p2; + return result; +} + +function unprotect () +{ + --(protected_ptr); +} + +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"; +} + +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; + 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"); +} + +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); + } +} + +-------------------------------------------------------------------------------- +[CMD] qseawk -m 500000 -d- -f lisp/awklisp lisp/startup lisp/scmhelp.lsp lisp/tail.lsp &1 +-------------------------------------------------------------------------------- +function eval_rands (__p0) +{ + for (; (__p0 != NIL); __p0 = cdr[__p0]) + stack[(stack_ptr)++] = eval(car[__p0]); +} + +function def_prim (__p0, __p1, __p2) +{ + __p2 = string_to_symbol(__p0); + value[__p2] = string_to_symbol(sprintf("#",__p0)); + if ((__p1 != "")) + num_params[value[__p2]] = __p1; + return value[__p2]; +} + +function is_symbol (__p0) +{ + return ((__p0 % 4) == 2); +} + +function is_number (__p0) +{ + return ((__p0 % 4) == 0); +} + +function read (__p0, __p1) +{ + skip_blanks(); + if ((token == eof)) + if (__p0) + error("Unexpected EOF"); + else + return THE_EOF_OBJECT; + if ((token == "(")) + { + advance(); + __p1 = NIL; + for (; ; ) + { + skip_blanks(); + if ((token == ".")) + { + advance(); + after_dot = read(1); + skip_blanks(); + if ((token != ")")) + error("')' expected"); + advance(); + return nreverse(__p1,after_dot); + } + else + if ((token == ")")) + { + advance(); + return nreverse(__p1,NIL); + } + else + { + protect(__p1); + __p1 = cons(read(1),__p1); + unprotect(); + } + } + } + else + if ((token == "'")) + { + advance(); + return cons(QUOTE,cons(read(1),NIL)); + } + else + if ((token ~ /^-?[0-9]+$/)) + { + __p1 = make_number(token); + advance(); + return __p1; + } + else + { + __p1 = string_to_symbol(token); + advance(); + return __p1; + } +} + +function protect (__p0) +{ + protected[++(protected_ptr)] = __p0; +} + +function mark (__p0) +{ + while ((is_pair(__p0) && (!((__p0 in marks))))) + { + marks[__p0] = 1; + mark(car[__p0]); + __p0 = cdr[__p0]; + } +} + +function write_expr (__p0) +{ + if (is_atom(__p0)) + { + if ((!(is_symbol(__p0)))) + printf ("%d",numeric_value(__p0)); + else + { + if ((!((__p0 in printname)))) + error((("BUG: " __p0) " has no printname")); + printf ("%s",printname[__p0]); + } + } + else + { + printf "("; + write_expr(car[__p0]); + for (__p0 = cdr[__p0]; is_pair(__p0); __p0 = cdr[__p0]) + { + printf " "; + write_expr(car[__p0]); + } + if ((__p0 != NIL)) + { + printf " . "; + write_expr(__p0); + } + printf ")"; + } +} + +function make_number (__p0) +{ + return (__p0 * 4); +} + +function print_expr (__p0) +{ + write_expr(__p0); + print ""; +} + +function progn (__p0) +{ + for (; (cdr[__p0] != NIL); __p0 = cdr[__p0]) + eval(car[__p0]); + return eval(car[__p0]); +} + +function string_to_symbol (__p0) +{ + if ((__p0 in intern)) + return intern[__p0]; + symbol_ptr += 4; + intern[__p0] = symbol_ptr; + printname[symbol_ptr] = __p0; + return symbol_ptr; +} + +function cons (__p0, __p1) +{ + while ((pair_ptr in marks)) + { + delete marks[pair_ptr]; + pair_ptr += 4; + } + if ((pair_ptr == pair_limit)) + gc(__p0,__p1); + car[pair_ptr] = __p0; + cdr[pair_ptr] = __p1; + pair_ptr += 4; + return (pair_ptr - 4); +} + +function listify_args (__p0, __p1) +{ + __p1 = NIL; + for (__p0 = (stack_ptr - 1); (frame_ptr <= __p0); --(__p0)) + __p1 = cons(stack[__p0],__p1); + return __p1; +} + +function numeric_value (__p0) +{ + if (((__p0 % 4) != 0)) + error("Not a number"); + return (__p0 / 4); +} + +function skip_blanks () +{ + while ((token ~ /^[ ]*$/)) + advance(); +} + +function apply (__p0) +{ + if (profiling) + ++(call_count[__p0]); + if ((car[__p0] == LAMBDA)) + { + extend_env(car[cdr[__p0]]); + result = progn(cdr[cdr[__p0]]); + unwind_env(car[cdr[__p0]]); + return result; + } + if (((__p0 in num_params) && (num_params[__p0] != (stack_ptr - frame_ptr)))) + error(("Wrong number of arguments to " printname[cdr[__p0]])); + if ((__p0 == CAR)) + return car[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CDR)) + return cdr[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CONS)) + return cons(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == NULL)) + return ((stack[frame_ptr] == NIL))?T:NIL; + if ((__p0 == EQ)) + return ((stack[frame_ptr] == stack[(frame_ptr + 1)]))?T:NIL; + if ((__p0 == ATOMP)) + return (is_atom(stack[frame_ptr]))?T:NIL; + if ((__p0 == ADD)) + return (is(a_number,stack[frame_ptr]) + is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == SUB)) + return (is(a_number,stack[frame_ptr]) - is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == MUL)) + return make_number((numeric_value(stack[frame_ptr]) * numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == DIV)) + return make_number(int((numeric_value(stack[frame_ptr]) / numeric_value(stack[(frame_ptr + 1)])))); + if ((__p0 == MOD)) + return make_number((numeric_value(stack[frame_ptr]) % numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == LT)) + return (((stack[frame_ptr] + 0) < (stack[(frame_ptr + 1)] + 0)))?T:NIL; + if ((__p0 == GET)) + return (((stack[frame_ptr],stack[(frame_ptr + 1)]) in property))?property[stack[frame_ptr],stack[(frame_ptr + 1)]]:NIL; + if ((__p0 == PUT)) + return property[stack[frame_ptr],stack[(frame_ptr + 1)]] = stack[(frame_ptr + 2)]; + if ((__p0 == CADR)) + return car[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == CDDR)) + return cdr[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == LIST)) + return listify_args(); + if ((__p0 == SYMBOLP)) + return (is_symbol(stack[frame_ptr]))?T:NIL; + if ((__p0 == PAIRP)) + return (is_pair(stack[frame_ptr]))?T:NIL; + if ((__p0 == NUMBERP)) + return (is_number(stack[frame_ptr]))?T:NIL; + if ((__p0 == SETCAR)) + return car[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == SETCDR)) + return cdr[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == APPLY)) + return do_apply(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == EVAL)) + return eval(stack[frame_ptr]); + if ((__p0 == NREV)) + return nreverse(stack[frame_ptr],NIL); + if ((__p0 == WRITE)) + { + write_expr(stack[frame_ptr]); + printf " "; + return NIL; + } + if ((__p0 == NEWLINE)) + { + printf "\n"; + return NIL; + } + if ((__p0 == READ)) + return read(); + if ((__p0 == RANDOM)) + return make_number(int((rand() * numeric_value(stack[frame_ptr])))); + if ((__p0 == GENSYM)) + return string_to_symbol(("#G" ++(gensym_counter))); + if ((__p0 == ERROR)) + { + printf "Error!\n"; + print_expr(listify_args()); + exit 1; + } + error("Unknown procedure type"); +} + +function error (__p0) +{ + print ("ERROR: " __p0) > "/dev/stderr"; + exit 1; +} + +function gc (__p0, __p1, __p2, __p3) +{ + if (loud_gc) + printf "\nGC..." > "/dev/stderr"; + mark(__p0); + mark(__p1); + for (__p2 in protected) + mark(protected[__p2]); + for (__p2 in stack) + mark(stack[__p2]); + for (__p2 in value) + mark(value[__p2]); + for (__p2 in property) + { + __p3 = index(SUBSEP,__p2); + mark(substr(__p2,1,(__p3 - 1))); + mark(substr(__p2,(__p3 + 1))); + mark(property[__p2]); + } + 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); + } +} + +function extend_env (__p0, __p1, __p2) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((__p1 == stack_ptr)) + error("Too many arguments to procedure"); + __p2 = value[car[__p0]]; + value[car[__p0]] = stack[__p1]; + stack[__p1] = __p2; + ++(__p1); + } + if ((__p1 != stack_ptr)) + error("Not enough arguments to procedure"); +} + +function is_atom (__p0) +{ + return ((__p0 % 4) != 1); +} + +function is_pair (__p0) +{ + return ((__p0 % 4) == 1); +} + +function eval (__p0, __p1) +{ + if (is_atom(__p0)) + if (is_symbol(__p0)) + { + if ((!((__p0 in value)))) + error(("Unbound variable: " printname[__p0])); + return value[__p0]; + } + else + return __p0; + op = car[__p0]; + if ((!((op in is_special)))) + { + __p1 = frame_ptr; + frame_ptr = stack_ptr; + eval_rands(cdr[__p0]); + protect(proc = eval(car[__p0])); + result = apply(proc); + unprotect(); + stack_ptr = frame_ptr; + frame_ptr = __p1; + return result; + } + if ((op == QUOTE)) + return car[cdr[__p0]]; + if ((op == LAMBDA)) + return __p0; + if ((op == IF)) + return ((eval(car[cdr[__p0]]) != NIL))?eval(car[cdr[cdr[__p0]]]):eval(car[cdr[cdr[cdr[__p0]]]]); + if ((op == PROGN)) + return progn(cdr[__p0]); + if ((op == SETQ)) + { + if ((!((car[cdr[__p0]] in value)))) + error(("Unbound variable: " printname[car[cdr[__p0]]])); + return value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + } + if ((op == WHILE)) + { + while ((eval(car[cdr[__p0]]) != NIL)) + progn(cdr[cdr[__p0]]); + return NIL; + } + if ((op == DEFINE)) + { + value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + return car[cdr[__p0]]; + } + error("BUG: Unknown special form"); +} + +function is (__p0, __p1) +{ + if (((__p1 % 4) != __p0)) + error(((("Expected a " type_name[__p0]) ", not a ") type_name[(__p1 % 4)])); + return __p1; +} + +function unwind_env (__p0, __p1) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((stack[__p1] == "")) + delete value[car[__p0]]; + else + value[car[__p0]] = stack[__p1]; + ++(__p1); + } +} + +function nreverse (__p0, __p1, __p2) +{ + while (is_pair(__p0)) + { + __p2 = cdr[__p0]; + cdr[__p0] = __p1; + __p1 = __p0; + __p0 = __p2; + } + if ((__p0 != NIL)) + error("Not a proper list - reverse!"); + return __p1; +} + +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 = ""; + else + error(("Lexical error starting at " line)); +} + +function do_apply (__p0, __p1, __p2) +{ + __p2 = frame_ptr; + frame_ptr = stack_ptr; + for (; is_pair(__p1); __p1 = cdr[__p1]) + stack[(stack_ptr)++] = car[__p1]; + if ((__p1 != NIL)) + error("Bad argument to APPLY: not a proper list"); + result = apply(__p0); + stack_ptr = frame_ptr; + frame_ptr = __p2; + return result; +} + +function unprotect () +{ + --(protected_ptr); +} + +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"; +} + +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; + 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"); +} + +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); + } +} + +-------------------------------------------------------------------------------- +[CMD] qseawk -m 500000 -d- -f lisp/awklisp lisp/startup lisp/scmhelp.lsp lisp/scheme.lsp &1 +-------------------------------------------------------------------------------- +function eval_rands (__p0) +{ + for (; (__p0 != NIL); __p0 = cdr[__p0]) + stack[(stack_ptr)++] = eval(car[__p0]); +} + +function def_prim (__p0, __p1, __p2) +{ + __p2 = string_to_symbol(__p0); + value[__p2] = string_to_symbol(sprintf("#",__p0)); + if ((__p1 != "")) + num_params[value[__p2]] = __p1; + return value[__p2]; +} + +function is_symbol (__p0) +{ + return ((__p0 % 4) == 2); +} + +function is_number (__p0) +{ + return ((__p0 % 4) == 0); +} + +function read (__p0, __p1) +{ + skip_blanks(); + if ((token == eof)) + if (__p0) + error("Unexpected EOF"); + else + return THE_EOF_OBJECT; + if ((token == "(")) + { + advance(); + __p1 = NIL; + for (; ; ) + { + skip_blanks(); + if ((token == ".")) + { + advance(); + after_dot = read(1); + skip_blanks(); + if ((token != ")")) + error("')' expected"); + advance(); + return nreverse(__p1,after_dot); + } + else + if ((token == ")")) + { + advance(); + return nreverse(__p1,NIL); + } + else + { + protect(__p1); + __p1 = cons(read(1),__p1); + unprotect(); + } + } + } + else + if ((token == "'")) + { + advance(); + return cons(QUOTE,cons(read(1),NIL)); + } + else + if ((token ~ /^-?[0-9]+$/)) + { + __p1 = make_number(token); + advance(); + return __p1; + } + else + { + __p1 = string_to_symbol(token); + advance(); + return __p1; + } +} + +function protect (__p0) +{ + protected[++(protected_ptr)] = __p0; +} + +function mark (__p0) +{ + while ((is_pair(__p0) && (!((__p0 in marks))))) + { + marks[__p0] = 1; + mark(car[__p0]); + __p0 = cdr[__p0]; + } +} + +function write_expr (__p0) +{ + if (is_atom(__p0)) + { + if ((!(is_symbol(__p0)))) + printf ("%d",numeric_value(__p0)); + else + { + if ((!((__p0 in printname)))) + error((("BUG: " __p0) " has no printname")); + printf ("%s",printname[__p0]); + } + } + else + { + printf "("; + write_expr(car[__p0]); + for (__p0 = cdr[__p0]; is_pair(__p0); __p0 = cdr[__p0]) + { + printf " "; + write_expr(car[__p0]); + } + if ((__p0 != NIL)) + { + printf " . "; + write_expr(__p0); + } + printf ")"; + } +} + +function make_number (__p0) +{ + return (__p0 * 4); +} + +function print_expr (__p0) +{ + write_expr(__p0); + print ""; +} + +function progn (__p0) +{ + for (; (cdr[__p0] != NIL); __p0 = cdr[__p0]) + eval(car[__p0]); + return eval(car[__p0]); +} + +function string_to_symbol (__p0) +{ + if ((__p0 in intern)) + return intern[__p0]; + symbol_ptr += 4; + intern[__p0] = symbol_ptr; + printname[symbol_ptr] = __p0; + return symbol_ptr; +} + +function cons (__p0, __p1) +{ + while ((pair_ptr in marks)) + { + delete marks[pair_ptr]; + pair_ptr += 4; + } + if ((pair_ptr == pair_limit)) + gc(__p0,__p1); + car[pair_ptr] = __p0; + cdr[pair_ptr] = __p1; + pair_ptr += 4; + return (pair_ptr - 4); +} + +function listify_args (__p0, __p1) +{ + __p1 = NIL; + for (__p0 = (stack_ptr - 1); (frame_ptr <= __p0); --(__p0)) + __p1 = cons(stack[__p0],__p1); + return __p1; +} + +function numeric_value (__p0) +{ + if (((__p0 % 4) != 0)) + error("Not a number"); + return (__p0 / 4); +} + +function skip_blanks () +{ + while ((token ~ /^[ ]*$/)) + advance(); +} + +function apply (__p0) +{ + if (profiling) + ++(call_count[__p0]); + if ((car[__p0] == LAMBDA)) + { + extend_env(car[cdr[__p0]]); + result = progn(cdr[cdr[__p0]]); + unwind_env(car[cdr[__p0]]); + return result; + } + if (((__p0 in num_params) && (num_params[__p0] != (stack_ptr - frame_ptr)))) + error(("Wrong number of arguments to " printname[cdr[__p0]])); + if ((__p0 == CAR)) + return car[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CDR)) + return cdr[is(a_pair,stack[frame_ptr])]; + if ((__p0 == CONS)) + return cons(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == NULL)) + return ((stack[frame_ptr] == NIL))?T:NIL; + if ((__p0 == EQ)) + return ((stack[frame_ptr] == stack[(frame_ptr + 1)]))?T:NIL; + if ((__p0 == ATOMP)) + return (is_atom(stack[frame_ptr]))?T:NIL; + if ((__p0 == ADD)) + return (is(a_number,stack[frame_ptr]) + is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == SUB)) + return (is(a_number,stack[frame_ptr]) - is(a_number,stack[(frame_ptr + 1)])); + if ((__p0 == MUL)) + return make_number((numeric_value(stack[frame_ptr]) * numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == DIV)) + return make_number(int((numeric_value(stack[frame_ptr]) / numeric_value(stack[(frame_ptr + 1)])))); + if ((__p0 == MOD)) + return make_number((numeric_value(stack[frame_ptr]) % numeric_value(stack[(frame_ptr + 1)]))); + if ((__p0 == LT)) + return (((stack[frame_ptr] + 0) < (stack[(frame_ptr + 1)] + 0)))?T:NIL; + if ((__p0 == GET)) + return (((stack[frame_ptr],stack[(frame_ptr + 1)]) in property))?property[stack[frame_ptr],stack[(frame_ptr + 1)]]:NIL; + if ((__p0 == PUT)) + return property[stack[frame_ptr],stack[(frame_ptr + 1)]] = stack[(frame_ptr + 2)]; + if ((__p0 == CADR)) + return car[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == CDDR)) + return cdr[is(a_pair,cdr[is(a_pair,stack[frame_ptr])])]; + if ((__p0 == LIST)) + return listify_args(); + if ((__p0 == SYMBOLP)) + return (is_symbol(stack[frame_ptr]))?T:NIL; + if ((__p0 == PAIRP)) + return (is_pair(stack[frame_ptr]))?T:NIL; + if ((__p0 == NUMBERP)) + return (is_number(stack[frame_ptr]))?T:NIL; + if ((__p0 == SETCAR)) + return car[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == SETCDR)) + return cdr[is(a_pair,stack[frame_ptr])] = stack[(frame_ptr + 1)]; + if ((__p0 == APPLY)) + return do_apply(stack[frame_ptr],stack[(frame_ptr + 1)]); + if ((__p0 == EVAL)) + return eval(stack[frame_ptr]); + if ((__p0 == NREV)) + return nreverse(stack[frame_ptr],NIL); + if ((__p0 == WRITE)) + { + write_expr(stack[frame_ptr]); + printf " "; + return NIL; + } + if ((__p0 == NEWLINE)) + { + printf "\n"; + return NIL; + } + if ((__p0 == READ)) + return read(); + if ((__p0 == RANDOM)) + return make_number(int((rand() * numeric_value(stack[frame_ptr])))); + if ((__p0 == GENSYM)) + return string_to_symbol(("#G" ++(gensym_counter))); + if ((__p0 == ERROR)) + { + printf "Error!\n"; + print_expr(listify_args()); + exit 1; + } + error("Unknown procedure type"); +} + +function error (__p0) +{ + print ("ERROR: " __p0) > "/dev/stderr"; + exit 1; +} + +function gc (__p0, __p1, __p2, __p3) +{ + if (loud_gc) + printf "\nGC..." > "/dev/stderr"; + mark(__p0); + mark(__p1); + for (__p2 in protected) + mark(protected[__p2]); + for (__p2 in stack) + mark(stack[__p2]); + for (__p2 in value) + mark(value[__p2]); + for (__p2 in property) + { + __p3 = index(SUBSEP,__p2); + mark(substr(__p2,1,(__p3 - 1))); + mark(substr(__p2,(__p3 + 1))); + mark(property[__p2]); + } + 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); + } +} + +function extend_env (__p0, __p1, __p2) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((__p1 == stack_ptr)) + error("Too many arguments to procedure"); + __p2 = value[car[__p0]]; + value[car[__p0]] = stack[__p1]; + stack[__p1] = __p2; + ++(__p1); + } + if ((__p1 != stack_ptr)) + error("Not enough arguments to procedure"); +} + +function is_atom (__p0) +{ + return ((__p0 % 4) != 1); +} + +function is_pair (__p0) +{ + return ((__p0 % 4) == 1); +} + +function eval (__p0, __p1) +{ + if (is_atom(__p0)) + if (is_symbol(__p0)) + { + if ((!((__p0 in value)))) + error(("Unbound variable: " printname[__p0])); + return value[__p0]; + } + else + return __p0; + op = car[__p0]; + if ((!((op in is_special)))) + { + __p1 = frame_ptr; + frame_ptr = stack_ptr; + eval_rands(cdr[__p0]); + protect(proc = eval(car[__p0])); + result = apply(proc); + unprotect(); + stack_ptr = frame_ptr; + frame_ptr = __p1; + return result; + } + if ((op == QUOTE)) + return car[cdr[__p0]]; + if ((op == LAMBDA)) + return __p0; + if ((op == IF)) + return ((eval(car[cdr[__p0]]) != NIL))?eval(car[cdr[cdr[__p0]]]):eval(car[cdr[cdr[cdr[__p0]]]]); + if ((op == PROGN)) + return progn(cdr[__p0]); + if ((op == SETQ)) + { + if ((!((car[cdr[__p0]] in value)))) + error(("Unbound variable: " printname[car[cdr[__p0]]])); + return value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + } + if ((op == WHILE)) + { + while ((eval(car[cdr[__p0]]) != NIL)) + progn(cdr[cdr[__p0]]); + return NIL; + } + if ((op == DEFINE)) + { + value[car[cdr[__p0]]] = eval(car[cdr[cdr[__p0]]]); + return car[cdr[__p0]]; + } + error("BUG: Unknown special form"); +} + +function is (__p0, __p1) +{ + if (((__p1 % 4) != __p0)) + error(((("Expected a " type_name[__p0]) ", not a ") type_name[(__p1 % 4)])); + return __p1; +} + +function unwind_env (__p0, __p1) +{ + for (__p1 = frame_ptr; (__p0 != NIL); __p0 = cdr[__p0]) + { + if ((stack[__p1] == "")) + delete value[car[__p0]]; + else + value[car[__p0]] = stack[__p1]; + ++(__p1); + } +} + +function nreverse (__p0, __p1, __p2) +{ + while (is_pair(__p0)) + { + __p2 = cdr[__p0]; + cdr[__p0] = __p1; + __p1 = __p0; + __p0 = __p2; + } + if ((__p0 != NIL)) + error("Not a proper list - reverse!"); + return __p1; +} + +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 = ""; + else + error(("Lexical error starting at " line)); +} + +function do_apply (__p0, __p1, __p2) +{ + __p2 = frame_ptr; + frame_ptr = stack_ptr; + for (; is_pair(__p1); __p1 = cdr[__p1]) + stack[(stack_ptr)++] = car[__p1]; + if ((__p1 != NIL)) + error("Bad argument to APPLY: not a proper list"); + result = apply(__p0); + stack_ptr = frame_ptr; + frame_ptr = __p2; + return result; +} + +function unprotect () +{ + --(protected_ptr); +} + +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"; +} + +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; + 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"); +} + +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); + } +} + diff --git a/qse/regress/awk/regress.sh.in b/qse/regress/awk/regress.sh.in index 9d07749a..f2bca985 100755 --- a/qse/regress/awk/regress.sh.in +++ b/qse/regress/awk/regress.sh.in @@ -278,7 +278,7 @@ run_test() echo_so " You may execute 'diff ${base_outfile} ${outfile}.test' for more info." return 1 } - rm -f "${outfile}.test" + #rm -f "${outfile}.test" return 0 } diff --git a/qse/samples/awk/Makefile.am b/qse/samples/awk/Makefile.am index 6aed1cf7..82992d4b 100644 --- a/qse/samples/awk/Makefile.am +++ b/qse/samples/awk/Makefile.am @@ -5,7 +5,7 @@ AM_CPPFLAGS = \ -I$(top_srcdir)/include \ -I$(includedir) -bin_PROGRAMS = awk01 awk02 awk03 awk04 awk09 awk10 +bin_PROGRAMS = awk01 awk02 awk03 awk04 awk09 awk10 awk11 LDFLAGS = -L../../lib/awk -L../../lib/cmn LDADD = -lqseawk -lqsecmn $(LIBM) @@ -20,6 +20,7 @@ awk03_SOURCES = awk03.c awk04_SOURCES = awk04.c awk09_SOURCES = awk09.c awk10_SOURCES = awk10.c +awk11_SOURCES = awk11.c if ENABLE_CXX diff --git a/qse/samples/awk/Makefile.in b/qse/samples/awk/Makefile.in index 83dc8843..a387a8a1 100644 --- a/qse/samples/awk/Makefile.in +++ b/qse/samples/awk/Makefile.in @@ -35,7 +35,8 @@ POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ bin_PROGRAMS = awk01$(EXEEXT) awk02$(EXEEXT) awk03$(EXEEXT) \ - awk04$(EXEEXT) awk09$(EXEEXT) awk10$(EXEEXT) $(am__EXEEXT_1) + awk04$(EXEEXT) awk09$(EXEEXT) awk10$(EXEEXT) awk11$(EXEEXT) \ + $(am__EXEEXT_1) @WIN32_TRUE@am__append_1 = $(UNICOWS_LIBS) @ENABLE_CXX_TRUE@am__append_2 = awk05 awk06 awk07 awk08 subdir = samples/awk @@ -103,6 +104,10 @@ am_awk10_OBJECTS = awk10.$(OBJEXT) awk10_OBJECTS = $(am_awk10_OBJECTS) awk10_LDADD = $(LDADD) awk10_DEPENDENCIES = $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_2) +am_awk11_OBJECTS = awk11.$(OBJEXT) +awk11_OBJECTS = $(am_awk11_OBJECTS) +awk11_LDADD = $(LDADD) +awk11_DEPENDENCIES = $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_2) DEFAULT_INCLUDES = depcomp = $(SHELL) $(top_srcdir)/ac/depcomp am__depfiles_maybe = depfiles @@ -128,11 +133,12 @@ CXXLINK = $(LIBTOOL) --tag=CXX $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \ SOURCES = $(awk01_SOURCES) $(awk02_SOURCES) $(awk03_SOURCES) \ $(awk04_SOURCES) $(awk05_SOURCES) $(awk06_SOURCES) \ $(awk07_SOURCES) $(awk08_SOURCES) $(awk09_SOURCES) \ - $(awk10_SOURCES) + $(awk10_SOURCES) $(awk11_SOURCES) DIST_SOURCES = $(awk01_SOURCES) $(awk02_SOURCES) $(awk03_SOURCES) \ $(awk04_SOURCES) $(am__awk05_SOURCES_DIST) \ $(am__awk06_SOURCES_DIST) $(am__awk07_SOURCES_DIST) \ - $(am__awk08_SOURCES_DIST) $(awk09_SOURCES) $(awk10_SOURCES) + $(am__awk08_SOURCES_DIST) $(awk09_SOURCES) $(awk10_SOURCES) \ + $(awk11_SOURCES) ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) @@ -295,6 +301,7 @@ awk03_SOURCES = awk03.c awk04_SOURCES = awk04.c awk09_SOURCES = awk09.c awk10_SOURCES = awk10.c +awk11_SOURCES = awk11.c @ENABLE_CXX_TRUE@CXXLIB = -lqseawkxx -lqsecmnxx @ENABLE_CXX_TRUE@awk05_SOURCES = awk05.cpp @ENABLE_CXX_TRUE@awk06_SOURCES = awk06.cpp @@ -411,6 +418,9 @@ awk09$(EXEEXT): $(awk09_OBJECTS) $(awk09_DEPENDENCIES) awk10$(EXEEXT): $(awk10_OBJECTS) $(awk10_DEPENDENCIES) @rm -f awk10$(EXEEXT) $(LINK) $(awk10_OBJECTS) $(awk10_LDADD) $(LIBS) +awk11$(EXEEXT): $(awk11_OBJECTS) $(awk11_DEPENDENCIES) + @rm -f awk11$(EXEEXT) + $(LINK) $(awk11_OBJECTS) $(awk11_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) @@ -428,6 +438,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/awk08.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/awk09.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/awk10.Po@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/awk11.Po@am__quote@ .c.o: @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< diff --git a/qse/samples/awk/awk11.c b/qse/samples/awk/awk11.c new file mode 100644 index 00000000..82e8da3c --- /dev/null +++ b/qse/samples/awk/awk11.c @@ -0,0 +1,128 @@ +/* + * $Id: awk01.c 441 2011-04-22 14:28:43Z hyunghwan.chung $ + * + Copyright 2006-2011 Chung, Hyung-Hwan. + This file is part of QSE. + + QSE is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as + published by the Free Software Foundation, either version 3 of + the License, or (at your option) any later version. + + QSE is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with QSE. If not, see . + */ + +#include +#include + +const qse_char_t* src = QSE_T("BEGIN { print \"hello, world\" | \"dir\"; }"); + +struct rtx_xtn_t +{ + qse_awk_rio_fun_t old_pipe_handler; +}; + +static qse_ssize_t new_pipe_handler ( + qse_awk_rtx_t* rtx, qse_awk_rio_cmd_t cmd, qse_awk_rio_arg_t* riod, + qse_char_t* data, qse_size_t size) +{ + struct rtx_xtn_t* xtn; + xtn = qse_awk_rtx_getxtnstd (rtx); + + if (cmd == QSE_AWK_RIO_OPEN) + qse_fprintf (QSE_STDERR, QSE_T("LOG: Executing [%s] for piping\n"), riod->name); + + return xtn->old_pipe_handler (rtx, cmd, riod, data, size); +} + +static void extend_pipe_handler (qse_awk_rtx_t* rtx) +{ + /* this function simply demonstrates how to extend + * runtime I/O handlers provided by qse_awk_rtx_openstd() */ + + struct rtx_xtn_t* xtn; + qse_awk_rio_t rio; + + xtn = qse_awk_rtx_getxtnstd (rtx); + + /* get the previous handler functions */ + qse_awk_rtx_getrio (rtx, &rio); + + /* remember the old pipe handler function */ + xtn->old_pipe_handler = rio.pipe; + + /* change the pipe handler to a new one */ + rio.pipe = new_pipe_handler; + + /* changes the handlers with a new set */ + qse_awk_rtx_setrio (rtx, &rio); +} + +int main () +{ + qse_awk_t* awk = QSE_NULL; + qse_awk_rtx_t* rtx = QSE_NULL; + qse_awk_val_t* retv; + qse_awk_parsestd_t psin; + int ret = -1; + + awk = qse_awk_openstd (0); + if (awk == QSE_NULL) + { + qse_fprintf (QSE_STDERR, QSE_T("ERROR: cannot open awk\n")); + goto oops; + } + + //qse_awk_setoption (awk, qse_awk_getoption(awk) | QSE_AWK_RWPIPE); + + psin.type = QSE_AWK_PARSESTD_STR; + psin.u.str.ptr = src; + psin.u.str.len = qse_strlen(src); + + if (qse_awk_parsestd (awk, &psin, QSE_NULL) <= -1) + { + qse_fprintf (QSE_STDERR, QSE_T("ERROR: %s\n"), + qse_awk_geterrmsg(awk)); + goto oops; + } + + rtx = qse_awk_rtx_openstd ( + awk, + QSE_SIZEOF(struct rtx_xtn_t), + QSE_T("awk11"), + QSE_NULL, /* stdin */ + QSE_NULL, /* stdout */ + QSE_NULL /* default cmgr */ + ); + if (rtx == QSE_NULL) + { + qse_fprintf (QSE_STDERR, QSE_T("ERROR: %s\n"), + qse_awk_geterrmsg(awk)); + goto oops; + } + + extend_pipe_handler (rtx); + + retv = qse_awk_rtx_loop (rtx); + if (retv == QSE_NULL) + { + qse_fprintf (QSE_STDERR, QSE_T("ERROR: %s\n"), + qse_awk_rtx_geterrmsg(rtx)); + goto oops; + } + + qse_awk_rtx_refdownval (rtx, retv); + ret = 0; + +oops: + if (rtx != QSE_NULL) qse_awk_rtx_close (rtx); + if (awk != QSE_NULL) qse_awk_close (awk); + return ret; +} +