conservatory
/
elk
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added $Id and copyright information to all .c files in lib/misc/ 

* Fixed old shitty K&R syntax.


git-svn-id: svn://svn.zoy.org/elk/trunk@65 55e467fa-43c5-0310-a8a2-de718669efc6
This commit is contained in:
sam 2003-09-01 17:06:43 +00:00
parent b13cf1d931
commit cd36edfd2a
9 changed files with 338 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
lib/misc/bitstring.c
View File

@ -1,3 +1,33 @@
/* bitstring.c
*
* $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/
#include <string.h> #include <string.h>
#include <stdlib.h> #include <stdlib.h>
@ -105,12 +135,12 @@ static Object P_Make_Bitstring(Object len, Object init) {
return ret; return ret;
} }
static Object P_Bitstring_Length(bs) Object bs; { static Object P_Bitstring_Length(Object bs) {
Check_Type(bs, T_Bitstring); Check_Type(bs, T_Bitstring);
return Make_Unsigned(BITSTRING(bs)->len); return Make_Unsigned(BITSTRING(bs)->len);
} }
static int Ulong_Size(ul) unsigned long ul; { static int Ulong_Size(unsigned long ul) {
int n; int n;
for (n = 0; ul; ul >>= 1, n++) for (n = 0; ul; ul >>= 1, n++)
@ -135,7 +165,7 @@ static Object Ulong_To_Bitstring(unsigned long ul, unsigned int len) {
return ret; return ret;
} }
static unsigned int Bigbits(b) struct S_Bignum *b; { static unsigned int Bigbits(struct S_Bignum *b) {
return b->usize ? (Ulong_Size((unsigned long)b->data[b->usize-1]) + return b->usize ? (Ulong_Size((unsigned long)b->data[b->usize-1]) +
(b->usize-1) * sizeof(gran_t) * 8) : 0; (b->usize-1) * sizeof(gran_t) * 8) : 0;
} }
@ -166,7 +196,7 @@ static Object Bignum_To_Bitstring(Object big, unsigned int len) {
return ret; return ret;
} }
static Object P_Int_To_Bitstring(len, i) Object len, i; { static Object P_Int_To_Bitstring(Object len, Object i) {
Object isneg; Object isneg;
int ilen; int ilen;
@ -181,7 +211,7 @@ static Object P_Int_To_Bitstring(len, i) Object len, i; {
return Bignum_To_Bitstring(i, (unsigned)ilen); return Bignum_To_Bitstring(i, (unsigned)ilen);
} }
static Object Bitstring_To_Bignum (bs) Object bs; { static Object Bitstring_To_Bignum (Object bs) {
struct S_Bitstring *b; struct S_Bitstring *b;
Object big; Object big;
int i, n, k; int i, n, k;
@ -204,7 +234,7 @@ static Object Bitstring_To_Bignum (bs) Object bs; {
return big; return big;
} }
static Object P_Bitstring_To_Int(bs) Object bs; { static Object P_Bitstring_To_Int(Object bs) {
struct S_Bitstring *b; struct S_Bitstring *b;
unsigned u = 0; unsigned u = 0;
int i; int i;
@ -220,7 +250,7 @@ static Object P_Bitstring_To_Int(bs) Object bs; {
return Make_Integer(u); return Make_Integer(u);
} }
static Object P_Bitstring_Ref(bs, inx) Object bs, inx; { static Object P_Bitstring_Ref(Object bs, Object inx) {
struct S_Bitstring *b; struct S_Bitstring *b;
int i; int i;
@ -232,7 +262,7 @@ static Object P_Bitstring_Ref(bs, inx) Object bs, inx; {
return b->data[i/8] & 1 << i % 8 ? True : False; return b->data[i/8] & 1 << i % 8 ? True : False;
} }
static Object P_Bitstring_Set(bs, inx, val) Object bs, inx, val; { static Object P_Bitstring_Set(Object bs, Object inx, Object val) {
int old, i, j, mask; int old, i, j, mask;
struct S_Bitstring *b; struct S_Bitstring *b;
@ -252,7 +282,7 @@ static Object P_Bitstring_Set(bs, inx, val) Object bs, inx, val; {
return old ? True : False; return old ? True : False;
} }
static Object P_Bitstring_Zerop(bs) Object bs; { static Object P_Bitstring_Zerop(Object bs) {
struct S_Bitstring *b; struct S_Bitstring *b;
int i; int i;
@ -263,14 +293,15 @@ static Object P_Bitstring_Zerop(bs) Object bs; {
return i < 0 ? True : False; return i < 0 ? True : False;
} }
static Object P_Bitstring_Fill(bs, fill) Object bs, fill; { static Object P_Bitstring_Fill(Object bs, Object fill) {
Check_Type(bs, T_Bitstring); Check_Type(bs, T_Bitstring);
Check_Type(fill, T_Boolean); Check_Type(fill, T_Boolean);
Fill_Bitstring(bs, Truep(fill)); Fill_Bitstring(bs, Truep(fill));
return Void; return Void;
} }
#define bitop(name, op) static void name(a, b) struct S_Bitstring *a, *b; {\ #define bitop(name, op) static void name(struct S_Bitstring *a,\
struct S_Bitstring *b) {\
int i, rem;\ int i, rem;\
\ \
if (a->len != b->len) {\ if (a->len != b->len) {\
@ -293,7 +324,7 @@ bitop(bor, |=)
bitop(bandnot, &= ~) bitop(bandnot, &= ~)
bitop(bxor, ^=) bitop(bxor, ^=)
static Object Bit_Operation(b1, b2, fun) Object b1, b2; void (*fun)(); { static Object Bit_Operation(Object b1, Object b2, void (*fun)()) {
struct S_Bitstring *a, *b; struct S_Bitstring *a, *b;
Check_Type(b1, T_Bitstring); Check_Type(b1, T_Bitstring);
@ -306,32 +337,32 @@ static Object Bit_Operation(b1, b2, fun) Object b1, b2; void (*fun)(); {
return Void; return Void;
} }
static Object P_Bitstring_Move(a, b) Object a, b; { static Object P_Bitstring_Move(Object a, Object b) {
return Bit_Operation(a, b, bmove); return Bit_Operation(a, b, bmove);
} }
static Object P_Bitstring_Not(a, b) Object a, b; { static Object P_Bitstring_Not(Object a, Object b) {
return Bit_Operation(a, b, bnot); return Bit_Operation(a, b, bnot);
} }
static Object P_Bitstring_And(a, b) Object a, b; { static Object P_Bitstring_And(Object a, Object b) {
return Bit_Operation(a, b, band); return Bit_Operation(a, b, band);
} }
static Object P_Bitstring_Or(a, b) Object a, b; { static Object P_Bitstring_Or(Object a, Object b) {
return Bit_Operation(a, b, bor); return Bit_Operation(a, b, bor);
} }
static Object P_Bitstring_Andnot(a, b) Object a, b; { static Object P_Bitstring_Andnot(Object a, Object b) {
return Bit_Operation(a, b, bandnot); return Bit_Operation(a, b, bandnot);
} }
static Object P_Bitstring_Xor(a, b) Object a, b; { static Object P_Bitstring_Xor(Object a, Object b) {
return Bit_Operation(a, b, bxor); return Bit_Operation(a, b, bxor);
} }
static Object P_Substring_Move(b1, from, to, b2, dst) static Object P_Substring_Move(Object b1, Object from, Object to,
Object b1, from, to, b2, dst; { Object b2, Object dst) {
struct S_Bitstring *a, *b; struct S_Bitstring *a, *b;
int start1, end1, start2, end2, len, off1, off2, i, j; int start1, end1, start2, end2, len, off1, off2, i, j;
unsigned char mask; unsigned char mask;
@ -480,7 +511,7 @@ static Object P_Substring_Move(b1, from, to, b2, dst)
} }
/*ARGSUSED*/ /*ARGSUSED*/
static Object Bitstring_Read(port, chr, konst) Object port; int chr, konst; { static Object Bitstring_Read(Object port, int chr, int konst) {
int c, str, i; int c, str, i;
FILE *f; FILE *f;
char buf[1024], *p = buf; char buf[1024], *p = buf;

32
lib/misc/debug.c
View File

@ -1,6 +1,36 @@
/* debug.c
*
* $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/
#include "scheme.h" #include "scheme.h"
static Object P_Debug (on) Object on; { static Object P_Debug (Object on) {
Check_Type (on, T_Boolean); Check_Type (on, T_Boolean);
GC_Debug = EQ(on, True); GC_Debug = EQ(on, True);
return Void; return Void;

34
lib/misc/elk-eval.c
View File

@ -1,3 +1,33 @@
/* elk-eval.c
*
* $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/
/* The function /* The function
* *
* char *Elk_Eval(char *expr); * char *Elk_Eval(char *expr);
@ -18,7 +48,7 @@
static Object in, out; static Object in, out;
static char *String_Eval(expr) char *expr; { static char *String_Eval(char *expr) {
Object str, res; Object str, res;
char *p; char *p;
GC_Node; GC_Node;
@ -40,7 +70,7 @@ static char *String_Eval(expr) char *expr; {
return buf; return buf;
} }
char *Elk_Eval(expr) char *expr; { char *Elk_Eval(char *expr) {
char *s; char *s;
s = String_Eval("\ s = String_Eval("\

57
lib/misc/gdbm.c
View File

@ -1,8 +1,35 @@
/* Elk/GDBM-interface. /* gdbm.c: Elk/GDBM-interface.
*
* Original version by Martin Stut <stut@informatik.tu-muenchen.dbp.de>. * Original version by Martin Stut <stut@informatik.tu-muenchen.dbp.de>.
* *
* Functions exported: * $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/
/* Functions exported:
* *
* (gdbm-file? obj) * (gdbm-file? obj)
* *
@ -99,7 +126,7 @@ struct S_gdbm_fh{
#define GDBM_FH(obj) ((struct S_gdbm_fh *)POINTER(obj)) #define GDBM_FH(obj) ((struct S_gdbm_fh *)POINTER(obj))
int Gdbm_fh_Equal (a, b) Object a, b; { int Gdbm_fh_Equal (Object a, Object b) {
return !GDBM_FH(a)->free && !GDBM_FH(b)->free && return !GDBM_FH(a)->free && !GDBM_FH(b)->free &&
GDBM_FH(a)->fptr == GDBM_FH(b)->fptr; GDBM_FH(a)->fptr == GDBM_FH(b)->fptr;
} }
@ -111,16 +138,16 @@ int Gdbm_fh_Print (fh, port, raw, depth, len) Object fh, port;
return 0; return 0;
} }
Object P_Gdbm_filep (x) Object x; { Object P_Gdbm_filep (Object x) {
return TYPE(x) == T_Gdbm_fh ? True : False; return TYPE(x) == T_Gdbm_fh ? True : False;
} }
static void Fatal_Func (s) char *s; { static void Fatal_Func (char *s) {
gdbm_error_message = s; gdbm_error_message = s;
fprintf (stderr, "gdbm error: %s\n", s); fprintf (stderr, "gdbm error: %s\n", s);
} }
Object P_Gdbm_Open (argc, argv) Object *argv; { Object P_Gdbm_Open (int argc, Object *argv) {
Object Gdbm_fh; Object Gdbm_fh;
GDBM_FILE dbf; GDBM_FILE dbf;
@ -140,13 +167,13 @@ Object P_Gdbm_Open (argc, argv) Object *argv; {
return Gdbm_fh; return Gdbm_fh;
} }
void Check_Fh (fh) Object fh; { void Check_Fh (Object fh) {
Check_Type (fh, T_Gdbm_fh); Check_Type (fh, T_Gdbm_fh);
if (GDBM_FH(fh)->free) if (GDBM_FH(fh)->free)
Primitive_Error ("invalid gdbm-file: ~s", fh); Primitive_Error ("invalid gdbm-file: ~s", fh);
} }
Object P_Gdbm_Close (fh) Object fh; { Object P_Gdbm_Close (Object fh) {
Check_Fh (fh); Check_Fh (fh);
GDBM_FH(fh)->free = 1; GDBM_FH(fh)->free = 1;
Disable_Interrupts; Disable_Interrupts;
@ -174,7 +201,7 @@ Object P_Gdbm_Store (fh, key, content, flag)
return Make_Integer (res); return Make_Integer (res);
} }
static Object Gdbm_Get (fh, key, func) Object fh, key; datum (*func)(); { static Object Gdbm_Get (Object fh, Object key, datum (*func)()) {
Object res; Object res;
datum k, c; datum k, c;
@ -192,15 +219,15 @@ static Object Gdbm_Get (fh, key, func) Object fh, key; datum (*func)(); {
return res; return res;
} }
Object P_Gdbm_Fetch (fh, key) Object fh, key; { Object P_Gdbm_Fetch (Object fh, Object key) {
return Gdbm_Get (fh, key, gdbm_fetch); return Gdbm_Get (fh, key, gdbm_fetch);
} }
Object P_Gdbm_Nextkey (fh, key) Object fh, key; { Object P_Gdbm_Nextkey (Object fh, Object key) {
return Gdbm_Get (fh, key, gdbm_nextkey); return Gdbm_Get (fh, key, gdbm_nextkey);
} }
Object P_Gdbm_Delete (fh, key) Object fh, key; { Object P_Gdbm_Delete (Object fh, Object key) {
int res; int res;
datum k; datum k;
@ -214,7 +241,7 @@ Object P_Gdbm_Delete (fh, key) Object fh, key; {
return res == 0 ? True : False; return res == 0 ? True : False;
} }
Object P_Gdbm_Firstkey (fh) Object fh; { Object P_Gdbm_Firstkey (Object fh) {
Object res; Object res;
datum k; datum k;
@ -229,7 +256,7 @@ Object P_Gdbm_Firstkey (fh) Object fh; {
return res; return res;
} }
Object P_Gdbm_Reorganize (fh) Object fh; { Object P_Gdbm_Reorganize (Object fh) {
Check_Fh (fh); Check_Fh (fh);
Disable_Interrupts; Disable_Interrupts;
gdbm_reorganize (GDBM_FH(fh)->fptr); gdbm_reorganize (GDBM_FH(fh)->fptr);

32
lib/misc/hack.c
View File

@ -1,6 +1,36 @@
/* hack.c
*
* $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/
#include "scheme.h" #include "scheme.h"
static Object P_Hack_Procedure_Environment (p, e) Object p, e; { static Object P_Hack_Procedure_Environment (Object p, Object e) {
Check_Type (p, T_Compound); Check_Type (p, T_Compound);
Check_Type (e, T_Environment); Check_Type (e, T_Environment);
COMPOUND(p)->env = e; COMPOUND(p)->env = e;

35
lib/misc/monitor.c
View File

@ -1,11 +1,38 @@
/* A trivial function to enable and disable execution profiling. /* monitor.c: A trivial function to enable and disable execution profiling.
* *
* Evaluate "(monitor #t)" to enable profiling; "(monitor #f)" to * Evaluate "(monitor #t)" to enable profiling; "(monitor #f)" to
* disable profiling and create a mon.out (this is done automatically * disable profiling and create a mon.out (this is done automatically
* on exit by means of an extension finalization function). * on exit by means of an extension finalization function).
* *
* $Id$
* *
* This extension may not work on some platforms. * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/
/* This extension may not work on some platforms.
* *
* On DECstations running Ultrix, you may have to evaluate * On DECstations running Ultrix, you may have to evaluate
* (set! load-libraries "/usr/lib/cmplrs/cc/libprof1_G0.a -lc_G0") * (set! load-libraries "/usr/lib/cmplrs/cc/libprof1_G0.a -lc_G0")
@ -30,9 +57,9 @@
#define MONSTART 2 #define MONSTART 2
static monitoring; static int monitoring;
static Object P_Monitor (on) Object on; { static Object P_Monitor (Object on) {
char *brk; char *brk;
extern char *sbrk(); extern char *sbrk();

51
lib/misc/record.c
View File

@ -1,3 +1,33 @@
/* record.c
*
* $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/
#include "scheme.h" #include "scheme.h"
#define RTD(x) ((struct S_Rtd *)POINTER(x)) #define RTD(x) ((struct S_Rtd *)POINTER(x))
@ -15,25 +45,25 @@ struct S_Record {
int T_Rtd, T_Record; int T_Rtd, T_Record;
static Object P_Rtdp (x) Object x; { static Object P_Rtdp (Object x) {
return TYPE(x) == T_Rtd ? True : False; return TYPE(x) == T_Rtd ? True : False;
} }
static Object P_Recordp (x) Object x; { static Object P_Recordp (Object x) {
return TYPE(x) == T_Record ? True : False; return TYPE(x) == T_Record ? True : False;
} }
static Object P_Rtd_Name (x) Object x; { static Object P_Rtd_Name (Object x) {
Check_Type (x, T_Rtd); Check_Type (x, T_Rtd);
return RTD(x)->name; return RTD(x)->name;
} }
static Object P_Rtd_Field_Names (x) Object x; { static Object P_Rtd_Field_Names (Object x) {
Check_Type (x, T_Rtd); Check_Type (x, T_Rtd);
return RTD(x)->fields; return RTD(x)->fields;
} }
static Object P_Make_Record_Type (name, fields) Object name, fields; { static Object P_Make_Record_Type (Object name, Object fields) {
Object s, ismem; Object s, ismem;
GC_Node2; GC_Node2;
@ -56,17 +86,17 @@ static Object P_Make_Record_Type (name, fields) Object name, fields; {
return s; return s;
} }
static Object P_Record_Type (x) Object x; { static Object P_Record_Type (Object x) {
Check_Type (x, T_Record); Check_Type (x, T_Record);
return RECORD(x)->rtd; return RECORD(x)->rtd;
} }
static Object P_Record_Values (x) Object x; { static Object P_Record_Values (Object x) {
Check_Type (x, T_Record); Check_Type (x, T_Record);
return RECORD(x)->values; return RECORD(x)->values;
} }
static Object P_Make_Record (rtd, values) Object rtd, values; { static Object P_Make_Record (Object rtd, Object values) {
Object s; Object s;
GC_Node2; GC_Node2;
@ -97,13 +127,14 @@ static int Record_Equal (Object a, Object b) {
Equal (RECORD(a)->values, RECORD(b)->values); Equal (RECORD(a)->values, RECORD(b)->values);
} }
static int Rtd_Print (x, port, raw, depth, length) Object x, port; { static int Rtd_Print (Object x, Object port, int raw, int depth, int length) {
struct S_String *s = STRING(RTD(x)->name); struct S_String *s = STRING(RTD(x)->name);
Printf (port, "#[%.*s-record-type %lu]", s->size, s->data, POINTER(x)); Printf (port, "#[%.*s-record-type %lu]", s->size, s->data, POINTER(x));
return 0; return 0;
} }
static int Record_Print (x, port, raw, depth, length) Object x, port; { static int Record_Print (Object x, Object port,
int raw, int depth, int length) {
struct S_String *s = STRING(RTD(RECORD(x)->rtd)->name); struct S_String *s = STRING(RTD(RECORD(x)->rtd)->name);
Printf (port, "#[%.*s-record-type %lu]", s->size, s->data, POINTER(x)); Printf (port, "#[%.*s-record-type %lu]", s->size, s->data, POINTER(x));
return 0; return 0;

35
lib/misc/regexp.c
View File

@ -1,8 +1,35 @@
/* The regular expression extension. It provides Scheme language /* regexp.c: The regular expression extension. It provides Scheme language
* bindings to the POSIX regcomp/regexec functions. * bindings to the POSIX regcomp/regexec functions.
* *
* Inspired by a GNU regular expression extension contributed by * Inspired by a GNU regular expression extension contributed by
* Stephen J. Bevan to an earlier version of Elk. * Stephen J. Bevan to an earlier version of Elk.
*
* $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/ */
#include "scheme.h" #include "scheme.h"
@ -45,11 +72,11 @@ static SYMDESCR Exec_Syms[] = {
{ 0, 0 } { 0, 0 }
}; };
static Object P_Regexpp(x) Object x; { static Object P_Regexpp(Object x) {
return TYPE(x) == T_Regexp ? True : False; return TYPE(x) == T_Regexp ? True : False;
} }
static Object P_Matchp(x) Object x; { static Object P_Matchp(Object x) {
return TYPE(x) == T_Match ? True : False; return TYPE(x) == T_Match ? True : False;
} }
@ -77,7 +104,7 @@ static int Match_Equal(Object a, Object b) {
return 1; return 1;
} }
static int Match_Size(m) Object m; { static int Match_Size(Object m) {
return sizeof(struct S_Match) + (MATCH(m)->num - 1) * sizeof(regmatch_t); return sizeof(struct S_Match) + (MATCH(m)->num - 1) * sizeof(regmatch_t);
} }

62
lib/misc/struct.c
View File

@ -1,6 +1,33 @@
/* The `structure' extension is obsolete and should not be used in /* struct.c: The `structure' extension is obsolete and should not be used
* applications any longer; it has been replaced by the more powerful * in applications any longer; it has been replaced by the more powerful
* `record' extension. * `record' extension.
*
* $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/ */
#include "scheme.h" #include "scheme.h"
@ -15,26 +42,26 @@ struct S_Struct {
int T_Struct; int T_Struct;
static Object P_Structurep (x) Object x; { static Object P_Structurep (Object x) {
return TYPE(x) == T_Struct ? True : False; return TYPE(x) == T_Struct ? True : False;
} }
static Object P_Structure_Name (x) Object x; { static Object P_Structure_Name (Object x) {
Check_Type (x, T_Struct); Check_Type (x, T_Struct);
return STRUCT(x)->name; return STRUCT(x)->name;
} }
static Object P_Structure_Slots (x) Object x; { static Object P_Structure_Slots (Object x) {
Check_Type (x, T_Struct); Check_Type (x, T_Struct);
return P_Vector_To_List (STRUCT(x)->slots); return P_Vector_To_List (STRUCT(x)->slots);
} }
static Object P_Structure_Values (x) Object x; { static Object P_Structure_Values (Object x) {
Check_Type (x, T_Struct); Check_Type (x, T_Struct);
return P_Vector_To_List (STRUCT(x)->values); return P_Vector_To_List (STRUCT(x)->values);
} }
static Check_Structure_Type (x, t) Object x, t; { static void Check_Structure_Type (Object x, Object t) {
Check_Type (x, T_Struct); Check_Type (x, T_Struct);
Check_Type (t, T_Symbol); Check_Type (t, T_Symbol);
if (!EQ(STRUCT(x)->name, t)) if (!EQ(STRUCT(x)->name, t))
@ -42,18 +69,18 @@ static Check_Structure_Type (x, t) Object x, t; {
STRUCT(x)->name, t); STRUCT(x)->name, t);
} }
static Object P_Structure_Ref (x, t, n) Object x, t, n; { static Object P_Structure_Ref (Object x, Object t, Object n) {
Check_Structure_Type (x, t); Check_Structure_Type (x, t);
return P_Vector_Ref (STRUCT(x)->values, n); return P_Vector_Ref (STRUCT(x)->values, n);
} }
static Object P_Structure_Set (x, t, n, obj) Object x, t, n, obj; { static Object P_Structure_Set (Object x, Object t, Object n, Object obj) {
Check_Structure_Type (x, t); Check_Structure_Type (x, t);
return P_Vector_Set (STRUCT(x)->values, n, obj); return P_Vector_Set (STRUCT(x)->values, n, obj);
} }
static Object P_Make_Structure (name, slots) Object name, slots; { static Object P_Make_Structure (Object name, Object slots) {
register n; register int n;
Object s, vec, *vp; Object s, vec, *vp;
GC_Node3; GC_Node3;
@ -77,23 +104,28 @@ static Object P_Make_Structure (name, slots) Object name, slots; {
return s; return s;
} }
static Structure_Eqv (a, b) Object a, b; { return EQ(a,b); } static int Structure_Eqv (Object a, Object b) {
return EQ(a,b);
}
static Structure_Equal (a, b) Object a, b; { static int Structure_Equal (Object a, Object b) {
return EQ(STRUCT(a)->name,STRUCT(b)->name) && return EQ(STRUCT(a)->name,STRUCT(b)->name) &&
Equal (STRUCT(a)->slots, STRUCT(b)->slots) && Equal (STRUCT(a)->slots, STRUCT(b)->slots) &&
Equal (STRUCT(a)->values, STRUCT(b)->values); Equal (STRUCT(a)->values, STRUCT(b)->values);
} }
static Structure_Print (x, port, raw, depth, length) Object x, port; { static int Structure_Print (Object x, Object port,
int raw, int depth, int length) {
struct S_String *s = STRING(SYMBOL(STRUCT(x)->name)->name); struct S_String *s = STRING(SYMBOL(STRUCT(x)->name)->name);
Printf (port, "#[%.*s-structure %lu]", s->size, s->data, POINTER(x)); Printf (port, "#[%.*s-structure %lu]", s->size, s->data, POINTER(x));
return 0;
} }
static Structure_Visit (sp, f) register Object *sp; register (*f)(); { static int Structure_Visit (register Object *sp, register int (*f)()) {
(*f)(&STRUCT(*sp)->name); (*f)(&STRUCT(*sp)->name);
(*f)(&STRUCT(*sp)->slots); (*f)(&STRUCT(*sp)->slots);
(*f)(&STRUCT(*sp)->values); (*f)(&STRUCT(*sp)->values);
return 0;
} }
void elk_init_lib_struct () { void elk_init_lib_struct () {