scm/ 0000775 0000000 0000000 00000000000 12456214340 010341 5 ustar root root scm/scm.h 0000755 0000000 0000000 00000125545 12434243653 011316 0 ustar root root /* "scm.h" SCM data types and external functions.
* Copyright (C) 1990-2006 Free Software Foundation, Inc.
*
* This program 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.
*
* This program 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 this program. If not, see
* .
*/
#ifdef __cplusplus
extern "C" {
#endif
#ifdef _WIN32
# include
#endif
#ifdef _WIN32_WCE
# include
#endif
#ifdef hpux
# ifndef __GNUC__
# define const /**/
# endif
#endif
#ifdef PLAN9
# include
# include
/* Simple imitation of some Unix system calls */
# define exit(val) exits("")
# define getcwd getwd
/* we have our own isatty */
int isatty (int);
#endif
typedef long SCM;
typedef struct {SCM car, cdr;} cell;
typedef struct {long sname;SCM (*cproc)();} subr;
typedef struct {long sname;double (*dproc)();} dsubr;
typedef struct {const char *string;SCM (*cproc)();} iproc;
typedef struct {const char *name;} subr_info;
#include
#include "scmfig.h"
#ifdef _WIN32
# ifdef SCM_WIN_DLL
# define SCM_DLL_EXPORT __declspec(dllexport)
# define SCM_EXPORT SCM_DLL_EXPORT
# else
# define SCM_DLL_EXPORT /**/
# define SCM_EXPORT extern
# endif
#else
# define SCM_DLL_EXPORT /**/
# define SCM_EXPORT extern
#endif
typedef struct {
sizet eltsize;
sizet len;
sizet alloclen;
sizet maxlen;
const char *what;
char *elts;} scm_gra;
#ifdef USE_ANSI_PROTOTYPES
# define P(s) s
#else
# define P(s) ()
#endif
#ifndef STDC_HEADERS
int isatty P((int));
#endif
typedef struct {
SCM (*mark)P((SCM));
sizet (*free)P((CELLPTR));
int (*print)P((SCM exp, SCM port, int writing));
SCM (*equalp)P((SCM, SCM));
} smobfuns;
typedef struct {
char *name;
SCM (*mark)P((SCM ptr));
int (*free)P((FILE *p));
int (*print)P((SCM exp, SCM port, int writing));
SCM (*equalp)P((SCM, SCM));
int (*fputc)P((int c, FILE *p));
int (*fputs)P((const char *s, FILE *p));
sizet (*fwrite)P((const void *s, sizet siz, sizet num, FILE *p));
int (*fflush)P((FILE *stream));
int (*fgetc)P((FILE *p));
int (*fclose)P((FILE *p));
int (*ungetc)P((int c, SCM p));
} ptobfuns;
typedef struct {
SCM data;
SCM port;
long flags;
long line;
int unread;
short col;
short colprev;
} port_info;
typedef struct {
SCM v;
sizet base;
} array;
typedef struct {
long lbnd;
long ubnd;
long inc;
} array_dim;
#ifdef FLOATS
typedef struct {char *string;double (*cproc)P((double));} dblproc;
# ifdef SINGLES
# ifdef CDR_DOUBLES
typedef struct {SCM type;double num;} flo;
# else
typedef struct {SCM type;float num;} flo;
# endif
# endif
typedef struct {SCM type;double *real;} dbl;
#endif
/* Conditionals should always expect immediates */
/* GCC __builtin_expect() is stubbed in scmfig.h */
#define IMP(x) SCM_EXPECT_TRUE(6 & PTR2INT(x))
#define NIMP(x) (!IMP(x))
#define INUMP(x) SCM_EXPECT_TRUE(2 & PTR2INT(x))
#define NINUMP(x) (!INUMP(x))
#define INUM0 ((SCM) 2)
#define ICHRP(x) ((0xff & PTR2INT(x))==0xf4)
#define ICHR(x) ((unsigned char)((x)>>8))
#define MAKICHR(x) (((x)<<8)+0xf4L)
#define ILOC00 (0x000000fcL)
#define ILOCP(n) ((0xff & PTR2INT(n))==PTR2INT(ILOC00))
#define MAKILOC(if, id) (ILOC00 + (((long)id)<<8) + (((long)if)<<16))
#define IDIST(n) ((PTR2INT(n)>>8) & 0x7f)
#define IFRAME(n) ((PTR2INT(n)>>16))
#define ICDRP(n) (ICDR & (n))
#define ICDR (1L<<15)
/* ISYMP tests for ISPCSYM and ISYM */
#define ISYMP(n) ((0x187 & PTR2INT(n))==4)
/* IFLAGP tests for ISPCSYM, ISYM and IFLAG */
#define IFLAGP(n) ((0x87 & PTR2INT(n))==4)
#define ISYMNUM(n) ((PTR2INT((n)>>9)) & 0x7f)
#define ISYMVAL(n) (PTR2INT((n)>>16))
#define MAKISYMVAL(isym, val) ((isym) | ((long)(val) <<16))
#define ISYMCHARS(n) (isymnames[ISYMNUM(n)])
#define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
#define MAKISYM(n) (((n)<<9)+0x74L)
#define MAKIFLAG(n) (((n)<<9)+0x174L)
/* This is to make the print representation of some evaluated code,
as in backtraces, make a little more sense. */
#define MAKSPCSYM2(work, look) ((127L & (work)) | ((127L<<9) & (look)))
SCM_EXPORT char *isymnames[];
#define NUM_ISPCSYM 14
#define IM_AND MAKSPCSYM(0)
#define IM_BEGIN MAKSPCSYM(1)
#define IM_CASE MAKSPCSYM(2)
#define IM_COND MAKSPCSYM(3)
#define IM_DO MAKSPCSYM(4)
#define IM_IF MAKSPCSYM(5)
#define IM_LAMBDA MAKSPCSYM(6)
#define IM_LET MAKSPCSYM(7)
#define IM_LETSTAR MAKSPCSYM(8)
#define IM_LETREC MAKSPCSYM(9)
#define IM_OR MAKSPCSYM(10)
#define IM_QUOTE MAKSPCSYM(11)
#define IM_SET MAKSPCSYM(12)
#define IM_FUNCALL MAKSPCSYM(13)
#define s_and (ISYMCHARS(IM_AND)+2)
#define s_begin (ISYMCHARS(IM_BEGIN)+2)
#define s_case (ISYMCHARS(IM_CASE)+2)
#define s_cond (ISYMCHARS(IM_COND)+2)
#define s_do (ISYMCHARS(IM_DO)+2)
#define s_if (ISYMCHARS(IM_IF)+2)
#define s_lambda (ISYMCHARS(IM_LAMBDA)+2)
#define s_let (ISYMCHARS(IM_LET)+2)
#define s_letstar (ISYMCHARS(IM_LETSTAR)+2)
#define s_letrec (ISYMCHARS(IM_LETREC)+2)
#define s_or (ISYMCHARS(IM_OR)+2)
#define s_quote (ISYMCHARS(IM_QUOTE)+2)
#define s_set (ISYMCHARS(IM_SET)+2)
#define s_define (ISYMCHARS(IM_DEFINE)+2)
#define s_delay (ISYMCHARS(IM_DELAY)+2)
#define s_quasiquote (ISYMCHARS(IM_QUASIQUOTE)+2)
#define s_let_syntax (ISYMCHARS(IM_LET_SYNTAX)+2)
SCM_EXPORT SCM i_dot, i_quote, i_quasiquote, i_unquote, i_uq_splicing;
#define s_apply (ISYMCHARS(IM_APPLY)+2)
/* each symbol defined here must have a unique number which
corresponds to it's position in isymnames[] in repl.c */
/* These are used for dispatch in eval.c */
#define IM_APPLY MAKISYM(14)
#define IM_FARLOC_CAR MAKISYM(15)
#define IM_FARLOC_CDR MAKISYM(16)
#define IM_DELAY MAKISYM(17)
#define IM_QUASIQUOTE MAKISYM(18)
#define IM_EVAL_FOR_APPLY MAKISYM(19)
#define IM_LET_SYNTAX MAKISYM(20)
#define IM_ACRO_CALL MAKISYM(21)
#define IM_LINUM MAKISYM(22)
#define IM_DEFINE MAKISYM(23)
#define IM_EVAL_VALUES MAKISYM(24)
/* These are not used for dispatch. */
#define IM_UNQUOTE MAKISYM(25)
#define IM_UQ_SPLICING MAKISYM(26)
#define IM_ELSE MAKISYM(27)
#define IM_ARROW MAKISYM(28)
#define IM_VALUES_TOKEN MAKISYM(29)
#define IM_KEYWORD MAKISYM(30)
#define NUM_ISYMS 31
#define SCM_MAKE_LINUM(n) (IM_LINUM | ((unsigned long)(n))<<16)
#define SCM_LINUM(x) ((unsigned long)(x)>>16)
#define SCM_LINUMP(x) ((0xffffL & (x))==IM_LINUM)
#define BOOL_F MAKIFLAG(NUM_ISYMS+0)
#define BOOL_T MAKIFLAG(NUM_ISYMS+1)
#define UNDEFINED MAKIFLAG(NUM_ISYMS+2)
#define EOF_VAL MAKIFLAG(NUM_ISYMS+3)
#ifdef SICP
# define EOL BOOL_F
#else
# define EOL MAKIFLAG(NUM_ISYMS+4)
#endif
#define UNSPECIFIED MAKIFLAG(NUM_ISYMS+5)
#define NUM_IFLAGS NUM_ISYMS+6
/* Now some unnamed flags used as magic cookies by scm_top_level. */
/* Argument n can range from -4 to 16 */
#ifdef SHORT_INT
# define COOKIE(n) (n)
# define UNCOOK(f) (f)
#else
# define COOKIE(n) MAKIFLAG(NUM_IFLAGS+4+n)
# define UNCOOK(f) (ISYMNUM(f)-(NUM_IFLAGS+4))
#endif
#define FALSEP(x) (BOOL_F==(x))
#define NFALSEP(x) (BOOL_F != (x))
/* BOOL_NOT returns the other boolean. The order of ^s here is
important for Borland C++. */
#define BOOL_NOT(x) ((x) ^ (BOOL_T ^ BOOL_F))
#define NULLP(x) (EOL==(x))
#define NNULLP(x) (EOL != (x))
#define UNBNDP(x) (UNDEFINED==(x))
#define CELLP(x) (!NCELLP(x))
#define NCELLP(x) ((sizeof(cell)-1) & PTR2INT(x))
#define GCMARKP(x) (1 & PTR2INT(CDR(x)))
#define GC8MARKP(x) (0x80 & PTR2INT(CAR(x)))
#define SETGCMARK(x) CDR(x) |= 1;
#define CLRGCMARK(x) CDR(x) &= ~1L;
#define SETGC8MARK(x) CAR(x) |= 0x80;
#define CLRGC8MARK(x) CAR(x) &= ~0x80L;
#define TYP3(x) (7 & PTR2INT(CAR(x)))
#define TYP7(x) (0x7f & PTR2INT(CAR(x)))
#define TYP7S(x) (0x7d & PTR2INT(CAR(x)))
#define TYP16(x) (0xffff & PTR2INT(CAR(x)))
#define TYP16S(x) (0xfeff & PTR2INT(CAR(x)))
#define GCTYP16(x) (0xff7f & PTR2INT(CAR(x)))
#define NCONSP(x) (1 & PTR2INT(CAR(x)))
#define CONSP(x) (!NCONSP(x))
#define ECONSP(x) (CONSP(x) || (1==TYP3(x)))
#define NECONSP(x) (NCONSP(x) && (1 != TYP3(x)))
#define SCM_GLOCP(x) (tc3_cons_gloc==(7 & PTR2INT(x)))
#define CAR(x) (((cell *)(SCM2PTR(x)))->car)
#define CDR(x) (((cell *)(SCM2PTR(x)))->cdr)
#define GCCDR(x) (~1L & CDR(x))
#define SETCDR(x, v) CDR(x) = (SCM)(v)
#ifdef _M_ARM
/* MS CLARM compiler bug workaround. */
volatile SCM MS_CLARM_dumy;
# define CODE(x) (MS_CLARM_dumy = (CAR(x)-tc3_closure))
#else
# define CODE(x) (CAR(x)-tc3_closure)
#endif
#define CLOSUREP(x) (TYP3(x)==tc3_closure)
#define SETCODE(x, e) CAR(x) = (e)+tc3_closure
#define ENV(x) ((~7L & CDR(x)) ? (~7L & CDR(x)) : EOL)
#define GCENV ENV
#define ARGC(x) ((6L & CDR(x))>>1)
#ifdef CAUTIOUS
# define SCM_ESTK_FRLEN 4
#else
# define SCM_ESTK_FRLEN 3
#endif
#define SCM_ESTK_BASE 4
#define SCM_ESTK_PARENT(v) (VELTS(v)[0])
#define SCM_ESTK_PARENT_WRITABLEP(v) (VELTS(v)[1])
#define SCM_ESTK_PARENT_INDEX(v) (VELTS(v)[2])
SCM_EXPORT long tc16_env, tc16_ident;
#define ENVP(x) (tc16_env==TYP16(x))
#define SCM_ENV_FORMALS CAR
#ifdef MACRO
# define M_IDENTP(x) (tc16_ident==TYP16(x))
# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x))
# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x))
# define IDENT_PARENT(x) (M_IDENT_LEXP(x) ? CAR(CDR(x)) : CDR(x))
# define IDENT_ENV(x) (M_IDENT_LEXP(x) ? CDR(CDR(x)) : BOOL_F)
#else
# define IDENTP SYMBOLP
# define M_IDENTP(x) (0)
#endif
/* markers for various static environment frame types */
/* FIXME these need to be exported somehow to Scheme */
#ifdef CAUTIOUS
# define SCM_ENV_FILENAME MAKINUM(1L)
# define SCM_ENV_PROCNAME MAKINUM(2L)
#endif
#define SCM_ENV_DOC MAKINUM(3L)
#define SCM_ENV_ANNOTATION MAKINUM(4L)
#define SCM_ENV_CONSTANT MAKINUM(5L)
#define SCM_ENV_SYNTAX MAKINUM(6L)
#define SCM_ENV_END MAKINUM(7L)
#define PORTP(x) (TYP7(x)==tc7_port)
#define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN))
#define OPINPORTP(x) (((0x7f | OPN | RDNG) & CAR(x))==(tc7_port | OPN | RDNG))
#define OPOUTPORTP(x) (((0x7f | OPN | WRTNG) & CAR(x))==(tc7_port | OPN | WRTNG))
#define OPIOPORTP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc7_port | OPN | RDNG | WRTNG))
#define FPORTP(x) (TYP16S(x)==tc7_port)
#define OPFPORTP(x) (((0xfeff | OPN) & CAR(x))==(tc7_port | OPN))
#define OPINFPORTP(x) (((0xfeff | OPN | RDNG) & CAR(x))==(tc7_port | OPN | RDNG))
#define OPOUTFPORTP(x) (((0xfeff | OPN | WRTNG) & CAR(x))==(tc7_port | OPN | WRTNG))
#define INPORTP(x) (((0x7f | RDNG) & CAR(x))==(tc7_port | RDNG))
#define OUTPORTP(x) (((0x7f | WRTNG) & CAR(x))==(tc7_port | WRTNG))
#define OPENP(x) (OPN & CAR(x))
#define CLOSEDP(x) (!OPENP(x))
#define STREAM(x) ((FILE *)(CDR(x)))
#define SETSTREAM SETCDR
#define CRDYP(port) ((CAR(port) & CRDY) && (EOF != CGETUN(port)))
#define CLRDY(port) (CAR(port) &= (SCM_PORTFLAGS(port) | (~0xf0000)))
#define CGETUN(port) (scm_port_table[SCM_PORTNUM(port)].unread)
#define tc_socket (tc7_port | OPN)
#define SOCKP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc_socket))
#define SOCKTYP(x) (INUM(SCM_PORTDATA(x)))
#define DIRP(x) (NIMP(x) && (TYP16(x)==(tc16_dir)))
#define OPDIRP(x) (NIMP(x) && (CAR(x)==(tc16_dir | OPN)))
#ifdef FLOATS
# define INEXP(x) (TYP16(x)==tc16_flo)
# define CPLXP(x) (CAR(x)==tc_dblc)
# define REAL(x) (*(((dbl *) (SCM2PTR(x)))->real))
# define IMAG(x) (*((double *)(CHARS(x)+sizeof(double))))
/* ((&REAL(x))[1]) */
# ifdef SINGLES
# define REALP(x) ((~REAL_PART & CAR(x))==tc_flo)
# define SINGP(x) SCM_EXPECT_TRUE(CAR(x)==tc_flo)
# define FLO(x) (((flo *)(SCM2PTR(x)))->num)
# define REALPART(x) (SINGP(x)?0.0+FLO(x):REAL(x))
# else /* SINGLES */
# define REALP(x) (CAR(x)==tc_dblr)
# define REALPART REAL
# endif /* SINGLES */
#endif
#ifdef FLOATS
# define NUMBERP(x) (INUMP(x) || (NIMP(x) && NUMP(x)))
#else
# ifdef BIGDIG
# define NUMBERP(x) (INUMP(x) || (NIMP(x) && NUMP(x)))
# else
# define NUMBERP INUMP
# endif
#endif
#define NUMP(x) ((0xfcff & PTR2INT(CAR(x)))==tc7_smob)
#define BIGP(x) (TYP16S(x)==tc16_bigpos)
#define BIGSIGN(x) (0x0100 & PTR2INT(CAR(x)))
#define BDIGITS(x) ((BIGDIG *)(CDR(x)))
#define NUMDIGS(x) ((sizet)(((unsigned long)CAR(x))>>16))
#define MAKE_NUMDIGS(v, t) ((((v)+0L)<<16)+(t))
#define SETNUMDIGS(x, v, t) CAR(x) = MAKE_NUMDIGS(v, t)
#define SNAME(x) ((char *)(subrs[NUMDIGS(x)].name))
#define SUBRF(x) (((subr *)(SCM2PTR(x)))->cproc)
#define DSUBRF(x) (((dsubr *)(SCM2PTR(x)))->dproc)
#define CCLO_SUBR(x) (VELTS(x)[0])
#define CCLO_LENGTH NUMDIGS
#define CXR_OP SMOBNUM
#define SYMBOLP(x) (TYP7S(x)==tc7_ssymbol)
#define STRINGP(x) (TYP7(x)==tc7_string)
#define NSTRINGP(x) (!STRINGP(x))
#define BYTESP(x) (TYP7(x)==tc7_VfixN8)
#define VECTORP(x) (TYP7(x)==tc7_vector)
#define NVECTORP(x) (!VECTORP(x))
#define LENGTH(x) (((unsigned long)CAR(x))>>8)
#define LENGTH_MAX (((unsigned long)-1L)>>8)
#define MAKE_LENGTH(v, t) ((((v)+0L)<<8) + (t))
#define SETLENGTH(x, v, t) CAR(x) = MAKE_LENGTH(v, t)
#define CHARS(x) ((char *)(CDR(x)))
#define UCHARS(x) ((unsigned char *)(CDR(x)))
#define VELTS(x) ((SCM *)CDR(x))
#define SETCHARS SETCDR
#define SETVELTS SETCDR
SCM_EXPORT long tc16_array;
#define ARRAYP(a) (tc16_array==TYP16(a))
#define ARRAY_V(a) (((array *)CDR(a))->v)
/*#define ARRAY_NDIM(x) NUMDIGS(x)*/
#define ARRAY_NDIM(x) ((sizet)(CAR(x)>>17))
#define ARRAY_CONTIGUOUS 0x10000
#define ARRAY_CONTP(x) (ARRAY_CONTIGUOUS & PTR2INT(CAR(x)))
#define ARRAY_BASE(a) (((array *)CDR(a))->base)
#define ARRAY_DIMS(a) ((array_dim *)(CHARS(a)+sizeof(array)))
#define FREEP(x) (CAR(x)==tc_free_cell)
#define NFREEP(x) (!FREEP(x))
#define SMOBNUM(x) (0x0ff & (CAR(x)>>8))
#define PTOBNUM(x) (0x0ff & (CAR(x)>>8))
#define SCM_PORTNUM(x) ((int)(((unsigned long)CAR(x))>>20))
#define SCM_PORTNUM_MAX ((int)((0x7fffUL<<20)>>20))
#define SCM_PORTFLAGS(x) (scm_port_table[SCM_PORTNUM(x)].flags)
#define SCM_PORTDATA(x) (scm_port_table[SCM_PORTNUM(x)].data)
#define SCM_SETFLAGS(x, flags) (CAR(x) = (CAR(x) & ~0x0f0000L) | (flags))
/* This is used (only) for closing ports. */
#define SCM_SET_PTOBNUM(x, typ) (CAR(x)=(typ)|(CAR(x) & ~0x0ffffL))
#define DIGITS '0':case '1':case '2':case '3':case '4':\
case '5':case '6':case '7':case '8':case '9'
/* Aggregated types for dispatch in switch statements. */
#define tcs_cons_inum 2: case 6:case 10:case 14:\
case 18:case 22:case 26:case 30:\
case 34:case 38:case 42:case 46:\
case 50:case 54:case 58:case 62:\
case 66:case 70:case 74:case 78:\
case 82:case 86:case 90:case 94:\
case 98:case 102:case 106:case 110:\
case 114:case 118:case 122:case 126
#define tcs_cons_iloc 124
#define tcs_cons_ispcsym 4:case 12:case 20:case 28:\
case 36:case 44:case 52:case 60:\
case 68:case 76:case 84:case 92:\
case 100:case 108
#define tcs_cons_chflag 116 /* char *or* flag */
#define tcs_cons_imcar tcs_cons_inum:\
case tcs_cons_iloc:\
case tcs_cons_ispcsym:\
case tcs_cons_chflag
#define tcs_cons_nimcar 0:case 8:case 16:case 24:\
case 32:case 40:case 48:case 56:\
case 64:case 72:case 80:case 88:\
case 96:case 104:case 112:case 120
#define tcs_cons_gloc 1:case 9:case 17:case 25:\
case 33:case 41:case 49:case 57:\
case 65:case 73:case 81:case 89:\
case 97:case 105:case 113:case 121
#define tcs_closures 3:case 11:case 19:case 27:\
case 35:case 43:case 51:case 59:\
case 67:case 75:case 83:case 91:\
case 99:case 107:case 115:case 123
#define tcs_subrs tc7_asubr:case tc7_subr_0:case tc7_subr_1:case tc7_cxr:\
case tc7_subr_3:case tc7_subr_2:case tc7_rpsubr:case tc7_subr_1o:\
case tc7_subr_2o:case tc7_lsubr_2:case tc7_lsubr
#define tcs_symbols tc7_ssymbol:case tc7_msymbol
#define tcs_bignums tc16_bigpos:case tc16_bigneg
#define tcs_uves tc7_string:\
case tc7_VfixN8:case tc7_VfixZ8:case tc7_VfixN16:case tc7_VfixZ16:\
case tc7_VfixN32:case tc7_VfixZ32:case tc7_VfixN64:case tc7_VfixZ64:\
case tc7_VfloR32:case tc7_VfloC32:case tc7_VfloR64:case tc7_VfloC64:\
case tc7_Vbool
#define tc3_cons_nimcar 0
#define tc3_cons_imcar 2:case 4:case 6
#define tc3_cons_gloc 1
#define tc3_closure 3
#define tc3_tc7_types 5:case 7
#define tc7_ssymbol 5
#define tc7_msymbol 7
#define tc7_string 13
#define tc7_vector 15
#define tc7_VfixN8 21
#define tc7_VfixZ8 23
#define tc7_VfixN16 29
#define tc7_VfixZ16 31
#define tc7_VfixN32 37
#define tc7_VfixZ32 39
#define tc7_VfixN64 45
#define tc7_VfixZ64 47
#define tc7_VfloR32 53
#define tc7_VfloC32 55
#define tc7_VfloR64 61
#define tc7_VfloC64 63
#define tc7_Vbool 69
#define tc7_port 71
#define tc7_contin 77
#define tc7_specfun 79
#define tc7_subr_0 85
#define tc7_subr_1 87
#define tc7_cxr 93
#define tc7_subr_3 95
#define tc7_subr_2 101
#define tc7_asubr 103
#define tc7_subr_1o 109
#define tc7_subr_2o 111
#define tc7_lsubr_2 117
#define tc7_lsubr 119
#define tc7_rpsubr 125
#define tc7_smob 127
#define tc_free_cell 127
#define tc_broken_heart (tc_free_cell+0x10000)
#define tc16_apply (tc7_specfun | (0L<<8))
#define tc16_call_cc (tc7_specfun | (1L<<8))
#define tc16_cclo (tc7_specfun | (2L<<8))
#define tc16_eval (tc7_specfun | (3L<<8))
#define tc16_values (tc7_specfun | (4L<<8))
#define tc16_call_wv (tc7_specfun | (5L<<8))
#define tc16_flo 0x017f
#define tc_flo 0x017fL
#define REAL_PART (1L<<16)
#define IMAG_PART (2L<<16)
#define tc_dblr (tc16_flo|REAL_PART)
#define tc_dblc (tc16_flo|REAL_PART|IMAG_PART)
#define tc16_bigpos 0x027f
#define tc16_bigneg 0x037f
/* The first four flags fit in the car of a port cell, remaining
flags only in the port table */
#define OPN (1L<<16)
#define RDNG (2L<<16)
#define WRTNG (4L<<16)
#define CRDY (8L<<16)
#define TRACKED (16L<<16)
#define BINARY (32L<<16)
#define BUF0 (64L<<16)
#define EXCLUSIVE (128L<<16)
/* LSB is used for gc mark */
SCM_EXPORT scm_gra subrs_gra;
#define subrs ((subr_info *)(subrs_gra.elts))
/* SCM_EXPORT sizet numsmob, numptob;
SCM_EXPORT smobfuns *smobs;
SCM_EXPORT ptobfuns *ptobs;
SCM_EXPORT ptobfuns pipob; */
SCM_EXPORT scm_gra smobs_gra;
#define numsmob (smobs_gra.len)
#define smobs ((smobfuns *)(smobs_gra.elts))
SCM_EXPORT scm_gra ptobs_gra;
#define numptob (ptobs_gra.len)
#define ptobs ((ptobfuns *)(ptobs_gra.elts))
SCM_EXPORT port_info *scm_port_table;
#define tc16_fport (tc7_port + 0*256L)
#define tc16_pipe (tc7_port + 1*256L)
#define tc16_strport (tc7_port + 2*256L)
#define tc16_sfport (tc7_port + 3*256L)
SCM_EXPORT long tc16_dir;
SCM_EXPORT long tc16_clport;
SCM_EXPORT SCM sys_protects[];
#define cur_inp sys_protects[0]
#define cur_outp sys_protects[1]
#define cur_errp sys_protects[2]
#define def_inp sys_protects[3]
#define def_outp sys_protects[4]
#define def_errp sys_protects[5]
#define sys_errp sys_protects[6]
#define sys_safep sys_protects[7]
#define listofnull sys_protects[8]
#define undefineds sys_protects[9]
#define nullvect sys_protects[10]
#define nullstr sys_protects[11]
#define progargs sys_protects[12]
#define loadports sys_protects[13]
#define rootcont sys_protects[14]
#define dynwinds sys_protects[15]
#define list_unspecified sys_protects[16]
#define f_evapply sys_protects[17]
#define eval_env sys_protects[18]
#define f_apply_closure sys_protects[19]
#define flo0 sys_protects[20]
#define scm_uprotects sys_protects[21]
#define scm_narn sys_protects[22]
#define pows5 sys_protects[23]
#define NUM_PROTECTS 24
/* now for connects between source files */
/* SCM_EXPORT sizet num_finals;
SCM_EXPORT void (**finals)P((void));
SCM_EXPORT sizet num_finals; */
SCM_EXPORT scm_gra finals_gra;
#define num_finals (finals_gra.len)
#define finals ((void (**)())(finals_gra.elts))
SCM_EXPORT unsigned char upcase[], downcase[];
SCM_EXPORT SCM symhash;
SCM_EXPORT int symhash_dim;
SCM_EXPORT int no_symhash_gc; /* Set when linking code produced by Hobbit compiler. */
SCM_EXPORT long heap_cells;
SCM_EXPORT CELLPTR heap_org;
SCM_EXPORT VOLATILE SCM freelist;
SCM_EXPORT long gc_cells_collected, gc_malloc_collected, gc_ports_collected;
SCM_EXPORT long gc_syms_collected;
SCM_EXPORT long cells_allocated, lcells_allocated, mallocated, lmallocated;
SCM_EXPORT long mtrigger;
SCM_EXPORT SCM *loc_loadpath;
SCM_EXPORT SCM *loc_errobj;
SCM_EXPORT SCM loadport;
SCM_EXPORT char *errjmp_bad;
SCM_EXPORT VOLATILE int ints_disabled;
SCM_EXPORT int output_deferred, gc_hook_pending, gc_hook_active;
SCM_EXPORT unsigned long SIG_deferred;
SCM_EXPORT SCM exitval;
SCM_EXPORT int cursinit;
SCM_EXPORT unsigned int poll_count, tick_count;
SCM_EXPORT int dumped;
SCM_EXPORT char *execpath;
SCM_EXPORT char s_no_execpath[];
SCM_EXPORT int scm_verbose;
#define verbose (scm_verbose+0)
SCM_EXPORT const char dirsep[];
/* strings used in several source files */
SCM_EXPORT char s_write[], s_newline[], s_system[];
SCM_EXPORT char s_make_string[], s_make_vector[], s_list[], s_op_pipe[];
#define s_string (s_make_string+5)
#define s_vector (s_make_vector+5)
#define s_pipe (s_op_pipe+5)
SCM_EXPORT char s_make_sh_array[];
SCM_EXPORT char s_array_fill[];
#define s_array (s_make_sh_array+12)
SCM_EXPORT char s_ccl[];
#define s_limit (s_ccl+10)
SCM_EXPORT char s_close_port[];
#define s_port_type (s_close_port+6)
SCM_EXPORT char s_call_cc[];
#define s_cont (s_call_cc+18)
SCM_EXPORT char s_try_create_file[];
SCM_EXPORT char s_badenv[];
SCM_EXPORT void (*init_user_scm) P((void));
/* function prototypes */
SCM_EXPORT void (* deferred_proc) P((void));
SCM_EXPORT void process_signals P((void));
SCM_EXPORT int handle_it P((int i));
SCM_EXPORT SCM must_malloc_cell P((long len, SCM c, const char *what));
SCM_EXPORT void must_realloc_cell P((SCM z, long olen, long len, const char *what));
SCM_EXPORT char *must_malloc P((long len, const char *what));
SCM_EXPORT char *must_realloc P((char *where, long olen, long len, const char *what));
SCM_EXPORT void must_free P((char *obj, sizet len));
SCM_EXPORT void scm_protect_temp P((SCM *ptr));
SCM_EXPORT long ilength P((SCM sx));
SCM_EXPORT SCM hash P((SCM obj, SCM n));
SCM_EXPORT SCM hashv P((SCM obj, SCM n));
SCM_EXPORT SCM hashq P((SCM obj, SCM n));
SCM_EXPORT SCM obhash P((SCM obj));
SCM_EXPORT SCM obunhash P((SCM obj));
SCM_EXPORT unsigned long strhash P((unsigned char *str, sizet len, unsigned long n));
SCM_EXPORT unsigned long hasher P((SCM obj, unsigned long n, sizet d));
SCM_EXPORT SCM lroom P((SCM args));
SCM_EXPORT void lfflush P((SCM port));
SCM_EXPORT SCM scm_force_output P((SCM port));
SCM_EXPORT void scm_init_gra P((scm_gra *gra, sizet eltsize, sizet len,
sizet maxlen, const char *what));
SCM_EXPORT int scm_grow_gra P((scm_gra *gra, char *elt));
SCM_EXPORT void scm_trim_gra P((scm_gra *gra));
SCM_EXPORT void scm_free_gra P((scm_gra *gra));
SCM_EXPORT long newsmob P((smobfuns *smob));
SCM_EXPORT long newptob P((ptobfuns *ptob));
SCM_EXPORT SCM scm_port_entry P((FILE *stream, long ptype, long flags));
SCM_EXPORT SCM scm_open_ports P((void));
SCM_EXPORT void prinport P((SCM exp, SCM port, char *type));
SCM_EXPORT SCM repl P((void));
SCM_EXPORT void repl_report P((void));
SCM_EXPORT void growth_mon P((char *obj, long size, char *units, int grewp));
SCM_EXPORT void gc_start P((const char *what));
SCM_EXPORT void gc_end P((void));
SCM_EXPORT void gc_mark P((SCM p));
SCM_EXPORT void scm_gc_hook P((void));
SCM_EXPORT SCM scm_gc_protect P((SCM obj));
SCM_EXPORT SCM scm_add_finalizer P((SCM value, SCM finalizer));
SCM_EXPORT void scm_run_finalizers P((int exiting));
SCM_EXPORT void scm_egc_start P((void));
SCM_EXPORT void scm_egc_end P((void));
SCM_EXPORT void heap_report P((void));
SCM_EXPORT void gra_report P((void));
SCM_EXPORT void exit_report P((void));
SCM_EXPORT void stack_report P((void));
SCM_EXPORT SCM scm_stack_trace P((SCM contin));
SCM_EXPORT SCM scm_scope_trace P((SCM env));
SCM_EXPORT SCM scm_frame_trace P((SCM contin, SCM nf));
SCM_EXPORT SCM scm_frame2env P((SCM contin, SCM nf));
SCM_EXPORT SCM scm_frame_eval P((SCM contin, SCM nf, SCM expr));
SCM_EXPORT void scm_iprin1 P((SCM exp, SCM port, int writing));
SCM_EXPORT void scm_intprint P((long n, int radix, SCM port));
SCM_EXPORT void scm_iprlist P((char *hdr, SCM exp, int tlr, SCM port, int writing));
SCM_EXPORT SCM scm_env_lookup P((SCM var, SCM stenv));
SCM_EXPORT SCM scm_env_rlookup P((SCM addr, SCM stenv, const char *what));
SCM_EXPORT SCM scm_env_getprop P((SCM prop, SCM env));
SCM_EXPORT SCM scm_env_addprop P((SCM prop, SCM val, SCM env));
SCM_EXPORT long num_frames P((SCM estk, int i));
SCM_EXPORT SCM *estk_frame P((SCM estk, int i, int nf));
SCM_EXPORT SCM *cont_frame P((SCM contin, int nf));
SCM_EXPORT SCM stacktrace1 P((SCM estk, int i));
SCM_EXPORT void scm_princode P((SCM code, SCM env, SCM port, int writing));
SCM_EXPORT void scm_princlosure P((SCM proc, SCM port, int writing));
SCM_EXPORT void lputc P((int c, SCM port));
SCM_EXPORT void lputs P((const char *s, SCM port));
SCM_EXPORT sizet lfwrite P((char *ptr, sizet size, sizet nitems, SCM port));
SCM_EXPORT int lgetc P((SCM port));
SCM_EXPORT void lungetc P((int c, SCM port));
SCM_EXPORT char *grow_tok_buf P((SCM tok_buf));
SCM_EXPORT long mode_bits P((char *modes, char *cmodes));
SCM_EXPORT long time_in_msec P((long x));
SCM_EXPORT SCM my_time P((void));
SCM_EXPORT SCM your_time P((void));
SCM_EXPORT void init_iprocs P((iproc *subra, int type));
SCM_EXPORT void final_scm P((int));
SCM_EXPORT void init_sbrk P((void));
SCM_EXPORT int init_buf0 P((FILE *inport));
SCM_EXPORT void scm_init_from_argv P((int argc, const char * const *argv, char *script_arg,
int iverbose, int buf0stdin));
SCM_EXPORT void init_signals P((void));
SCM_EXPORT SCM scm_top_level P((char *initpath, SCM (*toplvl_fun)()));
SCM_EXPORT void restore_signals P((void));
SCM_EXPORT void free_storage P((void));
SCM_EXPORT char *dld_find_executable P((const char* command));
SCM_EXPORT char *scm_find_execpath P((int argc, const char * const *argv, const char *script_arg));
SCM_EXPORT void init_scm P((int iverbose, int buf0stdin, long init_heap_size));
SCM_EXPORT void scm_init_INITS P((void));
SCM_EXPORT SCM scm_init_extensions P((void));
SCM_EXPORT void ignore_signals P((void));
SCM_EXPORT void unignore_signals P((void));
SCM_EXPORT void add_feature P((char *str));
SCM_EXPORT int raprin1 P((SCM exp, SCM port, int writing));
SCM_EXPORT SCM markcdr P((SCM ptr));
#define mark0 (0) /*SCM mark0 P((SCM ptr)); */
SCM_EXPORT SCM equal0 P((SCM ptr1, SCM ptr2));
SCM_EXPORT sizet free0 P((CELLPTR ptr));
SCM_EXPORT void scm_warn P((char *str1, char *str2, SCM obj));
SCM_EXPORT void everr P((SCM exp, SCM env, SCM arg, const char *pos, const char *s_subr, int codep));
SCM_EXPORT void wta P((SCM arg, const char *pos, const char *s_subr));
SCM_EXPORT void scm_experr P((SCM arg, const char *pos, const char *s_subr));
SCM_EXPORT SCM intern P((char *name, sizet len));
SCM_EXPORT SCM sysintern P((const char *name, SCM val));
SCM_EXPORT SCM sym2vcell P((SCM sym));
SCM_EXPORT SCM makstr P((long len));
SCM_EXPORT SCM scm_maksubr P((const char *name, int type, SCM (*fcn)()));
SCM_EXPORT SCM make_subr P((const char *name, int type, SCM (*fcn)()));
SCM_EXPORT SCM make_synt P((const char *name, long flags, SCM (*fcn)()));
SCM_EXPORT SCM make_gsubr P((const char *name, int req, int opt, int rst,
SCM (*fcn)()));
SCM_EXPORT SCM closure P((SCM code, int nargs));
SCM_EXPORT SCM makprom P((SCM code));
SCM_EXPORT SCM force P((SCM x));
SCM_EXPORT SCM makarb P((SCM name));
SCM_EXPORT SCM tryarb P((SCM arb));
SCM_EXPORT SCM relarb P((SCM arb));
SCM_EXPORT SCM ceval P((SCM x, SCM static_env, SCM env));
SCM_EXPORT SCM scm_wrapcode P((SCM code, SCM env));
SCM_EXPORT SCM scm_current_env P((void));
SCM_EXPORT SCM prolixity P((SCM arg));
SCM_EXPORT SCM gc_for_newcell P((void));
SCM_EXPORT void gc_for_open_files P((void));
SCM_EXPORT SCM gc P((SCM arg));
SCM_EXPORT SCM tryload P((SCM filename, SCM reader));
SCM_EXPORT SCM acons P((SCM w, SCM x, SCM y));
SCM_EXPORT SCM cons2 P((SCM w, SCM x, SCM y));
SCM_EXPORT SCM resizuve P((SCM vect, SCM len));
SCM_EXPORT SCM lnot P((SCM x));
SCM_EXPORT SCM booleanp P((SCM obj));
SCM_EXPORT SCM eq P((SCM x, SCM y));
SCM_EXPORT SCM equal P((SCM x, SCM y));
SCM_EXPORT SCM consp P((SCM x));
SCM_EXPORT SCM cons P((SCM x, SCM y));
SCM_EXPORT SCM nullp P((SCM x));
SCM_EXPORT SCM setcar P((SCM pair, SCM value));
SCM_EXPORT SCM setcdr P((SCM pair, SCM value));
SCM_EXPORT SCM listp P((SCM x));
SCM_EXPORT SCM list P((SCM objs));
SCM_EXPORT SCM length P((SCM x));
SCM_EXPORT SCM append P((SCM args));
SCM_EXPORT SCM reverse P((SCM lst));
SCM_EXPORT SCM list_ref P((SCM lst, SCM k));
SCM_EXPORT SCM memq P((SCM x, SCM lst));
SCM_EXPORT SCM member P((SCM x, SCM lst));
SCM_EXPORT SCM memv P((SCM x, SCM lst));
SCM_EXPORT SCM assq P((SCM x, SCM alist));
SCM_EXPORT SCM assoc P((SCM x, SCM alist));
SCM_EXPORT SCM symbolp P((SCM x));
SCM_EXPORT SCM symbol2string P((SCM s));
SCM_EXPORT SCM string2symbol P((SCM s));
SCM_EXPORT SCM string_copy P((SCM s));
SCM_EXPORT SCM numberp P((SCM x));
SCM_EXPORT SCM exactp P((SCM x));
SCM_EXPORT SCM inexactp P((SCM x));
SCM_EXPORT SCM eqp P((SCM x, SCM y));
SCM_EXPORT SCM eqv P((SCM x, SCM y));
SCM_EXPORT SCM lessp P((SCM x, SCM y));
SCM_EXPORT SCM greaterp P((SCM x, SCM y));
SCM_EXPORT SCM leqp P((SCM x, SCM y));
SCM_EXPORT SCM greqp P((SCM x, SCM y));
SCM_EXPORT SCM zerop P((SCM z));
SCM_EXPORT SCM positivep P((SCM x));
SCM_EXPORT SCM negativep P((SCM x));
SCM_EXPORT SCM oddp P((SCM n));
SCM_EXPORT SCM evenp P((SCM n));
SCM_EXPORT SCM scm_max P((SCM x, SCM y));
SCM_EXPORT SCM scm_min P((SCM x, SCM y));
SCM_EXPORT SCM sum P((SCM x, SCM y));
SCM_EXPORT SCM difference P((SCM x, SCM y));
SCM_EXPORT SCM product P((SCM x, SCM y));
SCM_EXPORT SCM divide P((SCM x, SCM y));
SCM_EXPORT SCM scm_round_quotient P((SCM x, SCM y));
SCM_EXPORT SCM lquotient P((SCM x, SCM y));
SCM_EXPORT SCM scm_iabs P((SCM x));
SCM_EXPORT SCM scm_abs P((SCM x));
SCM_EXPORT SCM lremainder P((SCM x, SCM y));
SCM_EXPORT SCM modulo P((SCM x, SCM y));
SCM_EXPORT SCM lgcd P((SCM x, SCM y));
SCM_EXPORT SCM llcm P((SCM n1, SCM n2));
SCM_EXPORT SCM number2string P((SCM x, SCM radix));
SCM_EXPORT SCM istring2number P((char *str, long len, long radix));
SCM_EXPORT SCM string2number P((SCM str, SCM radix));
SCM_EXPORT SCM istr2flo P((char *str, long len, long radix));
SCM_EXPORT SCM mkbig P((sizet nlen, int sign));
SCM_EXPORT void bigrecy P((SCM bgnm));
SCM_EXPORT SCM mkstrport P((SCM pos, SCM str, long modes, char *caller));
SCM_EXPORT SCM mksafeport P((int maxlen, SCM port));
SCM_EXPORT int reset_safeport P((SCM sfp, int maxlen, SCM port));
SCM_EXPORT SCM long2big P((long n));
SCM_EXPORT SCM ulong2big P((unsigned long n));
SCM_EXPORT SCM big2inum P((SCM b, sizet l));
SCM_EXPORT sizet ilong2str P((long num, int rad, char *p));
SCM_EXPORT sizet iulong2str P((unsigned long num, int rad, char *p));
SCM_EXPORT SCM floequal P((SCM x, SCM y));
SCM_EXPORT SCM uve_equal P((SCM u, SCM v));
SCM_EXPORT SCM uve_read P((SCM v, SCM port));
SCM_EXPORT SCM uve_write P((SCM v, SCM port));
SCM_EXPORT SCM raequal P((SCM ra0, SCM ra1));
SCM_EXPORT SCM array_equal P((SCM u, SCM v));
SCM_EXPORT SCM array_rank P((SCM ra));
SCM_EXPORT int rafill P((SCM ra, SCM fill, SCM ignore));
SCM_EXPORT SCM uve_fill P((SCM uve, SCM fill));
SCM_EXPORT SCM array_fill P((SCM ra, SCM fill));
SCM_EXPORT SCM array_prot P((SCM ra));
SCM_EXPORT SCM array_rank P((SCM ra));
SCM_EXPORT SCM array_contents P((SCM ra, SCM strict));
SCM_EXPORT int bigprint P((SCM exp, SCM port, int writing));
SCM_EXPORT int floprint P((SCM sexp, SCM port, int writing));
SCM_EXPORT SCM istr2int P((char *str, long len, int radix));
SCM_EXPORT SCM istr2bve P((char *str, long len));
SCM_EXPORT void scm_ipruk P((char *hdr, SCM ptr, SCM port));
SCM_EXPORT SCM charp P((SCM x));
SCM_EXPORT SCM char_lessp P((SCM x, SCM y));
SCM_EXPORT SCM chci_eq P((SCM x, SCM y));
SCM_EXPORT SCM chci_lessp P((SCM x, SCM y));
SCM_EXPORT SCM char_alphap P((SCM chr));
SCM_EXPORT SCM char_nump P((SCM chr));
SCM_EXPORT SCM char_whitep P((SCM chr));
SCM_EXPORT SCM char_upperp P((SCM chr));
SCM_EXPORT SCM char_lowerp P((SCM chr));
SCM_EXPORT SCM char2int P((SCM chr));
SCM_EXPORT SCM int2char P((SCM n));
SCM_EXPORT SCM char_upcase P((SCM chr));
SCM_EXPORT SCM char_downcase P((SCM chr));
SCM_EXPORT SCM stringp P((SCM x));
SCM_EXPORT SCM string P((SCM chrs));
SCM_EXPORT SCM make_string P((SCM k, SCM chr));
SCM_EXPORT SCM string2list P((SCM str));
SCM_EXPORT SCM st_length P((SCM str));
SCM_EXPORT SCM st_ref P((SCM str, SCM k));
SCM_EXPORT SCM st_set P((SCM str, SCM k, SCM chr));
SCM_EXPORT SCM st_equal P((SCM s1, SCM s2));
SCM_EXPORT SCM stci_equal P((SCM s1, SCM s2));
SCM_EXPORT SCM st_lessp P((SCM s1, SCM s2));
SCM_EXPORT SCM stci_lessp P((SCM s1, SCM s2));
SCM_EXPORT SCM substring P((SCM str, SCM start, SCM end));
SCM_EXPORT SCM st_append P((SCM args));
SCM_EXPORT SCM vectorp P((SCM x));
SCM_EXPORT SCM vector_length P((SCM v));
SCM_EXPORT SCM vector P((SCM l));
SCM_EXPORT SCM vector_ref P((SCM v, SCM k));
SCM_EXPORT SCM vector_set P((SCM v, SCM k, SCM obj));
SCM_EXPORT SCM make_vector P((SCM k, SCM fill));
SCM_EXPORT SCM vector2list P((SCM v));
SCM_EXPORT SCM for_each P((SCM proc, SCM arg1, SCM args));
SCM_EXPORT SCM procedurep P((SCM obj));
SCM_EXPORT SCM apply P((SCM proc, SCM arg1, SCM args));
SCM_EXPORT SCM scm_cvapply P((SCM proc, long n, SCM *argv));
SCM_EXPORT int scm_arity_check P((SCM proc, long argc, const char *what));
SCM_EXPORT SCM map P((SCM proc, SCM arg1, SCM args));
SCM_EXPORT SCM scm_make_cont P((void));
SCM_EXPORT SCM copytree P((SCM obj));
SCM_EXPORT SCM eval P((SCM obj));
SCM_EXPORT SCM scm_values P((SCM arg1, SCM arg2, SCM rest, const char *what));
SCM_EXPORT SCM scm_eval_values P((SCM x, SCM static_env, SCM env));
SCM_EXPORT SCM identp P((SCM obj));
SCM_EXPORT SCM ident2sym P((SCM id));
SCM_EXPORT SCM ident_eqp P((SCM id1, SCM id2, SCM env));
SCM_EXPORT int scm_nullenv_p P((SCM env));
SCM_EXPORT SCM env2tree P((SCM env));
SCM_EXPORT SCM renamed_ident P((SCM id, SCM env));
SCM_EXPORT SCM scm_check_linum P((SCM x, SCM *linum));
SCM_EXPORT SCM scm_add_linum P((SCM linum, SCM x));
SCM_EXPORT SCM input_portp P((SCM x));
SCM_EXPORT SCM output_portp P((SCM x));
SCM_EXPORT SCM cur_input_port P((void));
SCM_EXPORT SCM cur_output_port P((void));
SCM_EXPORT SCM i_setbuf0 P((SCM port));
SCM_EXPORT SCM try_open_file P((SCM filename, SCM modes));
SCM_EXPORT SCM open_file P((SCM filename, SCM modes));
SCM_EXPORT SCM open_pipe P((SCM pipestr, SCM modes));
SCM_EXPORT SCM close_port P((SCM port));
SCM_EXPORT SCM scm_file_position P((SCM port, SCM pos));
#define file_position(port) scm_file_position(port, BOOL_F)
#define file_set_position scm_file_position
SCM_EXPORT SCM scm_read P((SCM port));
SCM_EXPORT SCM scm_read_char P((SCM port));
SCM_EXPORT SCM scm_peek_char P((SCM port));
SCM_EXPORT SCM eof_objectp P((SCM x));
SCM_EXPORT int scm_io_error P((SCM port, const char *what));
SCM_EXPORT SCM scm_write P((SCM obj, SCM port));
SCM_EXPORT SCM scm_display P((SCM obj, SCM port));
SCM_EXPORT SCM scm_newline P((SCM port));
SCM_EXPORT SCM scm_write_char P((SCM chr, SCM port));
SCM_EXPORT SCM scm_port_line P((SCM port));
SCM_EXPORT SCM scm_port_col P((SCM port));
SCM_EXPORT void scm_line_msg P((SCM file, SCM linum, SCM port));
SCM_EXPORT void scm_err_line P((const char *what, SCM file, SCM linum, SCM port));
SCM_EXPORT SCM scm_getenv P((SCM nam));
SCM_EXPORT SCM prog_args P((void));
SCM_EXPORT SCM makacro P((SCM code));
SCM_EXPORT SCM makmacro P((SCM code));
SCM_EXPORT SCM makmmacro P((SCM code));
SCM_EXPORT SCM makidmacro P((SCM code));
SCM_EXPORT void poll_routine P((void));
SCM_EXPORT void tick_signal P((void));
SCM_EXPORT void stack_check P((void));
SCM_EXPORT SCM list2ura P((SCM ndim, SCM prot, SCM lst));
SCM_EXPORT SCM make_ra P((int ndim));
SCM_EXPORT SCM makflo P((float x));
SCM_EXPORT SCM arrayp P((SCM v, SCM prot));
SCM_EXPORT SCM aset P((SCM v, SCM obj, SCM args));
SCM_EXPORT SCM aref P((SCM v, SCM args));
SCM_EXPORT SCM scm_array_ref P((SCM args));
SCM_EXPORT SCM cvref P((SCM v, sizet pos, SCM last));
SCM_EXPORT SCM quit P((SCM n));
#ifdef CAREFUL_INTS
SCM_EXPORT void ints_viol P((ints_infot *info, int sense));
SCM_EXPORT void ints_warn P((char *s1, char* s2, char *fname, int linum));
#endif
SCM_EXPORT void add_final P((void (*final)(void)));
SCM_EXPORT SCM makcclo P((SCM proc, long len));
SCM_EXPORT SCM make_uve P((long k, SCM prot));
SCM_EXPORT long scm_prot2type P((SCM prot));
SCM_EXPORT long aind P((SCM ra, SCM args, const char *what));
SCM_EXPORT SCM scm_eval_string P((SCM str));
SCM_EXPORT SCM scm_load_string P((SCM str));
SCM_EXPORT SCM scm_unexec P((const SCM pathname));
SCM_EXPORT SCM scm_logbitp P((SCM index, SCM j1));
SCM_EXPORT SCM scm_logtest P((SCM x, SCM y));
SCM_EXPORT SCM scm_logxor P((SCM x, SCM y));
SCM_EXPORT SCM scm_logand P((SCM x, SCM y));
SCM_EXPORT SCM scm_logior P((SCM x, SCM y));
SCM_EXPORT SCM scm_lognot P((SCM n));
SCM_EXPORT SCM scm_intexpt P((SCM z1, SCM z2));
SCM_EXPORT SCM scm_intlog P((SCM base, SCM k));
SCM_EXPORT SCM scm_cintlog P((SCM base, SCM k));
SCM_EXPORT SCM scm_ash P((SCM n, SCM cnt));
SCM_EXPORT SCM scm_bitfield P((SCM n, SCM start, SCM end));
SCM_EXPORT SCM scm_logcount P((SCM n));
SCM_EXPORT SCM scm_intlength P((SCM n));
SCM_EXPORT SCM scm_copybit P((SCM index, SCM j1, SCM bit));
SCM_EXPORT SCM scm_bitif P((SCM mask, SCM n0, SCM n1));
SCM_EXPORT SCM scm_copybitfield P((SCM to, SCM start, SCM rest));
/* Defined in "rope.c" */
SCM_EXPORT SCM long2num P((long n));
SCM_EXPORT SCM ulong2num P((unsigned long n));
SCM_EXPORT unsigned char num2uchar P((SCM num, char *pos, char *s_caller));
SCM_EXPORT signed char num2char P((SCM num, char *pos, char *s_caller));
SCM_EXPORT unsigned short num2ushort P((SCM num, char *pos, char *s_caller));
SCM_EXPORT short num2short P((SCM num, char *pos, char *s_caller));
SCM_EXPORT unsigned long num2ulong P((SCM num, char *pos, char *s_caller));
SCM_EXPORT long num2long P((SCM num, char *pos, char *s_caller));
SCM_EXPORT double num2dbl P((SCM num, char *pos, char *s_caller));
SCM_EXPORT SCM makfromstr P((const char *src, sizet len));
SCM_EXPORT SCM makfromstrs P((int argc, const char * const *argv));
SCM_EXPORT SCM makfrom0str P((const char *scr));
SCM_EXPORT char **makargvfrmstrs P((SCM args, const char *s_v));
SCM_EXPORT void must_free_argv P((char **argv));
SCM_EXPORT SCM scm_evstr P((char *str));
SCM_EXPORT void scm_ldstr P((char *str));
SCM_EXPORT int scm_ldfile P((char *path));
SCM_EXPORT int scm_ldprog P((char *path));
SCM_EXPORT void* scm_addr P((SCM args, const char *name));
SCM_EXPORT void* scm_base_addr P((SCM v, const char *name));
SCM_EXPORT int scm_cell_p P((SCM x));
#ifdef FLOATS
SCM_EXPORT SCM makdbl P((double x, double y));
SCM_EXPORT SCM dbl2big P((double d));
SCM_EXPORT double int2dbl P((SCM b));
SCM_EXPORT double scm_truncate P((double x));
SCM_EXPORT double scm_round P((double x));
SCM_EXPORT double floident P((double x));
#endif
#ifdef BIGDIG
SCM_EXPORT void longdigs P((long x, BIGDIG digs[DIGSPERLONG]));
SCM_EXPORT SCM adjbig P((SCM b, sizet nlen));
SCM_EXPORT SCM normbig P((SCM b));
SCM_EXPORT SCM copybig P((SCM b, int sign));
SCM_EXPORT SCM addbig P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int sgny));
SCM_EXPORT SCM mulbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn));
SCM_EXPORT UBIGLONG divbigdig P((BIGDIG *ds, sizet h, BIGDIG div));
SCM_EXPORT SCM divbigint P((SCM x, long z, int sgn, int mode));
SCM_EXPORT SCM divbigbig P((BIGDIG *x, sizet nx, BIGDIG *y, sizet ny, int sgn,
int mode));
SCM_EXPORT long pseudolong P((long x));
#endif
SCM_EXPORT int bigcomp P((SCM x, SCM y));
SCM_EXPORT SCM bigequal P((SCM x, SCM y));
SCM_EXPORT int scm_bigdblcomp P((SCM b, double d));
/* "script.c" functions */
SCM_EXPORT char * scm_cat_path P((char *str1, const char *str2, long n));
SCM_EXPORT char * scm_try_path P((char *path));
SCM_EXPORT char * script_find_executable P((const char *command));
SCM_EXPORT char ** script_process_argv P((int argc, const char **argv));
SCM_EXPORT int script_count_argv P((const char **argv));
SCM_EXPORT char * find_impl_file P((const char *exec_path, const char *generic_name,
const char *initname, const char *sep));
/* environment cache functions */
SCM_EXPORT void scm_ecache_report P((void));
SCM_EXPORT void scm_estk_reset P((sizet size));
SCM_EXPORT void scm_env_cons P((SCM x, SCM y));
SCM_EXPORT void scm_env_cons2 P((SCM w, SCM x, SCM y));
SCM_EXPORT void scm_env_cons3 P((SCM v, SCM w, SCM x, SCM y));
SCM_EXPORT void scm_env_v2lst P((long argc, SCM *argv));
SCM_EXPORT void scm_extend_env P((void));
SCM_EXPORT void scm_egc P((void));
/* Global state for environment cache */
SCM_EXPORT CELLPTR scm_ecache;
SCM_EXPORT VOLATILE long scm_ecache_index, scm_ecache_len;
SCM_EXPORT SCM scm_env, scm_env_tmp;
SCM_EXPORT SCM scm_egc_roots[];
SCM_EXPORT VOLATILE long scm_egc_root_index;
SCM_EXPORT SCM scm_estk;
SCM_EXPORT SCM *scm_estk_v, *scm_estk_ptr;
SCM_EXPORT long scm_estk_size;
#ifndef RECKLESS
SCM_EXPORT SCM scm_trace, scm_trace_env;
#endif
#ifdef RECKLESS
# define ASRTER(_cond, _arg, _pos, _subr) ;
# define ASRTGO(_cond, _label) ;
#else
# define ASRTER(_cond, _arg, _pos, _subr) if (SCM_EXPECT_FALSE(!(_cond))) wta(_arg, (char *)(_pos), _subr);
# define ASRTGO(_cond, _label) if (SCM_EXPECT_FALSE(!(_cond))) goto _label;
#endif
#define ARGn 1L
#define ARG1 2L
#define ARG2 3L
#define ARG3 4L
#define ARG4 5L
#define ARG5 6L
/* following must match entry indexes in errmsgs[] */
#define WNA 7L
#define OVFLOW 8L
#define OUTOFRANGE 9L
#define NALLOC 10L
#define THRASH 11L
#define EXIT 12L
#define HUP_SIGNAL 13L
#define INT_SIGNAL 14L
#define FPE_SIGNAL 15L
#define BUS_SIGNAL 16L
#define SEGV_SIGNAL 17L
#define ALRM_SIGNAL 18L
#define VTALRM_SIGNAL 19L
#define PROF_SIGNAL 20L
#define EVAL(x, env, venv) (IMP(x)?(x):ceval((x), (SCM)(env), (SCM)(venv)))
#define SIDEVAL(x, env, venv) if (NIMP(x)) ceval((x), (SCM)(env), (SCM)(venv))
#define NEWCELL(_into) {if (IMP(freelist)) _into = gc_for_newcell();\
else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}}
/*
#define NEWCELL(_into) {DEFER_INTS;if (IMP(freelist)) _into = gc_for_newcell();\
else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}\
ALLOW_INTS;}
*/
#ifdef __cplusplus
}
#endif
scm/hobbit.scm 0000755 0000000 0000000 00000677563 12124662713 012350 0 ustar root root ;;;; "hobbit.scm": an optimizing scheme -> C compiler for SCM
;; Copyright (C) 1992-2006 Free Software Foundation
;;
;; This program 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.
;;
;; This program 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 this program. If not, see
;; .
;====================================================================
;
; HOBBIT: an optimizing scheme -> C compiler for SCM
;
; scm5e1
; 2002-04-11
;
; tammet@staff.ttu.ee, tammet@cs.chalmers.se
;
; Tanel Tammet
; Department of Computer Science
; Tallinn University of Technology
; Raja 15
; 12618, Tallinn
; Estonia
;
; Department of Computing Science
; Chalmers University of Technology
; University of Go"teborg
; S-41296 Go"teborg
; Sweden
;
;
; Documentation is in the file hobbit.texi
;
; NB! the terms for usage, copying
; and redistribution of hobbit are given in the file COPYING
;====================================================================
;
; Last part of changelog:
;
; april 2-11, 2002, Tanel Tammet:
; - "system" and "verbose" compilation corrected
; (system was previously not compiled, verbose is compiled to prolixity)
; - "require" moved from top level to hobbit procedure (necessary
; for self-compilation)
; - "copy-tree" and "acons" compilation introduced
; pre-april, 2002, Aubrey Jaffer:
; - numerous changes necessary for co-operation with SCM5d5
;;; Declare modules which might be needed:
(require-if 'compiling 'pretty-print)
(require-if 'compiling 'defmacroexpand)
(require-if 'compiling 'pprint-file)
;=================================================================
;
; default compiler options
; (may be changed)
;
;=================================================================
;;; The following variable controls whether hobbit will do any
;;; macroexpansion. In that case (require 'defmacroexpand) must
;;; be able to load the macroexpander from the scheme library.
(define *expand-macros-flag* #t)
;;; The following variable controls whether functions declared
;;; to be inlined are inlined in full or only once. If the set of
;;; nested inlinable function defs contains a circularity, the
;;; setting #t will cause Hobbit to go into an infinite loop.
(define *full-inlining-flag* #t)
;;; The following variable controls whether any intermediate files
;;; will be built. In that case (require 'pretty-print) and
;;; (require 'pprint-load) must be able to load the prettyprinter
;;; from the scheme library.
(define *build-intermediate-files* #f)
;;; The following variable controls whether any information about
;;; compilation (except warnings and error messages) are printed.
(define *infomessages-flag* #t)
;;; The following variables control whether all map-s and for-each-s
;;; are converted into inline-do-loops, or map-s and for-each-s
;;; taking only one list are compiled as any other higher-order call
;;; to functions map1 and for-each1 (inserted by the compiler in case
;;; of need).
(define *always-map->do-flag* #f)
(define *always-for-each->do-flag* #f)
;================================================================
;
; C-specific and system-specific options
; (change if needed)
;
;===============================================================
;;; If your C compiler does not assume that integers without a cast
;;; are long ints, you may need to set the following flag to #t.
;;; In that case all integers in the output C text, which should
;;; be long ints, will have a trailing L cast.
(define *long-cast-flag* #f)
;;; If your C compiler may compile the C operator ? :
;;; to the code which may evaluate BOTH and in one
;;; evaluation of the whole operator, you MUST define *lift-ifs-flag*
;;; as #t.
(define *lift-ifs-flag* #f)
;;; If you C compiler may compile the C operator ||
;;; to the code which may evaluate even if evaluates to 1,
;;; or, analogically, && may evaluate even if
;;; evaluates to 0, you MUST define *lift-and-or-flag* as #t.
(define *lift-and-or-flag* #f)
;;; The following flag may be false only if the output C program
;;; is supposed to run only on systems where the following holds:
;;; ((-1%2 == -1) && (-1%-2 == -1) && (1%2 == 1) && (1%-2 == 1).
;;; Otherwise the following flag must be #t.
(define *badivsgns-flag* #f)
;;; *input-file-modifier* and *output-file-modifier*
;;; are strings which are given to the C file-opener to
;;; indicate the mode of the file to be opened.
;;; Select the MSDOS or ATARI version if appropriate, or define
;;; your own modifier-strings.
(define *input-file-modifier* "r") ;;; for UNIX & others
(define *output-file-modifier* "w") ;;; for UNIX & others
;;; (define *input-file-modifier* "rb") ;;; for MSDOS & ATARI
;;; (define *output-file-modifier* "wb") ;;; for MSDOS & ATARI
;;; The following variable controls the maximal length of auxiliary
;;; functions created by the compiler (longer functions are split
;;; into separate chunks).
(define *max-auxfun-size* 50)
;====================================================================
;
; Scheme-implementation-specific definitions. Change if needed.
;
;====================================================================
(define (report-error . lst)
(display #\newline)
(display "COMPILATION ERROR: ")
(display #\newline)
(for-each display lst)
(display #\newline)
(abort))
;@
(define compile-allnumbers #t)
;=================================================================
;
; renamable constants
; (you might need to change some of these to
; avoid name clashes)
;
;=================================================================
;;; If your scheme file contains symbols which start
;;; with a number, then *c-num-symb-prefix* is prefixed to
;;; such symbols in the C source.
(define *c-num-symb-prefix* "nonum_prefix_")
;;; NB! If your scheme file contains variables which are also
;;; C keywords or C functions defined in scm,
;;; the string *c-keyword-postfix* is added to such variable names.
;;; The list of prohibited variables is *c-keywords*. Add new
;;; variables there, if needed.
(define *c-keyword-postfix* "_nonkeyword")
(define *c-keywords*
'(auto double int struct break else long switch
case enum register typedef char extern return union
const float short unsigned continue for signed void
default goto sizeof volatile do if static while
system random exit ; Added by M.Ward
;;; Some things are commented out to make hobbit compile itself correctly.
sizet void cell subr iproc smobfuns dblproc flo dbl isymnames s-and
s-begin s-case s-cond s-do s-if s-lambda s-let s-letstar s-letrec s-or
s-quote s-set i-dot i-quote i-quasiquote i-unquote i-uq-splicing
tcs-cons-imcar tcs-cons-nimcar tcs-cons-gloc tcs-closures tcs-subrs
tc7-asubr tcs-symbols tc7-ssymbol tcs-bignums tc16-bigpos tc3-cons
tc3-cons-gloc tc3-closure tc7-ssymbol tc7-msymbol tc7-string
tc7-vector tc7-Vbool
tc7-VfixZ32 tc7-VfixN32 tc7-VfixZ16 tc7-VfixN16 tc7-VfixZ8 tc7-VfixN8
tc7-VfloR32 tc7-VfloC32 tc7-VfloR64 tc7-VfloC64
tc7-contin tc7-cclo tc7-asubr
;;; tc7-subr-0 tc7-subr-1
tc7-cxr
;;; tc7-subr-3 tc7-subr-2
tc7-subr-2x tc7-subr-1o tc7-subr-2o tc7-lsubr-2
;;; tc7-lsubr
tc7-smob tc-free-cell tc16-flo tc-flo tc-dblr tc-dblc
tc16-bigpos tc16-bigneg tc16-port tc-inport tc-outport tc-ioport
tc-inpipe tc-outpipe smobfuns numsmob sys-protects cur-inp cur-outp
listofnull undefineds nullvect nullstr symhash progargs transcript
def-inp def-outp rootcont sys-protects upcase downcase symhash-dim
heap-size stack-start-ptr heap-org freelist gc-cells-collected
gc-malloc-collected gc-ports-collected cells-allocated linum
errjmp-ok ints-disabled sig-deferred alrm-deferred han-sig han-alrm
must-malloc ilength s-read s-write s-newline s-make-string
s-make-vector s-list s-string s-vector repl-driver newsmob lthrow repl
gc-end gc-start growth-mon scm_iprin1 scm_intprint scm_iprlist lputc lputs
lfwrite time-in-msec my-time init-tables init-storage init-subrs
init-features init-iprocs init- init-scl init-io init-repl init-time
init-signals ignore-signals unignore-signals init-eval init-sc2
free-storage init-unif uvprin1 markcdr free0 warn wta everr sysintern
;;; intern
sym2vcell makstr
;;; make-subr
;;; makfromstr
closure makprom force
makarb tryarb relarb ceval prolixity gc gc-for-newcell tryload cons2
;;; acons
resizuve cons2r lnot booleanp eq equal consp cons nullp
setcar setcdr listp list length append reverse list-ref memq memv
member assq assv assoc symbolp symbol2string string2symbol numberp exactp
inexactp eqp lessp zerop positivep negativep oddp evenp scm_max scm_min sum
product difference lquotient scm_abs remainder lremainder modulo lgcd llcm
number2string
;;; string2number
makdbl istr2flo mkbig long2big dbl2big
ilong2str iflo2str floprint bigprint int2dbl charp char-lessp chci-eq
chci-lessp char-alphap char-nump char-whitep char-upperp char-lowerp
char2int int2char char-upcase char-downcase stringp make-string
string st-length st-ref st-set st-equal stci-equal st-lessp
stci-lessp substring st-append vectorp make-vector
vector
vector-length vector-ref vector-set for-each procedurep apply map
call-cc copytree
;;; eval
throwval quit input-portp output-portp
cur-input-port cur-output-port open-file open-pipe close-port
close-pipe read-char peek-char eof-objectp scm_write scm_display
scm_newline scm_write-char
file-position file-set-position scm_file-position scm_getenv prog-args
makacro makmacro makmmacro
remove ash round array-ref array_ref
sin cos tan asin acos atan sinh cosh tanh asinh acosh atanh sqrt expt
log abs exp
;; verbose copy-tree @copy-tree
last-pair subml submr subfl ;from sc2.c
))
;;; NB! Your scheme file must not contain symbols which end with
;;; the third elements of the following defines appended
;;; with an integer. The same holds for the case where "-" is written
;;; instead of "_". In case your scheme file contains any offending
;;; symbols, replace them either in your file or replace the offending
;;; strings in the following defines.
;;;
;;; E.g. it is not allowed to have symbols like: my__12, spec-tmp-var3,
;;; foo-inst1, foo_inst5, bar-aux2.
;;;
;;; E.g. it is allowed to have symbols like: my__x, spec_tmp_var,
;;; foo-inst1x, foo_inst_5, bar-aux-spec.
(define *local-var-infix* "__")
(define *new-var-name* "new_var")
(define *tmp-var-name* "tmp_var")
(define *new-parameter-prefix* "npar__")
(define *new-fun-infix* "_aux")
(define *new-letfun-infix* "_fn")
(define *new-instfun-infix* "_inst")
(define *new-constant-prefix* "const_")
(define *closure-name-suffix* "_cl")
(define *closure-vector-name* "clargsv_")
;;; The following are names for the additional scheme functions
;;; nonkeyword-make-promise and nonkeyword-force.
;;; If your scheme file contains a function
;;; with these names already, you must change the following names.
(define *make-promise-function* 'nonkeyword_make-promise)
(define *force-function* 'nonkeyword_force)
;;; The following two will be names for the additional scheme functions
;;; map1 and for-each1. If your scheme file contains any functions with
;;; such names already, you must change the following names.
(define *map1-function* 'map1)
(define *for-each1-function* 'for-each1)
;;; The following name is not allowed to occur in your scheme file,
;;; neither is _ allowed.
(define *new-closure-var* "newclosure")
;;; The following is appended to symbols (not variables!) in your scheme
;;; file. Thus your scheme file should not contain variables or symbols
;;; ending with the value of *symbol-name-postfix*. If needed, change
;;; *symbol-name-postfix* from "_symb" to some other string.
(define *symbol-name-postfix* "_symb")
;;; The following is appended to higher-order function names in your scheme
;;; file which should be accessible from the interpreter. Thus your scheme
;;; file should not contain variables or symbols
;;; ending with the value of *export-hof-postfix*. If needed, change
;;; *export-hof-postfix* from "_exporthof" to some other string.
(define *export-hof-postfix* "_exporthof")
;;; The following is needed for exportable functions which do not
;;; have a type available in scm and need a special wrapper-function
;;; to pass variables supplied by the interpreter. The wrapper function
;;; name for some function foo is foo_wrapper, unless you change
;;; the following define.
(define *wrapper-postfix* "_wrapper")
;;; The following is appended to those function names in your scheme
;;; which are passed in the file to functions defined out of file
;;; or to append: in other words, passed to interpreter
(define *interpreter-suffix* "_interpreter")
;;; The following is appended to names of stable vectors, to
;;; denote the precalculated VELTS(x) part of a stable vector x.
(define *st-vector-postfix* "_velts0")
;;; The following is appended to names of closure procedures, giving
;;; the C-only static SCM variable name
(define *closure-proc-suffix* "_clproc0")
;;; The following is a string which is prepended to the name of your
;;; scheme file (without .scm) to form a name of a function generated
;;; to initialize non-function defined variables in your scheme file.
(define *init-globals-prefix* "init_globals_")
;;; The following is a string which is prepended to the name of your
;;; scheme file (without .scm) to form a name of a function generated
;;; to perform all top-level computations in your scheme file.
(define *top-actions-prefix* "top_actions_")
;;; The following is a string which is prepended to the name of your
;;; scheme file (without .scm) to form a name of a main initialization
;;; function for your file.
(define *init-fun-prefix* "init_")
;;; The following is a name of a variable which may be defined to
;;; the list of inlinable functions in your scheme file.
(define *inline-declare* 'compile-inline)
;;; The following is a name of a variable which may be defined to
;;; the list of inlinable variables in your scheme file.
(define *inline-vars-declare* 'compile-inline-vars)
;;; The following is a name of a variable which has to be defined to
;;; make hobbit compile numeric procedures for all numbers as default,
;;; not just integers:
(define *allnumbers-declare* 'compile-allnumbers)
;;; The following is a name of a variable which has to be defined to
;;; make hobbit assume all procedures may be redefined.
(define *all-funs-modified-declare* 'compile-all-proc-redefined)
;;; The following is a name of a variable which has to be defined to
;;; make hobbit assume all procedures may be redefined.
(define *new-funs-modified-declare* 'compile-new-proc-redefined)
;;; The following is a name of a variable which may be defined to
;;; the list of exportable functions in your scheme file.
(define *export-declare* 'compile-export)
;;; The following is a name of a variable which may be defined to
;;; the list of stable vector names (never-assigned except the first
;;; initialization, not even by let or as local variables) in your
;;; scheme file.
(define *stable-vectors-declare* 'compile-stable-vectors)
;;; The following is a name of a variable which may be defined to
;;; the list of uninterned fast global vars (never holding nonimmediate values,
;;; ie not char, bool or short int). These vars are NOT accessible
;;; by the interpreter! They are used directly as C vars, without the GLOBAL
;;; (ie * op) prefix.
(define *fast-vars-declare* 'compile-uninterned-variables)
;;; The following two are default names for the single argument
;;; of the closure function and the variable which is assigned its
;;; first element.
(define *closurefun-arg* 'closurearg_0)
(define *closurefun-arg-car* 'closurearg_car_0)
;;; NB! The following determine the replacements for symbols
;;; allowed in scheme variables but not in C variables.
;;; Be careful with your scheme variables to avoid
;;; name clashes! E.g. if you have scheme variables
;;; bar--plus_, bar-+ and bar_+, they will all be converted to
;;; the same C variable bar__plus_
;;; In case of need feel free to change the replacement table.
;;; You may also wish to change the scheme function
;;; display-c-var, which performs the conversion.
;;;
;;; *global-postfix* determines the string to be appended to
;;; variable names surrounded by *-s. The surrounding *-s
;;; are dropped. E.g. *special-flag* will be converted to
;;; special_flag_global
;;; *char-replacements* determine the replacement strings
;;; for characters not allowed in C variables. E.g. foo!?
;;; will be converted to foo_excl__pred_
(define *global-postfix* "_global")
(define *char-replacements*
'((#\+ "_plus_")
(#\- "_")
(#\@ "_at_")
(#\. "_dot_")
(#\* "_star_")
(#\/ "_slash_")
(#\\ "_backsl_"); Added by M.Ward:
(#\< "_less_")
(#\= "_equal_")
(#\> "_grtr_")
(#\! "_excl_")
(#\? "_pred_")
(#\: "_colon_")
(#\$ "_dollar_")
(#\% "_percent_")
(#\_ "_")
(#\& "_and_")
(#\~ "_tilde_")
(#\^ "_exp_")
(#\[ "_obrckt_")
(#\] "_cbrckt_")
(#\| "_vbar_")))
;;; *c-indent* is the one-level indentation for C statements.
;;; There is no indentation for C expressions.
(define *c-indent* " ")
;;; *c-infix-surround* is put before and after each infix C operator.
;;; The sensible alternative to default "" is " " or #\space.
(define *c-infix-surround* "")
;;; The following are some obvious C constants. *c-null* is the
;;; C object corresponding to scheme '().
(define *c-true* 1)
(define *c-false* 0)
(define *c-null* "EOL")
(define *scm-type* "SCM")
(define *unspecified* '**unspecified**) ; you may change it
;;; NB! Your scheme file must not contain any third symbols
;;; of the following defines. If it does, replace the
;;; offending symbol either in your file or in the following
;;; defines (the compiler must contain the replacement anywhere
;;; else).
(define *function* '**function**)
(define *higher-order-call* '**higher-order-call**)
(define *higher-order-flag* #f)
(define *dummy* '**dummy**)
(define *not?* '**not?**)
(define *and?* '**and**)
(define *or?* '**or**)
(define *open-file-function* '**open-file-function**)
(define *set-current-input-port-function*
'**set-current-input-port-function**)
(define *set-current-output-port-function*
'**set-current-output-port-function**)
(define *num-s->c* '**num-s->c**)
(define *num-c->s* '**num-c->s**)
(define *bool-s->c* '**bool-s->c**)
(define *bool-c->s* '**bool-c->s**)
(define *char-c->s* '**char-c->s**)
(define *float-c->s* '**float-c->s**)
(define *tailrec* '**tailrec**)
(define *c-fetch* '**c-fetch**)
(define *c-adr* '**c-adr**)
(define *op-if* '**op-if**)
(define *op-begin* '**op-begin**)
(define *op-let* '**op-let**)
(define *do-not* '**do-not**)
(define *return* '**return**) ; NB! do not change this!!!
(define *goto-tailrec* '**goto-tailrec**)
(define *mark-tailrec* '**mark-tailrec**)
(define *define-constant* '**define-constant**)
(define *actual-c-string* '**actual-c-string**)
(define *actual-c-expr* '**actual-c-expr**)
(define *actual-c-int* '**actual-c-int**)
(define *actual-c-eval* '**actual-c-eval**)
(define *special-pseudoquote* '**special-pseudoquote**)
(define *global-access* '**global-access**)
(define *sysapply* '**sysapply**)
(define *listofnull* '**listofnull**)
(define *velts-function* '**velts-function**)
(define *st-vector-set* '**st-vector-set**)
(define *st-vector-ref* '**st-vector-ref**)
(define *make-cclo* '**make-cclo**)
(define *special-scm->c-functions*
(list
*function*
*higher-order-call*
*dummy*
*not?*
*and?*
*or?*
*open-file-function*
*set-current-input-port-function*
*set-current-output-port-function*
*num-s->c*
*num-c->s*
*bool-s->c*
*bool-c->s*
*char-c->s*
*float-c->s*
*tailrec*
*c-fetch*
*c-adr*
*op-if*
*op-begin*
*op-let*
*do-not*
*return*
*goto-tailrec*
*mark-tailrec*
*define-constant*
*actual-c-string*
*actual-c-int*
*actual-c-eval*
*special-pseudoquote*
*global-access*
*listofnull*
*velts-function*
*st-vector-set*
*st-vector-ref*
*sysapply*
*make-cclo*
*unspecified*))
;;; *intern-function* must be a C function taking a C string
;;; and its length (C int) which builds a new scheme symbol
;;; and returns it.
;;; *makfromstr-function* must be a C function taking a C string
;;; and its length (C int) which builds a new scheme string
;;; and returns it.
;;; *string->number-function* must be a C function taking a scheme string
;;; and a radix (scheme int) which builds a new scheme number
;;; and returns it.
;;; Instead of using such special functions it is possible to
;;; change the compiler functions make-symbol-constant and
;;; make-string-constant instead.
(define *intern-function* 'intern)
(define *intern-symbol-function* 'intern)
(define *makfromstr-function* 'makfromstr)
(define *string->number-function* 'string2number)
(define *c-eval-fun* 'eval)
(define *internal-c-functions*
(list *intern-function* *makfromstr-function*
*intern-symbol-function* *string->number-function* *c-eval-fun*))
(define *prohibited-funs* '())
;;; *type-converters* is a list of scheme<->C representation
;;; converters.
(define *type-converters*
(list *num-s->c* *num-c->s* *bool-s->c* *bool-c->s*
*char-c->s* *float-c->s*))
;;; The following four defines specify functions which will either
;;; take or return (or both) C numbers or booleans. They
;;; are actually set in set-primitive-tables.
;;;
;;; *num-arg-c-funs* is a set of scheme functions which will be
;;; converted to analogous C functions (provided
;;; *reckless-arithmetic* is #t) and which take C numbers
;;; as arguments.
;;; *num-res-c-funs* is a set of scheme functions which will
;;; converted to analogous C functions (provided
;;; *reckless-arithmetic* is #t) and which give C numbers
;;; as results.
;;; *bool-arg-c-funs* is a set of scheme functions which will always be
;;; converted to analogous C functions
;;; and which take C booleans (int 0 or non-0) as arguments.
;;; *bool-res-c-funs* is a set of scheme functions which will be
;;; converted to analogous C functions (some only if
;;; *reckless-arithmetic* is #t) and which give C booleans
;;; as results.
(define *num-arg-c-funs* '())
(define *always-num-arg-c-funs* '())
(define *num-res-c-funs* '())
(define *bool-arg-c-funs* '())
(define *always-bool-res-c-funs* '())
(define *bool-res-c-funs* '())
;;; cxr-functions is a set of allowed cxr functions. You may
;;; extend it if you wish.
(define *cxr-funs*
'(car cdr
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
;=================================================================
;
; global variable defs
;
;=================================================================
;;; the following variable determines whether floats or ints are used
(define *floats-flag* #f) ; must be #f in this version
;;; The following variables control error-checking performed by
;;; the resulting C program and numerical operations.
(define *reckless-arithmetic-flag* #t) ; MUST be #t in this version
(define *reckless-access-flag* #t) ; MUST be #t in this version
;;; The following variable controls optimizations of integer
;;; arithmetic for scheme<->C type conversions.
(define *optimize-arithmetic* #f) ; MUST be #f in this version
(define *splitted-init-function-names* '())
(define *splitted-topaction-function-names* '())
(define *map1-needed-flag* #f)
(define *for-each1-needed-flag* #f)
(define *inline-funs* '())
(define *inline-vars* '())
(define *top-actions-list* '())
(define *inline-funs-data* '())
(define *inline-vars-data* '())
(define *c-port* '())
(define *char-replacements-lists* '())
(define *tmp-var-max* 500)
(define *initial-defs* '())
(define *passed-defs* '())
(define *output-defs* '())
(define *new-funs-list* '())
(define *fun-arities-alist* '())
(define *to-do-fun-list* '())
(define *via-interpreter-defined* '())
(define *non-directcomp-list* '())
(define *current-fun-name* 'foo)
(define *current-formal-args* '())
(define *current-formal-argslist* '())
(define *tailrec-flag* #f)
(define *tmp-vars* '())
(define *new-fun-nr* 0)
(define *new-fun-names* '())
(define *higher-ordr-flag* #f)
(define *higher-order-args* '())
(define *higher-order-funs* '())
(define *higher-order-templates* '())
(define *new-parameter-nr* '0)
(define *make-new-ho-data* '())
(define *dot-arg-funs* '())
(define *dot-arg-templates* '())
(define *new-instnr* '0)
(define *new-primitive-instnr* '0)
(define *local-vars* '())
(define *new-constant-list* '())
(define *symbol-constant-table* '())
(define *interpreter-funname-table* '())
(define *new-constant-num* 0)
(define *passed-ho-dot-instfuns* '())
(define *passed-closure-funs* '())
(define *free-vars-list* '())
(define *global-vars-list* '())
(define *var-make-list* '())
(define *symbol-list* '())
(define *unknown-functions* '())
(define *unknown-vars* '())
(define *local-parameters* '())
(define *top-level-funs* '())
(define *export-functions* '())
(define *export-table* '())
(define *wrapper-table* '())
(define *stable-vector-names* '())
(define *fast-vars-list* '())
(define *closure-var-vectornames* '())
(define *lifted-closures-to-do* '())
(define *lifted-trivial-closure-names* '())
(define *lifted-closure-names* '())
(define *liftable-hof-names* '())
(define *non-liftable-hof-names* '())
(define *special-c-vars* '())
(define *closure-name-nr* 0)
(define *closure-vector-name-nr* 0)
(define *liftable-hof-database* '())
(define *letrec-closure-nr* 0)
(define *letrec-closures* '())
(define *letrec-closure-init* '())
(define *not-all-liftable-names* '())
(define *all-funs-modified-flag* #f)
(define *new-funs-modified-flag* #f)
(define *primitives* '())
(define *symbol-and-fun-list* '())
(define *hobbit-declaration-vars* '())
;;; the definition of force is used in case 'delay' is
;;; found inside the program
(define *force-definition*
(list
'define
*force-function*
'(lambda (object) (object))))
;;; the definition of make-promise is used in case 'delay' is
;;; found inside the program
(define *make-promise-definition*
(list
'define
*make-promise-function*
'(lambda (proc)
(let ((result-ready? #f)
(result #f))
(lambda ()
(if result-ready?
result
(let ((x (proc)))
(if result-ready?
result
(begin (set! result-ready? #t)
(set! result x)
result)))))))))
;;; a word of warning: the following two defs must not contain any
;;; of the following: (cond, case, not, or, and, let, letrec, map, for-each)
;;; and must not contain lambda-terms or clashing variables in let*.
;;; There might be other analogous restrictions as well!
(define *map1-definition*
(list 'define
*map1-function*
`(lambda (fn lst)
(let* ((res '()) (res-end res))
(do ()
((,*not?* (pair? lst)) res)
(if (null? res)
(begin (set! res (cons (fn (car lst)) '()))
(set! res-end res))
(begin (set-cdr! res-end (cons (fn (car lst)) '()))
(set! res-end (cdr res-end))))
(set! lst (cdr lst)))))))
(define *for-each1-definition*
(list 'define
*for-each1-function*
`(lambda (fn lst)
(do ()
((,*not?* (pair? lst)) ,*unspecified*)
(fn (car lst))
(set! lst (cdr lst))))))
;=================================================================
;
; top level
;
;=================================================================
;@ exported symbol hobbit.
(define (hobbit file . files)
(let* ((tmpname "hobbit.tmp"))
(if *build-intermediate-files*
(begin (require 'pretty-print)))
(if *expand-macros-flag*
(begin (require 'defmacroexpand)
(require 'pprint-file)))
(provide 'hobbit)
(if (or (member '"scmhob.scm" (cons file files))
(member '"scmhob" (cons file files)))
(report-error "The file scmhob.scm is not allowed to be compiled!"))
(init-global)
;; check for defmacros
(if *expand-macros-flag*
(if (not (find-if (lambda (x) (file-contains-defmacro? x))
(cons file files)))
(set! *expand-macros-flag* #f)))
(set! *initial-defs* '())
(if *expand-macros-flag* (for-each defmacro:load (cons file files)))
(for-each (lambda (x)
(if *infomessages-flag*
(begin (newline)
(display "Starting to read ") (display x)))
(read-compiled-file x tmpname))
(cons file files))
(if *infomessages-flag* (newline))
(compile-defs file (reverse *initial-defs*))))
(define (file-contains-defmacro? str)
(let ((foundflag #f)
(expr '())
(port (if (file-exists? str)
(open-input-file str)
(if (file-exists? (string-append str ".scm"))
(open-input-file (string-append str ".scm"))
(report-error "Could not find file " str)))))
(if port
(do ()
((or foundflag (eof-object? expr)) foundflag)
(set! foundflag (expr-contains-defmacro? expr))
(set! expr (read port)))
#f)))
(define (expr-contains-defmacro? expr)
(cond ((not (pair? expr)) #f)
((or (eq? 'quote (car expr)) (eq? 'quasiquote (car expr))) #f)
((eq? 'defmacro (car expr)) #t)
(else (pair-find-if (lambda (x) (expr-contains-defmacro? x)) expr))))
(define (read-compiled-file file tmpname)
(let* ((iport (if (file-exists? file)
(open-input-file file)
(if (file-exists? (string-append file ".scm"))
(open-input-file (string-append file ".scm"))
(report-error "Could not find file " file))))
(oport (if *expand-macros-flag* (open-output-file tmpname) '()))
(def #t))
(if *infomessages-flag* (newline))
(if *expand-macros-flag*
(begin
(if *infomessages-flag*
(begin
(display "Starting macroexpansion building the ")
(display "temporary file ")
(display tmpname) (display #\.) (newline)))
(pprint-filter-file iport defmacro:expand* oport)
(close-output-port oport)
(set! iport (open-input-file tmpname))))
(do ()
((eof-object? def)
(close-input-port iport))
(set! def (read iport))
(cond ((eof-object? def))
((and (pair? def)
(or (eq? 'load (car def))
(eq? 'require (car def))))
(report-warning "ignoring a load on top level: " def))
(else
(set! *initial-defs* (cons def *initial-defs*)))))))
(define (compile-defs file deflst)
(let ()
(set! file (descmify file))
;; - - - - adding primitives delay and force, if neccessary - - - - -
(if (find-if (lambda (x) (in-fun-position? 'delay x)) deflst)
(set! deflst
(append deflst
(append
(list *force-definition*)
(list *make-promise-definition*)))))
;; - - - - - initial checks and flag-setting, sorting out the toplevel
;; builds *top-level-names*, *modified-primitives* and
;; *modified-top-level-names*:
(make-top-level-namelist! deflst)
;; sorts out the toplevel:
(sort-out-toplevel! deflst file)
(if (not *floats-flag*)
(compute-floats-flag! deflst #t))
(if *infomessages-flag*
(if *floats-flag*
(begin
(display "Generic (slow) arithmetic assumed: ")
(display *floats-flag*)
(display " found.")
(newline))
(begin
(display "Bounded integer (fast) arithmetic assumed.")
(newline))))
(set-primitive-tables)
(set! *passed-defs* '())
;; - - - - - vars-simplification pass - -
(set! *to-do-fun-list*
(map vars-simplify-wholedef *to-do-fun-list*))
;; - - - - - finding liftable hof-s - - -
(set! *liftable-hof-names* '())
(set! *non-liftable-hof-names* '())
(for-each (lambda (x)
(if (and (pair? (caddr x))
(eq? 'lambda (caaddr x))
(liftable-hof? (caddr x) (cadr x)))
(set! *liftable-hof-names*
(cons (cadr x) *liftable-hof-names*))))
*to-do-fun-list*)
(for-each lift-analyse-def! *to-do-fun-list*)
(if *infomessages-flag*
(begin (newline) (display "** Pass 1 completed **")))
(if *build-intermediate-files*
(let ((fport (open-output-file (string-append file '".anl"))))
(for-each (lambda (x) (pretty-print x fport) (newline fport))
*to-do-fun-list*)
(close-output-port fport)
(newline)
(display "analyzed & marked definitions file ")
(display (string-append file '".anl"))
(display " is built.")))
;; initial analysis passes completed
;; - - - - - building closures - - - - - - - -
(do ((part *to-do-fun-list* part))
((null? part))
(set! *lifted-closures-to-do* '())
(set! *passed-defs*
(cons (try-closure-making-def(car part)) *passed-defs*))
(set! part (append *lifted-closures-to-do* (cdr part))))
(set! *to-do-fun-list* (reverse *passed-defs*))
(for-each lift-unmark-def! *to-do-fun-list*)
(if *infomessages-flag*
(begin (newline) (display "** Pass 2 completed **")))
(if *build-intermediate-files*
(let ((fport (open-output-file (string-append file '".cls"))))
(for-each (lambda (x) (pretty-print x fport) (newline fport))
*to-do-fun-list*)
(close-output-port fport)
(newline)
(display "closures-building file ")
(display (string-append file '".cls"))
(display " is built.")))
;; closurebuilding pass completed
;; - - - - - - - - flattening starts - - - - - - - - -
(set! *passed-defs* '())
(for-each (lambda (def)
(set! *passed-defs*
(append (reverse (flatten-wholedef def))
*passed-defs*)))
*to-do-fun-list*)
(if (not (or (pair? *export-functions*) (null? *export-functions*)))
(set! *export-functions* *top-level-funs*)
(set! *export-functions*
(intersection *export-functions* *top-level-funs*)))
(if *map1-needed-flag*
(set! *passed-defs* (cons *map1-definition* *passed-defs*)))
(if *for-each1-needed-flag*
(set! *passed-defs* (cons *for-each1-definition* *passed-defs*)))
(set! *passed-defs* (reverse *passed-defs*))
(if *infomessages-flag*
(begin (newline) (display "** Pass 3 completed **")))
(if *build-intermediate-files*
(let ((fport (open-output-file (string-append file '".flt"))))
(for-each (lambda (x) (pretty-print x fport) (newline fport))
*passed-defs*)
(close-output-port fport)
(newline)
(display "lambda-lifted & normalized definitions file ")
(display (string-append file '".flt"))
(display " is built.")))
(set! *to-do-fun-list* *passed-defs*)
;; lambda-lifting & normalization finished
;; - - - - - - - - - - lift statements - - - - - - - - - - -
(set! *passed-defs* '())
(do ((x 1 1))
((null? *to-do-fun-list*))
(let ((tmp (car *to-do-fun-list*)))
(set! *to-do-fun-list* (cdr *to-do-fun-list*))
(set! *passed-defs* (append (lift-statements-wholedef tmp)
*passed-defs*))))
(set! *passed-defs* (reverse *passed-defs*))
(if *infomessages-flag*
(begin (newline) (display "** Pass 4 completed **")))
(if *build-intermediate-files*
(let ((fport (open-output-file (string-append file '".stt"))))
(for-each (lambda (x) (pretty-print x fport) (newline fport))
*passed-defs*)
(close-output-port fport)
(newline)
(display "statement-lifted definitions file ")
(display (string-append file '".stt"))
(display " is built.")))
(set! *to-do-fun-list* *passed-defs*)
;; statement-lifting pass finished
;; - - - - - - - hof-dot-corrections starts - - - - - -
(set! *passed-ho-dot-instfuns* '())
(set! *passed-defs* '())
(do ((x 1 1))
((null? *to-do-fun-list*))
(let ((tmp (car *to-do-fun-list*)))
(set! *to-do-fun-list* (cdr *to-do-fun-list*))
(if (not (memq (cadr tmp) *passed-ho-dot-instfuns*))
(set! *passed-defs* (cons (ho-dot-wholedef tmp)
*passed-defs*)))))
(set! *passed-defs*
(reverse (append (build-wrappers *passed-defs*)
*passed-defs*)))
(build-wrapped-interpreter-table)
(if *infomessages-flag*
(begin (newline) (display "** Pass 5 completed **")))
(if *build-intermediate-files*
(let ((fport (open-output-file (string-append file '".hod"))))
(for-each (lambda (x) (pretty-print x fport) (newline fport))
*passed-defs*)
(close-output-port fport)
(newline)
(display "higher-order-&-dot-arglist corrected definitions file ")
(display (string-append file '".hod"))
(display " is built.")))
(set! *to-do-fun-list* *passed-defs*)
;; hof-dot correction finished
;; - - - - - - - typing & constant-correcting - - - - - - - - - -
(set! *passed-defs* '())
(do ((x 1 1))
((null? *to-do-fun-list*))
(let ((tmp (car *to-do-fun-list*)))
(set! *to-do-fun-list* (cdr *to-do-fun-list*))
(set! *passed-defs* (cons (type-const-wholedef tmp)
*passed-defs*))))
(for-each (lambda (x)
(let ((tmp (assq x *extra-hobbit-primitive-defs*)))
(if (and tmp (not (memq x *modified-primitives*)))
(begin
(set! *passed-defs*
(cons (type-const-wholedef
(list 'define x (cadr tmp)))
*passed-defs*))
(if (memq x *extra-hobbit-dot-primitives*)
(set! *dot-arg-templates*
(cons (list x 'x) *dot-arg-templates*)))))))
*unknown-vars*)
(set! *passed-defs* (reverse *passed-defs*))
(init-export-funs! file)
(make-initialization-function! file)
(if *infomessages-flag*
(begin (newline) (display "** Pass 6 completed **")))
(if *build-intermediate-files*
(let ((fport (open-output-file (string-append file '".typ"))))
(for-each (lambda (x) (pretty-print x fport) (newline fport))
*passed-defs*)
(close-output-port fport)
(newline)
(display "typing & constants - corrected definitions file ")
(display (string-append file '".typ"))
(display " is built.")
(newline)))
(set! *to-do-fun-list* *passed-defs*)
;; typing & constant-correcting pass finished
;; - - - - - - - - building .c and .h files - - - - - - - - - -
(set! *passed-defs* '())
(let ((fport (open-output-file (string-append file '".c"))))
(display "#include " fport)
(display #\" fport)
(display (string-append file '".h") fport)
(display #\" fport)
(newline fport)
(newline fport)
(for-each (lambda (x) (write-c-wholefun x fport))
*to-do-fun-list*)
(close-output-port fport)
(if *infomessages-flag*
(begin (newline) (newline)
(display "C source file ")
(display (string-append file '".c"))
(display " is built.")
(newline))))
(let ((fport (open-output-file (string-append file '".h"))))
(display-header fport)
(newline fport)
(for-each (lambda (x)
(write-fun-declaration (cadr x) fport))
*to-do-fun-list*)
(for-each (lambda (x)
(if (not (memq x *fast-vars-list*))
(write-c-*declaration x fport)))
*global-vars-list*)
(for-each (lambda (x)
(write-c-*declaration (cdr x) fport))
*interpreter-funname-table*)
(for-each (lambda (x)
(write-c-*declaration (make-closure-scmobj-name x) fport))
*symbol-and-fun-list*)
(for-each (lambda (x)
(write-c-static-declaration
(make-closure-scmobj-name x) fport))
*lifted-trivial-closure-names*)
(for-each (lambda (x)
(write-c-static-declaration
(make-closure-scmobj-name x) fport))
*lifted-closure-names*)
(for-each (lambda (x) (write-c-static-declaration (cadr x) fport))
(reverse *symbol-constant-table*))
(for-each (lambda (x)
(if (not (pair? (cadr x)))
(write-c-static-declaration (cadr x) fport)))
(reverse *new-constant-list*))
(for-each (lambda (x)
(write-c-*declaration
(string->symbol
(string-append (symbol->string x) *st-vector-postfix*))
fport))
(reverse *stable-vector-names*))
(for-each (lambda (x) (write-c-static-declaration x fport))
(reverse *fast-vars-list*))
(newline fport)
(close-output-port fport)
(if *infomessages-flag*
(begin
(display "C header file ")
(display (string-append file '".h"))
(display " is built.")
(newline))))
;; .c and .h files built
;; - - - - - - - - - extra compilation info: - - - - - - - - -
(set! *via-interpreter-defined*
(append *via-interpreter-defined*
(map car *switch-args-table*)
*cxr-funs*
*non-compiled-primitives*
*interpreter-defined-vars*
(map car *floats-s->c-fun-table*)))
;; - - - - - - - - - redefinability info: - - - - - - - - -
(if *infomessages-flag* (newline))
(cond
((not *infomessages-flag*))
(*all-funs-modified-flag*
(newline)
(display "All procedure names are assumed to be redefinable (slow).")
(newline))
(*new-funs-modified-flag*
(newline)
(display
"All new procedure names are assumed to be redefinable (slow).")
(newline)
(if (not (null? *modified-primitives*))
(begin
(display
"These primitive procedure names are assumed to be redefinable (slow):")
(newline)
(display *modified-primitives*)
(newline))))
(else
(if (not (null? *modified-primitives*))
(begin
(display
"These primitive procedure names are assumed to be redefinable (slow):")
(newline)
(display *modified-primitives*)
(newline)))
(if (not (null? (set-difference *modified-top-level-names*
(union
*global-vars-list* *fast-vars-list*))))
(begin
(display
"These top level procedure names are assumed to be redefinable (slow):")
(newline)
(display (set-difference *modified-top-level-names*
(union
*global-vars-list* *fast-vars-list*)))
(newline)))))
;; - - - - - - - - - hof-info: - - - - - - - - - - - - - -
(cond
((not *infomessages-flag*))
((not (null? *non-liftable-hof-names*))
(display
"These top level higher order procedures are not clonable (slow):")
(newline)
(display *non-liftable-hof-names*)
(newline)))
;; - - - - - - - - - closures-info: - - - - - - - - - - - - -
(cond
((not *infomessages-flag*))
((not (null? *not-all-liftable-names*))
(display
"These top level procedures create non-liftable closures (slow):")
(newline)
(display *not-all-liftable-names*)
(newline)))
;; - - - - - - - - - undefined-info: - - - - - - - - - - -
(if (and *infomessages-flag*
(not (null? (set-difference (set-difference *unknown-functions*
*modified-top-level-names*)
(union *global-vars-list*
(union *fast-vars-list*
*via-interpreter-defined*))))))
(begin (newline)
(display
"These nonprimitive procedures are assumed to be defined externally:")
(newline)
(display
(set-difference (set-difference *unknown-functions*
*modified-top-level-names*)
(union *global-vars-list*
(union *fast-vars-list*
*via-interpreter-defined*))))
(newline)))
(if (and *infomessages-flag*
(not (null? (set-difference (set-difference *unknown-vars*
*modified-top-level-names*)
*via-interpreter-defined*))))
(begin (newline)
(display
"These variables undefined (but used) in your file were defined:")
(newline)
(display (set-difference (set-difference *unknown-vars*
*modified-top-level-names*)
*via-interpreter-defined*))
(newline)))
(if *infomessages-flag* (newline))))
(define (sort-out-toplevel! lst file)
(set! *to-do-fun-list* '())
(set! *inline-funs* '())
(set! *inline-vars* '())
(set! *global-vars-list* '())
(set! *fast-vars-list* '())
(set! *var-make-list* '())
(set! *non-directcomp-list* '())
(set! *top-actions-list* '())
(do ((part lst (cdr part)))
((null? part))
(let ((el (car part))
(tmp '()))
(cond
((and (list? el)
(eq? 'begin (car el)))
(set! part (append el (cdr part))))
((and (pair? el)
(or (eq? 'load (car el))
(eq? 'require (car el))))
(report-warning "ignoring a load on top level: " el))
((or (not (pair? el))
(not (eq? 'define (car el)))
(null? (cdr el))
(not (list? el)))
;; (report-error "the compiled file contains a non-definition: "
;; el)
;; (if (pair? el)
;; (set! *non-directcomp-list* (cons el *non-directcomp-list*)))
(set! *top-actions-list* (cons el *top-actions-list*)))
;; from here everything starts with 'define'.
((or (pair? (cadr el)) ; the standard direct function def
(and (not (null? (cddr el)))
(pair? (caddr el))
(eq? 'lambda (car (caddr el)))))
;;(and (pair? (cddr el))
;; (pair? (caddr el))
;; (memq (car (caddr el)) '(let let* letrec))
;; (pair? (cddr (caddr el)))
;; (pair? (caddr (caddr el)))
;; (eq? 'lambda (car (caddr (caddr el)))))
;; ;(not (find-if (lambda (x) (not (eq? (car x) (cadr x))))
;; ; (cadr (caddr el))))
(let* ((def (normalize-top-define el))
(funname (cadr def))
(tmp '()))
(if (modified-fun? funname)
(set! *top-actions-list*
(cons (cons 'set! (cdr def)) *top-actions-list*))
(begin
(set! tmp (list *special-pseudoquote* funname))
(set! *top-actions-list* (cons tmp *top-actions-list*))
(set! *to-do-fun-list* (cons def *to-do-fun-list*))))))
;; the following filters out macro defs:
((and (pair? el)
(pair? (cdr el))
(eq? 'define (car el))
(not (pair? (cadr el)))
(pair? (cddr el))
(pair? (caddr el))
(eq? 'let (caaddr el))
(pair? (car (my-last-pair (caddr el))))
(eq? 'defmacro:transformer (caar (my-last-pair (caddr el))))))
;; - - - from here everything will be a define-expression - - - -
;;((and (pair? (caddr el))
;; (not (eq? 'quote (car (caddr el))))
;; (not (eq? 'quasiquote (car (caddr el)))))
;; (set! *top-actions-list*
;; (cons (cons 'set! (cdr el)) *top-actions-list*)))
;;(set! tmp (make-pair-constant (caddr el)))
;;(set! *top-actions-list*
;; (cons (list 'set! (cadr el) (list *actual-c-eval* tmp))
;; *top-actions-list*))
;; (set! *via-interpreter-defined*
;; (cons (cadr el) *via-interpreter-defined*))
;; - - - - - - - - - declarations-part starts - - - - - - - - -
((eq? (cadr el) *inline-declare*)
(set! *inline-funs* (append (cadr (caddr el)) *inline-funs*)))
((eq? (cadr el) *inline-vars-declare*)
(set! *inline-vars* (append (cadr (caddr el)) *inline-vars*)))
((eq? (cadr el) *allnumbers-declare*)
(set! *floats-flag* el))
((eq? (cadr el) *all-funs-modified-declare*)
(set! *all-funs-modified-flag* #t))
((eq? (cadr el) *new-funs-modified-declare*)
(set! *new-funs-modified-flag* #t))
((eq? (cadr el) *stable-vectors-declare*)
(set! *stable-vector-names*
(append (cadr (caddr el))
*stable-vector-names*)))
((eq? (cadr el) *fast-vars-declare*)
(set! *fast-vars-list*
(append (cadr (caddr el)) *fast-vars-list*)))
((eq? (cadr el) *export-declare*)
(set! *export-functions*
(append (cadr (caddr el))
(if (pair? *export-functions*)
*export-functions*
'()))))
;; - - - - - - - - -declarations-part ends - - - - - - - - - -
((null? (cddr el)) ; form: (define foo)
(set! *global-vars-list* (cons (cadr el) *global-vars-list*))
(set! *top-actions-list*
(cons (list 'set! (cadr el) *unspecified*)
*top-actions-list*))
(if (not (memq (cadr el) *fast-vars-list*))
(set! *var-make-list*
(cons `(set!
,(cadr el)
(,*c-adr* (cdr (,*intern-function*
(,*actual-c-string*
,(symbol->string (cadr el)))
,(string-length
(symbol->string (cadr el)))))))
*var-make-list*))))
(else ; form: (define foo )
(set! *global-vars-list* (cons (cadr el) *global-vars-list*))
(set! *top-actions-list*
(cons (cons 'set! (cdr el)) *top-actions-list*))
;;(if (symbol? (caddr el))
;; ; the last el of define is a symbol; call intern:
;; (set! *top-actions-list*
;; (cons `(set!
;; ,(cadr el)
;; ,(list *actual-c-eval*
;; (make-pair-constant-aux (caddr el))))
;;(,*c-adr* (cdr (,*intern-function*
;; (,*actual-c-string*
;; ,(symbol->string (caddr el)))
;; (,*actual-c-int*
;; ,(string-length
;; (symbol->string
;; (caddr el)))))))
;; *top-actions-list*))
;; ; the last el of define is a non-list non-symbol:
;; (set! *top-actions-list*
;; (cons (cons 'set! (cdr el))
;; *top-actions-list*)))
;;(set! *via-interpreter-defined*
;; (cons (cadr el) *via-interpreter-defined*))
(if (not (memq (cadr el) *fast-vars-list*))
(set! *var-make-list*
(cons `(set!
,(cadr el)
(,*c-adr* (cdr (,*intern-function*
(,*actual-c-string*
,(symbol->string (cadr el)))
,(string-length
(symbol->string (cadr el)))))))
*var-make-list*)))))))
;;(if (not (null? *top-actions-list*))
;; (set! *to-do-fun-list*
;; (cons (list 'define
;; (make-globals-name file)
;; (list* 'lambda
;; '()
;; (reverse (cons '() *top-actions-list*))))
;; *to-do-fun-list*)))
;; - - - - - - - - making the top-actions-fun - - - - - - -- - -
(let* ((init-all-list (reverse *top-actions-list*))
(init-all-splitted-lists (list '()))
(fname '())
(init-all-splitted-processed '())
(top-actions-fun '())
(split-nr 0))
;; split up the big list
(do ((n 1 (+ n 1)))
((null? init-all-list))
(if (> n *max-auxfun-size*)
(begin
(set! n 1)
(set! init-all-splitted-lists
(cons '() init-all-splitted-lists))))
(set! init-all-splitted-lists
(cons (cons (car init-all-list) (car init-all-splitted-lists))
(cdr init-all-splitted-lists)))
(set! init-all-list (cdr init-all-list)))
;;(display "init-all-splitted-lists: ")
;;(newline)
;;(pretty-print init-all-splitted-lists)
;;(newline)
(set! init-all-splitted-lists (reverse init-all-splitted-lists))
;; process each sublist
(do ((lst init-all-splitted-lists (cdr lst)))
((null? lst))
(set! split-nr (+ 1 split-nr))
(set! fname
(string->symbol
(string-append *top-actions-prefix*
(string-append
(number->string split-nr)
"_"
file))))
(set! *splitted-topaction-function-names*
(cons fname *splitted-topaction-function-names*))
(set! init-all-splitted-processed
(cons
(list 'define
fname
(list 'lambda
'()
(list* 'let* '() (reverse (car lst)))))
init-all-splitted-processed)))
;;(display "init-all-splitted-processed: ")
;;(newline)
;;(pretty-print init-all-splitted-processed)
;;(newline)
(set! top-actions-fun
(list
'define (make-top-actions-funname file)
(list* 'lambda '()
(map list
(reverse *splitted-topaction-function-names*)))))
(set! *to-do-fun-list*
(cons top-actions-fun
(append init-all-splitted-processed
*to-do-fun-list*))))
;; - - - - - - - - top-actions-fun is made and kept - - - - - - -
(set! *to-do-fun-list* (reverse *to-do-fun-list*))
(set! *non-directcomp-list* (reverse *non-directcomp-list*))
(set! *inline-funs-data* '())
(set! *inline-vars-data* '())
(do ((part *inline-vars* (cdr part)))
((null? part))
(let ((tmp (member-if (lambda (x)
(and (pair? x)
(eq? 'set! (car x))
(eq? (cadr x) (car part))))
*top-actions-list*)))
(if tmp
(set! *inline-vars-data*
(cons (cdar tmp) *inline-vars-data*))
(set! *inline-vars* (remove (car part) *inline-vars*)))))
(do ((part *inline-funs* (cdr part)))
((null? part))
(let ((tmp (member-if (lambda (x)
(or (eq? (cadr x) (car part))
(and (pair? (cadr x))
(eq? (caadr x) (car part)))))
*to-do-fun-list*)))
(if tmp
(set! *inline-funs-data*
(cons (list (car part)
(make-inline-body (car tmp)))
*inline-funs-data*))
(set! *inline-funs* (remove (car part) *inline-funs*))))))
(define (normalize-top-define term)
(if (or (not (pair? (cdr term)))
(not (pair? (cddr term))))
(report-error "incorrect define: " term))
(if (pair? (cadr term))
`(define ,(caadr term) (lambda ,(cdadr term) ,@(cddr term)))
term))
(define (make-inline-body def)
(let* ((tmp (rename-vars
(lettify-lambdas
(normalize-defines
(compile-quasiquote def))
200
#t)))
(term (caddr tmp))
(body (cddr term)))
(cond ((not (list? (cadr term)))
(report-error "inline-function has a non-list arglist: "
def))
((null? body)
(report-error "inline-function has no body: " def))
((null? (cdr body))
term)
(else
(list (car term)
(cadr term)
(cons 'begin body))))))
(define (make-initialization-function! file)
(let* ((nondefines
(map make-pair-constant *non-directcomp-list*))
(vector-elts
(map (lambda (x)
`(set! ,(string->symbol
(string-append
(symbol->string x)
*st-vector-postfix*))
(,*velts-function*
(,*global-access* ,x))))
*stable-vector-names*))
(init-all-list
(append
(init-closure-funs file *passed-defs*)
(init-interpretable-funs)
*var-make-list*
(reverse *symbol-list*)
(reverse *new-constant-list*)
(if (null? *top-actions-list*)
'()
(list
(list (make-top-actions-funname file))))
vector-elts
(map (lambda (x)
(list *c-eval-fun* x))
nondefines)))
(init-all-splitted-lists (list '()))
(init-all-splitted-processed '())
(split-nr 0)
(main-fun '())
(fname '()))
;;(display "init-all-list: ")
;;(newline)
;;(pretty-print init-all-list)
;;(newline)
;; split up the big list
(do ((n 1 (+ n 1)))
((null? init-all-list))
(if (> n *max-auxfun-size*)
(begin
(set! n 1)
(set! init-all-splitted-lists
(cons '() init-all-splitted-lists))))
(set! init-all-splitted-lists
(cons (cons (car init-all-list) (car init-all-splitted-lists))
(cdr init-all-splitted-lists)))
(set! init-all-list (cdr init-all-list)))
;;(display "init-all-splitted-lists: ")
;;(newline)
;;(pretty-print init-all-splitted-lists)
;;(newline)
(set! init-all-splitted-lists (reverse init-all-splitted-lists))
;; process each sublist
(do ((lst init-all-splitted-lists (cdr lst)))
((null? lst))
(set! split-nr (+ 1 split-nr))
(set! fname
(string->symbol
(string-append *init-fun-prefix*
(string-append
(number->string split-nr)
"_"
file))))
(set! *splitted-init-function-names*
(cons fname *splitted-init-function-names*))
(set! init-all-splitted-processed
(cons
(list 'define
fname
(list 'lambda
'()
(list* 'let* '() (reverse (car lst)))))
init-all-splitted-processed)))
;;(display "init-all-splitted-processed: ")
;;(newline)
;;(pretty-print init-all-splitted-processed)
;;(newline)
(set! main-fun
(list 'define
(string->symbol (string-append *init-fun-prefix* file))
(list 'lambda
'()
(list* 'let* '()
'(set! no-symhash-gc #t)
(map list
(reverse *splitted-init-function-names*))))))
(set! *passed-defs*
(append *passed-defs*
(append (reverse init-all-splitted-processed)
(list main-fun))))))
(define (init-export-funs! file)
(let* ((res '())
(topactions-funname (make-top-actions-funname file)))
(set! *export-functions*
(remove (make-globals-name file) *export-functions*))
(for-each
(lambda (x)
(set! res (init-export-fun-aux x))
(if res
(for-each
(lambda (name)
(let ((fun (car (member-if
(lambda (x) (eq? (cadr x) name))
*passed-defs*))))
(subst-term-equal!
res (list *special-pseudoquote* (cadr x)) fun)))
(cons topactions-funname
*splitted-topaction-function-names*))))
*passed-defs*)))
(define (init-export-fun-aux def)
(if (not (memq (cadr def) *export-functions*))
#f
(let* ((tmp1 (assq (cadr def) *export-table*))
(tmp (assq (cadr def) *wrapper-table*))
(arity '())
(flag '())
(res '()))
(cond (tmp (set! arity 'x))
((begin
(set! arity (assq (cadr def) *dot-arg-templates*))
(and arity
(symbol? (cadr arity))))
(set! arity 'x))
(else (set! arity (cadr (caddr def)))))
(cond ((symbol? arity)
(set! flag 'tc7_lsubr))
(else
(set! flag
(cadr (assq (length arity)
'((0 tc7_subr_0)
(1 tc7_subr_1)
(2 tc7_subr_2)
(3 tc7_subr_3)))))))
(set! res
(list 'make_subr
(list *actual-c-string*
(if (memq (cadr def) *symbol-and-fun-list*)
(symbol->string
(make-closure-scmobj-name (cadr def)))
(symbol->string (cadr def))))
flag
(if tmp
(cadr tmp)
(if tmp1
(cadr tmp1)
(cadr def)))))
(if (memq (cadr def) *symbol-and-fun-list*)
(set! res `(set! (,*global-access*
,(make-closure-scmobj-name (cadr def)))
,res)))
res)))
(define (init-closure-funs file defs)
(append
(map
(lambda (funname)
(let* ((procname (make-closure-scmobj-name funname))
(def-part '()))
(set! def-part (member-if (lambda (x) (eq? funname (cadr x))) defs))
`(set! ,procname ,(init-export-fun-aux (car def-part)))))
*lifted-trivial-closure-names*)
(map
(lambda (funname)
(let* ((procname (make-closure-scmobj-name funname)))
`(set! ,procname (make_subr (,*actual-c-string*
,(symbol->string procname))
tc7_lsubr
,funname))))
*lifted-closure-names*)))
(define (init-interpretable-funs)
(map
(lambda (x)
(list 'set! (cdr x)
`(,*c-adr* (cdr (,*intern-function*
(,*actual-c-string*
,(symbol->string (car x)))
,(string-length
(symbol->string (car x))))))))
*interpreter-funname-table*))
(define (make-globals-name file)
(string->symbol (string-append *init-globals-prefix* file)))
(define (make-top-actions-funname file)
(string->symbol (string-append *top-actions-prefix* file)))
(define (descmify str)
(let ((len (string-length str)))
(if (and (> len 4)
(string-ci=? ".scm" (substring str (- len 4) len)))
(substring str 0 (- len 4))
str)))
(define (display-header fport)
(define *h-port* fport)
(define (headerline s)
(display s *h-port*)
(newline *h-port*))
(if *floats-flag* (headerline "#define FLOATS"))
(headerline "#include \"scmhob.h\"")
(headerline ""))
(define (init-global)
(set! *floats-flag* #f)
(set! *tmp-vars* '())
(set! *new-fun-names* '())
(set! *new-fun-nr* 0)
(set! *higher-order-funs* '())
(set! *higher-order-templates* '())
(set! *new-parameter-nr* '0)
(set! *dot-arg-funs* '())
(set! *dot-arg-templates* '())
(set! *new-instnr* '0)
(set! *new-primitive-instnr* '0)
(set! *new-constant-list* '())
(set! *symbol-constant-table* '())
(set! *interpreter-funname-table* '())
(set! *new-constant-num* 0)
(set! *char-replacements-lists* '())
(set! *splitted-init-function-names* '())
(set! *splitted-topaction-function-names* '())
(set! *map1-needed-flag* #f)
(set! *for-each1-needed-flag* #f)
(set! *symbol-list* '())
(set! *unknown-functions* '())
(set! *unknown-vars* '())
(set! *top-level-funs* '())
(set! *inline-funs* '())
(set! *inline-vars* '())
(set! *export-functions* #f)
(set! *export-table* '())
(set! *wrapper-table* '())
(set! *stable-vector-names* '())
(set! *fast-vars-list* '())
(set! *closure-var-vectornames* '())
(set! *lifted-closures-to-do* '())
(set! *lifted-trivial-closure-names* '())
(set! *lifted-closure-names* '())
(set! *via-interpreter-defined* '())
(set! *special-c-vars* '())
(set! *closure-name-nr* 0)
(set! *closure-vector-name-nr* 0)
(set! *liftable-hof-database* '())
(set! *letrec-closure-nr* 0)
(set! *not-all-liftable-names* '())
(set! *all-funs-modified-flag* #f)
(set! *new-funs-modified-flag* #f)
(set! *symbol-and-fun-list* '())
(set! *hobbit-declaration-vars*
(list *inline-declare* *inline-vars-declare* *allnumbers-declare*
*all-funs-modified-declare* *new-funs-modified-declare*
*export-declare* *stable-vectors-declare* *fast-vars-declare*))
(set! *primitives*
(append (map car *switch-args-table*)
*cxr-funs*
*non-compiled-primitives*
(map car *floats-s->c-fun-table*)))
(do ((nr 1 (+ 1 nr)))
((= nr *tmp-var-max*))
(set! *tmp-vars*
(cons (string->symbol (string-append *tmp-var-name*
(number->string nr)))
*tmp-vars*)))
(set! *tmp-vars* (reverse *tmp-vars*)))
;; set-primitive-tables sets tables differently for the float and non-float case
(define (set-primitive-tables)
(set! *num-arg-c-funs*
(append
(if *badivsgns-flag*
'()
'(quotient remainder))
(if *floats-flag*
'()
'(/))
'(logxor lognot logsleft logsright
= < > <= >= + - *
%= %< %> %<= %>= %+ %- %* %/)))
(set! *always-num-arg-c-funs*
;;if *badivsgns-flag*
;; '()
;; '(quotient remainder))
'(logxor lognot logsleft logsright
%= %< %> %<= %>= %+ %- %* %/))
(set! *num-res-c-funs*
(append
(if *badivsgns-flag*
'()
'(quotient remainder))
(if *floats-flag*
'()
'(/))
'(logxor lognot logsleft logsright
+ - *
%+ %- %* %/)))
(set! *bool-arg-c-funs*
(cons *and?* (cons *or?* (list *not?*))))
(set! *always-bool-res-c-funs*
(cons *and?*
(cons *or?*
(cons *not?*
'(boolean? symbol? char? vector? pair?
string? number? complex?
eq? char=? null?
%eqv? %zero? %negative? %positive? %number?
%= %< %> %<= %>= )))))
(set! *bool-res-c-funs*
(cons *and?*
(cons *or?*
(cons *not?*
'(boolean? symbol? char? vector? pair?
string? number? real? rational? complex?
integer?
eq? eqv? char=? null? zero? negative? positive?
= < > <= >=
%eqv? %zero? %negative? %positive? %number?
%= %< %> %<= %>= ))))))
(define (report-warning . lst)
(display #\newline)
(display "COMPILER WARNING: ")
(display #\newline)
(for-each display lst)
(display #\newline))
;;=================================================================
;;
;; final conversion to C
;;
;;=================================================================
(define (write-c-*declaration var port)
(set! *c-port* port)
(display-c *scm-type*)
(display-c #\space)
(display-c #\*)
(display-c-var var)
(display-c #\;)
(display-c-newline))
(define (write-fun-declaration var port)
(set! *c-port* port)
(display-c *scm-type*)
(display-c #\space)
(display-c-var var)
(display-c "()")
(display-c #\;)
(display-c-newline))
(define (write-c-static-declaration var port)
(set! *c-port* port)
(display-c "static ")
(display-c *scm-type*)
(display-c #\space)
(display-c-var var)
(display-c #\;)
(display-c-newline))
(define (write-c-wholefun def port)
(let* ((fun (caddr def))
(top-let (caddr fun)))
(set! *c-port* port)
(set! *current-fun-name* (cadr def))
(display-c *scm-type*)
(display-c #\space)
(display-c-var (cadr def))
(display-c-lst (args->list (cadr fun)) #\( #f)
(display-c-newline)
(if (not (null? (cadr fun)))
(begin
(let ((scm-args (filter (lambda (x) (symbol? x)) (cadr fun)))
(fun-args (filter (lambda (x)
(and (pair? x) (eq? *function* (car x))))
(cadr fun)))
(ptr-args (filter (lambda (x)
(and (pair? x) (eq? *c-adr* (car x))))
(cadr fun))))
(if (not (null? ptr-args))
(begin
(display-c *scm-type*)
(display-c #\space)
(display-c-lst (map cadr ptr-args) #f #\*)
(display-c #\;)
(display-c-newline)))
(if (not (null? fun-args))
(begin
(display-c *scm-type*)
(display-c #\space)
(display-c-lst (map cadr fun-args) #f 'function)
(display-c #\;)
(display-c-newline)))
(if (not (null? scm-args))
(begin
(display-c *scm-type*)
(display-c #\space)
(display-c-lst scm-args #f #f)
(display-c #\;)
(display-c-newline))))))
(display-c #\{)
(display-c-newline)
(if (and (not (null? (cadr top-let)))
(find-if (lambda (x) (symbol? (car x))) (cadr top-let)))
(begin
(display-c-indent 1)
(display-c *scm-type*)
(display-c #\space)
(display-c-lst (filter (lambda (x) (symbol? x))
(map car (cadr top-let)))
#f #f)
(display-c #\;)
(display-c-newline)
(display-c-newline)))
(for-each (lambda (x)
(display-c-statement x 1))
(cddr top-let))
(display-c #\})
(display-c-newline)
(display-c-newline)))
(define (display-c x)
(display x *c-port*))
;;(define (write-c-string x)
;; (write x *c-port*))
(define (write-c-string x)
(display "\"" *c-port*)
(for-each
(lambda (c)
(cond
((eq? c #\nl) (display "\\n" *c-port*))
((eq? c #\") (display "\\\"" *c-port*))
((eq? c #\ht) (display "\\t" *c-port*))
((eq? c #\\) (display "\\\\" *c-port*))
(else (display c *c-port*))))
(string->list x))
(display "\"" *c-port*))
(define (display-c-newline)
(newline *c-port*))
(define (display-c-indent n)
(do ((m 0 (+ 1 m)))
((= n m))
(display-c *c-indent*)))
(define (display-c-lst lst par prefix)
(let ((separator #\,))
(cond ((char=? par #\()
(set! separator #\,)
(display-c #\())
((char=? par #\{)
(set! separator #\;)
(display-c #\{))
(else
(set! separator #\,)))
(if (not (null? lst))
(begin
(for-each (lambda (x)
(cond ((and (pair? x)
(eq? 'set! (car x))
(eq? 3 (length x))
(eq? *dummy* (caddr x))))
((or (char? prefix) (string? prefix))
(display-c prefix)
(display-c-expression x #t)
(display-c separator))
((eq? 'function prefix)
(display-c "(*")
(display-c-expression x #t)
(display-c ") ()")
(display-c separator))
(else
(display-c-expression x #t)
(display-c separator))))
(butlast lst 1))
(cond ((or (char? prefix) (string? prefix))
(display-c prefix)
(display-c-expression (car (my-last-pair lst)) #t))
((eq? 'function prefix)
(display-c "(*")
(display-c-expression (car (my-last-pair lst)) #t)
(display-c ") ()"))
(else
(display-c-expression (car (my-last-pair lst)) #t)))))
(cond ((char=? par #\()
(display-c #\)))
((char=? par #\{)
(display-c #\;)
(display-c #\})))))
(define (display-var var port)
(cond
((eq? *listofnull* var)
(display "listofnull" port))
((eq? *unspecified* var)
(display "UNSPECIFIED" port))
(else
(let* ((str (symbol->string var))
(char '())
(replacement '())
(len (string-length str))
(global-flag #f))
(if (and (symbol? var)
(char-numeric? (string-ref str 0)))
(display *c-num-symb-prefix* port))
(if (and (char=? #\* (string-ref str 0))
(char=? #\* (string-ref str (- len 1))))
(set! global-flag #t))
(do ((n 0 (+ 1 n)))
((= n len))
(set! char (string-ref str n))
(cond ((and global-flag
(or (= 0 n) (= n (- len 1))))
char) ; do nothing
((char-alphabetic? char)
(display (char-downcase char) port))
((char-numeric? char)
(display char port))
((begin
(set! replacement (assoc char *char-replacements*))
replacement)
(display (cadr replacement) port))
(else
(display char port))))
(cond ((memq var *c-keywords*)
(display *c-keyword-postfix* port))
(global-flag
(display *global-postfix* port)))))))
(define (display-c-var var)
(display-var var *c-port*))
(define (display-c-statement term n)
(let ()
(cond ((not (pair? term)))
;; (display-c-indent n)
;; (display-c #\;) ; empty operator
;; (display-c-newline))
((eq? 'if (car term))
(display-c-indent n)
(display-c "if (")
(display-c-expression (cadr term) #t)
(display-c #\))
(cond ((not (pair? (caddr term)))
(display-c #\space)
(display-c #\;) ; empty operator
(display-c-newline))
((and (not (eq? 'begin (car (caddr term))))
(not (eq? 'if (car (caddr term)))))
(display-c-newline)
(display-c-statement (caddr term) (+ 1 n)))
((eq? 'begin (car (caddr term)))
(display-c #\space)
(display-c #\{)
(display-c-newline)
(for-each (lambda (x) (display-c-statement x (+ 1 n)))
(cdar (cddr term)))
(display-c-indent n)
(display-c #\})
(display-c-newline))
((eq? 'if (car (caddr term)))
(display-c #\space)
(display-c #\{)
(display-c-newline)
(display-c-statement (car (cddr term)) (+ 1 n))
(display-c-indent n)
(display-c #\})
(display-c-newline))
(else (report-error "wrong syntax: " term)))
(cond ((null? (cdddr term))) ; do nothing
((not (pair? (car (cdddr term))))) ; do nothing
((and (not (eq? 'begin (caar (cdddr term))))
(not (eq? 'if (caar (cdddr term)))))
(display-c-indent n)
(display-c "else")
(display-c-newline)
(display-c-statement (car (cdddr term)) (+ 1 n)))
((eq? 'begin (caar (cdddr term)))
(display-c-indent n)
(display-c "else")
(display-c #\space)
(display-c #\{)
(display-c-newline)
(for-each (lambda (x) (display-c-statement x (+ 1 n)))
(cdar (cdddr term)))
(display-c-indent n)
(display-c #\})
(display-c-newline))
((eq? 'if (caar (cdddr term)))
(display-c-indent n)
(display-c "else")
(display-c-newline)
(display-c-statement (car (cdddr term)) n))))
((eq? (car term) *do-not*)
(display-c-indent n)
(display-c "for (")
(let ((lst1 (map (lambda (x) (list 'set! (car x) (cadr x)))
(cadr term)))
(lst2 (map (lambda (x) (list 'set! (car x) (caddr x)))
(filter (lambda (y) (not (null? (cddr y))))
(cadr term)))))
(if (not (null? lst1))
(display-c-lst lst1 #f #f))
(display-c #\;)
(if (> (length lst1) 1)
(begin
(display-c-newline) (display-c-indent n) (display-c " ")))
(display-c-expression (caar (cddr term)) #t)
(display-c #\;)
(if (and (> (length lst1) 1) (not (null? lst2)))
(begin
(display-c-newline) (display-c-indent n) (display-c " ")))
(if (not (null? lst2))
(display-c-lst lst2 #f #f))
(display-c #\))
(cond ((or (null? (cdddr term))
(not (find-if (lambda (x) (pair? x)) (cdddr term))))
(display-c #\space)
(display-c #\;) ; empty operator
(display-c-newline))
((null? (cdr (cdddr term)))
(if (or (eq? 'begin (caar (cdddr term)))
(eq? *op-begin* (caar (cdddr term))))
(begin
(display-c #\space)
(display-c #\{)
(display-c-newline)
(for-each (lambda (x)
(display-c-statement x (+ 1 n)))
(cdar (cdddr term)))
(display-c-indent n)
(display-c #\})
(display-c-newline))
(begin
(display-c-newline)
(display-c-statement (car (cdddr term))
(+ 1 n)))))
(else
(display-c #\space)
(display-c #\{)
(display-c-newline)
(for-each (lambda (x)
(display-c-statement x (+ 1 n)))
(cdddr term))
(display-c-indent n)
(display-c #\})
(display-c-newline)))))
((or (eq? (car term) 'begin) (eq? (car term) *op-begin*))
(display-c-indent n)
(display-c #\{)
(display-c-newline)
(for-each (lambda (x) (display-c-statement x (+ 1 n)))
(cdr term))
(display-c-indent n)
(display-c #\})
(display-c-newline))
((eq? (car term) *return*)
(display-c-indent n)
(display-c "return ")
(display-c-expression (cadr term) #t)
(display-c #\;)
(display-c-newline))
((or (eq? *tailrec* (car term)) (eq? *mark-tailrec* (car term)))
(display-c "tailrecursion:")
(display-c-newline))
((eq? *goto-tailrec* (car term))
(display-c-indent n)
(display-c "goto tailrecursion;")
(display-c-newline))
((and (eq? 'set! (car term))
(eq? *dummy* (caddr term)))) ; do nothing
(else
(display-c-indent n)
(display-c-expression term)
(display-c #\;)
(display-c-newline)))))
(define (display-c-expression term . no-par-flag)
(let ((fn (if (pair? term) (car term) '()))
(args (if (pair? term) (cdr term) '()))
(tmp #f))
(cond
((symbol? term)
(display-c-var term))
((number? term)
(display-c term)
(if *long-cast-flag* (display-c "L")))
((boolean? term)
(if term (display-c *c-true*) (display-c *c-false*)))
((char? term)
(if (printable-char? term)
(begin
(display-c #\')
(display-c term)
(display-c #\'))
(display-c (char->integer term))))
((null? term)
(display-c *c-null*))
((not (pair? term))
(report-error "wrong type of object for C: " term))
((and (eq? *bool-c->s* fn)
(boolean? (car args)))
(if (car args)
(display-c "BOOL_T")
(display-c "BOOL_F")))
((eq? *c-adr* fn)
(display-c #\&)
(display-c-expression (car args)))
((eq? *c-fetch* fn)
(display-c #\*)
(display-c-expression (car args)))
((eq? fn *higher-order-call*)
(display-c "(*")
(display-c-var (car args))
(display-c ")")
(display-c-lst (cdr args) #\( #f))
((eq? *function* fn)
(display-c-expression (car args)))
((or (eq? fn 'begin) (eq? fn *op-begin*))
(display-c-lst args #\( #f))
((eq? fn *op-if*)
(display-c #\()
(display-c-expression (car args))
(display-c " ? ")
(display-c-expression (cadr args))
(display-c " : ")
(display-c-expression
(if (null? (cddr args))
*unspecified*
(caddr args)))
(display-c #\)))
((eq? fn *actual-c-string*)
(display-c "(char *)")
(write-c-string (car args)))
((eq? fn *actual-c-expr*)
(display-c (car args)))
((eq? fn *actual-c-int*)
(display-c (car args)))
((eq? fn *actual-c-eval*)
(display-c "eval(")
(display-c-var (car args))
(display-c ")"))
((eq? 'set! fn)
(or (eq? *dummy* (cadr args))
(begin (display-c-expression (car args))
(display-c *c-infix-surround*)
(display-c "=")
(display-c *c-infix-surround*)
(display-c-expression (cadr args)))))
((begin (set! tmp (assq fn *switch-args-table*))
tmp)
(display-c-expression (cons (cadr tmp) (reverse args))))
((and (begin (set! tmp (assq fn *add-args-table*))
tmp)
(not (= (length args) (caddr tmp))))
(display-c-expression
(cons fn (append args (list (cadr tmp))))))
((begin (if (memq fn '(vector string))
(set! args (list (normalize-list-for-c args))))
#f)) ; never succeeds
((begin (set! tmp (if *floats-flag*
(assq fn *floats-s->c-fun-table*)
(assq fn *reckless-s->c-fun-table*)))
tmp)
(cond ((and (not (null? (cdddr tmp)))
(car (cdddr tmp)))
(if (or (null? no-par-flag)
(not (car no-par-flag)))
(display-c #\())
(display-c-expression (car args))
(display-c *c-infix-surround*)
(display-c (cadr tmp))
(display-c *c-infix-surround*)
(display-c-expression (cadr args))
(if (or (null? no-par-flag)
(not (car no-par-flag)))
(display-c #\))))
(else
(display-c (cadr tmp))
(display-c-lst args #\( #f))))
(else
(display-c-expression fn)
(display-c-lst args #\( #f)))))
(define (printable-char? chr)
(or (char-alphabetic? chr)
(char-numeric? chr)
(memq chr '(#\! #\@ #\$ #\% #\^ #\& #\* #\( #\)
#\_ #\+ #\| #\- #\=
#\{ #\} #\[ #\]
#\; #\, #\. #\/
#\: #\" #\~ #\< #\> #\?
#\space))))
(define *non-compiled-primitives*
'(apply call-with-current-continuation apply force delay load
map for-each list call-with-input-file call-with-output-file
open-input-file open-output-file with-input-from-file
with-output-to-file string-append
defmacro:expand*
sin cos tan asin acos atan sinh cosh tanh asinh acosh
sin cos tan asin acos atan sinh cosh tanh asinh acosh
atanh sqrt expt integer-expt))
(define *interpreter-defined-vars* '())
;; '(slib:features
;; most-positive-fixnum most-negative-fixnum))
;; defs in *extra-hobbit-primitive-defs* are used when the extra primitive
;; is passed as an argument.
(define *extra-hobbit-dot-primitives* '(%+ %- %* %/ %= %< %> %<= %>=))
(define *extra-hobbit-primitive-defs*
'((logsleft (lambda (x y) (**return** (ash x y))))
(logsright (lambda (x y) (**return** (ash x (- y)))))
(%+ (lambda (x)
(let* ((r 0))
(do ((l x (cdr x))) ((null? l) (**return** r))
(set! r (%+ r (car l)))))))
(%- (lambda (x)
(let* ((r 0))
(do ((l x (cdr x))) ((null? l) (**return** r))
(set! r (%- r (car l)))))))
(%* (lambda (x)
(let* ((r 1))
(do ((l x (cdr x))) ((null? l) (**return** r))
(set! r (%* r (car l)))))))
(%/ (lambda (x)
(let* ((r 1))
(do ((l x (cdr x))) ((null? l) (**return** r))
(set! r (%/ r (car l)))))))
(%= (lambda (x)
(let* ((r #t))
(do ((l x (cdr x)))
((or (not r) (null? l) (null? (cdr l))) (**return** r))
(if (not (%= (car l) (cadr l)))
(set! r #f))))))
(%< (lambda (x)
(let* ((r #t))
(do ((l x (cdr x)))
((or (not r) (null? l) (null? (cdr l))) (**return** r))
(if (not (%< (car l) (cadr l)))
(set! r #f))))))
(%> (lambda (x)
(let* ((r #t))
(do ((l x (cdr x)))
((or (not r) (null? l) (null? (cdr l))) (**return** r))
(if (not (%> (car l) (cadr l)))
(set! r #f))))))
(%>= (lambda (x)
(let* ((r #t))
(do ((l x (cdr x)))
((or (not r) (null? l) (null? (cdr l))) (**return** r))
(if (not (%>= (car l) (cadr l)))
(set! r #f))))))
(%<= (lambda (x)
(let* ((r #t))
(do ((l x (cdr x)))
((or (not r) (null? l) (null? (cdr l))) (**return** r))
(if (not (%<= (car l) (cadr l)))
(set! r #f))))))))
(define *switch-args-table*
'((char>? char? char-ci=? char<=?) (char-ci>=? char-ci<=?)
(string>? string? string-ci=? string-ci<=?) (string>=? string<=?)))
(define *add-args-table*
(append
(list
(list 'make-vector '() 2)
(list 'number->string (list *num-c->s* 10) 2)
(list 'string->number (list *num-c->s* 10) 2)
(list 'make-string (list *actual-c-expr* "MAKICHR(' ')") 2))
'((quit 1 1)
(read (current-input-port) 1)
(read-char (current-input-port) 1)
(peek-char (current-input-port) 1)
(write (current-output-port) 2)
(display (current-output-port) 2)
(newline (current-output-port) 1)
(write-char (current-output-port) 2))))
(define *standard-s->c-fun-table*
(append
(list (list 'force (symbol->string *force-function*) 1))
'((%eqv? "==" 2 #t #t)
(%zero? "ZERO_P" 1 #f #t)
(%positive? "POSITIVE_P" 1 #f #t)
(%negative? "NEGATIVE_P" 1 #f #t)
(%= "==" 2 #t #t)
(%< "<" 2 #t #t)
(%> ">" 2 #t #t)
(%<= "<=" 2 #t #t)
(%>= ">=" 2 #t #t)
(%+ "+" 2 #t #t)
(%- "-" 2 #t #t)
(%* "*" 2 #t #t)
(%/ "lquotient" 2 #f #f)
(cons "cons" 2) (car "CAR" 1) (cdr "CDR" 1)
(acons "acons" 3)
(list? "listp" 1) (length "length" 1) (append "append2" 2)
(reverse "reverse" 1) (list-tail "list_tail" 2) (list-ref "list_ref" 2)
(memq "memq" 2) (member "member" 2) (memv "memv" 2)
(assq "assq" 2) (assv "assv" 2) (assoc "assoc" 2)
(symbol->string "symbol2string" 1) (string->symbol "string2symbol" 1)
(system "lsystem" 1)
(verbose "prolixity" 1)
(copy-tree "copytree" 1)
(@copy-tree "copytree" 1)
(exact? "exactp" 1) (inexact? "inexactp" 1)
(odd? "oddp" 1) (even? "evenp" 1) (max "scm_max" 2) (min "scm_min" 2) (abs "scm_abs" 1)
(quotient "lquotient" 2) (remainder "lremainder" 2)
(modulo "modulo" 2) (gcd "lgcd" 2) (lcm "llcm" 2)
(exact->inexact "EX2IN_FUN" 1) (floor "FLOOR_FUN" 1)
(ceiling "CEILING_FUN" 1)
(truncate "TRUNCATE_FUN" 1) (round "ROUND_FUN" 1)
($sin "SIN_FUN" 1) ($cos "COS_FUN" 1) ($tan "TAN_FUN" 1)
($asin "ASIN_FUN" 1)
($acos "ACOS_FUN" 1) ($atan "ATAN_FUN" 1) ($sinh "SINH_FUN" 1)
($cosh "COSH_FUN" 1)
($tanh "TANH_FUN" 1) ($asinh "ASINH_FUN" 1) ($acosh "ACOSH_FUN" 1)
($atanh "ATANH_FUN" 1)
($sqrt "SQRT_FUN" 1) ($expt "EXPT_FUN" 2)
($log "LOG_FUN" 1) ($abs "ABS_FUN" 1) ($exp "EXP_FUN" 1)
(real-sin "SIN_FUN" 1) (real-cos "COS_FUN" 1) (real-tan "TAN_FUN" 1)
(real-asin "ASIN_FUN" 1) (real-acos "ACOS_FUN" 1) (real-atan "ATAN_FUN" 1)
(real-sinh "SINH_FUN" 1) (real-cosh "COSH_FUN" 1)
(real-tanh "TANH_FUN" 1) (real-asinh "ASINH_FUN" 1) (real-acosh "ACOSH_FUN" 1)
(real-atanh "ATANH_FUN" 1)
(real-sqrt "SQRT_FUN" 1) (real-expt "EXPT_FUN" 2)
(real-ln "LOG_FUN" 1) (real-exp "EXP_FUN" 1)
(inexact->exact "in2ex" 1)
(make-rectangular "makrect" 2) (make-polar "makpolar" 2)
(real-part "real_part" 1) (imag-part "imag_part" 1)
(magnitude "scm_magnitude" 1) (angle "angle" 1)
(number->string "number2string" 2) (string->number "string2number" 1)
(charinteger "CHAR2INT" 1) (integer->char "INT2CHAR" 1)
(char-upcase "CHAR_UPCASE" 1) (char-downcase "CHAR_DOWNCASE" 1)
(make-string "make_string" 2)
(string "string" 1)
(string-length "ST_LENGTH" 1)
(string-ref "ST_REF" 2)
(string-set! "st_set" 3)
(substring "substring" 3)
(string-append "st_append" 1)
(list->string "string" 1)
(string->list "string2list" 1)
(string-copy "string_copy" 1)
(string-fill! "string_fill" 2)
(string=? "st_equal" 2) (stringlist "vector2list" 1)
(list->vector "vector" 1)
(read "scm_read" 1)
(read-char "scm_read_char" 1)
(peek-char "scm_peek_char" 1)
(eof-object? "eof_objectp" 1)
(write "scm_write" 2)
(display "scm_display" 2)
(newline "scm_newline" 1)
(write-char "scm_write_char" 2)
(input-port? "input_portp" 1)
(output-port? "output_portp" 1)
(current-input-port "cur_input_port" 0)
(current-output-port "cur_output_port" 0)
(close-input-port "close_port" 1)
(close-output-port "close_port" 1)
(get-internal-run-time "my_time" 0)
(quit "quit" 1)
(abort "abrt" 0)
(restart "restart" 0)
(chdir "chdir" 1)
(delete-file "del_fil" 1)
(rename-file "ren_fil" 2))))
;;; ()
(define *reckless-s->c-fun-table*
(append
(if *badivsgns-flag*
'()
'((quotient "/" 2 #t #t)
(remainder "%" 2 #t #t)
(/ "/" 2 #t #t)))
(list
(list *sysapply* "apply" 3 #f #f)
(list *make-cclo* "makcclo" 2 #f #f)
(list *global-access* "GLOBAL" 1 #f #f)
(list *velts-function* "VELTS" 1 #f #f)
(list *st-vector-ref* "STBL_VECTOR_REF" 2 #f #f)
(list *st-vector-set* "STBL_VECTOR_SET" 3 #f #f)
(list *not?* "!" 1 #f #t)
(list *and?* "&&" 2 #t #t)
(list *or?* "||" 2 #t #t)
(list *open-file-function* "open_file" 2 #f #f)
(list *set-current-input-port-function* "set_inp" 1 #f #f)
(list *set-current-output-port-function* "set_outp" 1 #f #f)
(list *num-s->c* "INUM" 1 #f #f)
(list *num-c->s* "MAKINUM" 1 #f #f)
(list *bool-s->c* "NFALSEP" 1 #f #f)
(list *bool-c->s* "SBOOL" 1 #f #f)
(list *char-c->s* "MAKICHR" 1 #f #f))
'((boolean? "BOOLEAN_P" 1 #f #t)
(symbol? "SYMBOL_P" 1 #f #t)
(char? "CHAR_P" 1 #f #t)
(vector? "VECTOR_P" 1 #f #t)
(pair? "PAIR_P" 1 #f #t)
(number? "NUMBER_P" 1 #f #t)
(complex? "NUMBER_P" 1 #f #t)
(real? "NUMBER_P" 1 #f #t)
(rational? "NUMBER_P" 1 #f #t)
(integer? "INTEGER_P" 1 #f #t)
(string? "STRING_P" 1 #f #t)
(procedure? "procedurep" 1 #f #t)
(not "NOT" 1 #f #f)
(eq? "==" 2 #t #t)
(eqv? "==" 2 #t #t)
(char=? "==" 2 #t #t)
(null? "NULL_P" 1 #f #t)
(zero? "ZERO_P" 1 #f #t)
(positive? "POSITIVE_P" 1 #f #t)
(negative? "NEGATIVE_P" 1 #f #t)
(logand "&" 2 #t #t)
(logior "|" 2 #t #t)
(logxor "^" 2 #t #t)
(lognot "~" 1 #f #t)
(logsleft "<<" 2 #t #t)
(logsright ">>" 2 #t #t)
(= "==" 2 #t #t)
(< "<" 2 #t #t)
(> ">" 2 #t #t)
(<= "<=" 2 #t #t)
(>= ">=" 2 #t #t)
(+ "+" 2 #t #t)
(- "-" 2 #t #t)
(* "*" 2 #t #t)
(/ "lquotient" 2 #f #f)
(set-car! "SET_CAR" 2 #f #t)
(set-cdr! "SET_CDR" 2 #f #t)
(vector-set! "VECTOR_SET" 3 #f #t)
(vector-ref "VECTOR_REF" 2 #f #t)
(equal? "equal" 2))
*standard-s->c-fun-table*))
(define *floats-s->c-fun-table*
(append
(list
(list *sysapply* "apply" 3 #f #f)
(list *make-cclo* "makcclo" 2 #f #f)
(list *global-access* "GLOBAL" 1 #f #f)
(list *velts-function* "VELTS" 1 #f #f)
(list *st-vector-ref* "STBL_VECTOR_REF" 2 #f #f)
(list *st-vector-set* "STBL_VECTOR_SET" 3 #f #f)
(list *not?* "!" 1 #f #t)
(list *and?* "&&" 2 #t #t)
(list *or?* "||" 2 #t #t)
(list *open-file-function* "open_file" 2 #f #f)
(list *set-current-input-port-function* "set_inp" 1 #f #f)
(list *set-current-output-port-function* "set_outp" 1 #f #f)
(list *num-s->c* "INUM" 1 #f #f)
(list *num-c->s* "MAKINUM" 1 #f #f)
(list *bool-s->c* "NFALSEP" 1 #f #f)
(list *bool-c->s* "SBOOL" 1 #f #f)
(list *char-c->s* "MAKICHR" 1 #f #f))
'((boolean? "BOOLEAN_P" 1 #f #t)
(symbol? "SYMBOL_P" 1 #f #t)
(char? "CHAR_P" 1 #f #t)
(vector? "VECTOR_P" 1 #f #t)
(pair? "PAIR_P" 1 #f #t)
(number? "NUMBERP" 1 #f #t) ;;; diff from the int case; scm.h macro
(complex? "NUMBERP" 1 #f #t) ;;; not in the int case; scm.h macro
(real? "realp" 1 #f #t) ;;; not in the int case;
(rational? "realp" 1 #f #t) ;;; not for int; ONLY for FLOATS
(integer? "intp" 1 #f #t) ;;; not for int; ONLY for FLOATS
(string? "STRING_P" 1 #f #t)
(procedure? "procedurep" 1 #f #t)
(not "NOT" 1 #f #f)
(eq? "==" 2 #t #t)
(eqv? "eqv" 2 #f #t);; diff for int
(char=? "==" 2 #t #t)
(null? "NULL_P" 1 #f #t)
(zero? "zerop" 1 #f #t);; diff for int
(positive? "positivep" 1 #f #t);; diff for int
(negative? "negativep" 1 #f #t);; diff for int
(logand "&" 2 #t #t)
(logior "|" 2 #t #t)
(logxor "^" 2 #t #t)
(lognot "~" 1 #f #t)
(logsleft "<<" 2 #t #t)
(logsright ">>" 2 #t #t)
(= "eqp" 2 #f #t);; diff for int
(< "lessp" 2 #f #t);; diff for int
(> "greaterp" 2 #f #t);; diff for int
(<= "leqp" 2 #f #t);; diff for int
(>= "greqp" 2 #f #t);; diff for int
(+ "sum" 2 #f #t);; diff for int
(- "difference" 2 #f #t);; diff for int
(* "product" 2 #f #t);; diff for int
(/ "divide" 2 #f #f);; diff for int
(quotient "lquotient" 2 #f #f)
(remainder "lremainder" 2 #f #f)
(set-car! "SET_CAR" 2 #f #t)
(set-cdr! "SET_CDR" 2 #f #t)
(vector-set! "VECTOR_SET" 3 #f #t)
(vector-ref "VECTOR_REF" 2 #f #t)
(equal? "equal" 2))
*standard-s->c-fun-table*))
(define (primitive? fn)
(or (member fn *cxr-funs*)
(if *floats-flag*
(assq fn *floats-s->c-fun-table*)
(assq fn *reckless-s->c-fun-table*))
(assq fn *switch-args-table*)
(assq fn *add-args-table*)
(member fn '(list append cond case do let let* letrec define
if and or map for-each))))
(define (fixed-arity-primitive? fn)
(or (member fn *cxr-funs*)
(and (if *floats-flag*
(assq fn *floats-s->c-fun-table*)
(assq fn *reckless-s->c-fun-table*))
(not (assq fn *associative-fun-table*))
(not (assq fn *comparison-fun-table*))
(not (assq fn *add-args-table*))
(not (member fn '(list append cond case do let let* letrec
define if and or map for-each
< > <= = >= + * - /
%< %> %<= %= %>= %+ %* %- %/ ))))
(assq fn *switch-args-table*)))
(define (primitive-arity fn)
(let ((tmp (if *floats-flag*
(assq fn *floats-s->c-fun-table*)
(assq fn *reckless-s->c-fun-table*))))
(cond (tmp (caddr tmp))
((memq fn *cxr-funs*) 1)
(else #f))))
;===================================================================
;
; introducing type conversion,
; collecting constants,
; moving variables to top-let.
;
;===================================================================
(define (type-const-wholedef term)
(set! *local-vars* '())
(set! *local-parameters*
(map (lambda (x) (if (pair? x) (cadr x) x))
(cadr (caddr term))))
(set! *current-fun-name* (cadr term))
(let* ((tmp (map type-const-pass (cddr (caddr term))))
(tmp2 (list 'lambda
(cadr (caddr term))
(cons 'let*
(cons (map (lambda (x) (list x *dummy*))
*local-vars*)
(begins->list tmp))))))
(list (car term) (cadr term) tmp2)))
(define (begins->list lst)
(let ((res '()))
(do ((part lst (cdr part)))
((null? part))
(if (and (pair? (car part))
(or (eq? 'begin (caar part))
(eq? *op-begin* (caar part))))
(set! res (append (reverse (begins->list (cdar part))) res))
(set! res (cons (car part) res))))
(reverse res)))
(define (type-const-pass-res term)
(cond
((string? term)
(make-string-constant term))
((char? term)
(list *char-c->s* term))
((vector? term)
(make-vector-constant term))
((number? term)
(if (and (integer? term)
(exact? term)
(<= term most-positive-fixnum)
(>= term most-negative-fixnum))
(list *num-c->s* term)
(begin
(if (not *floats-flag*)
(report-warning
"exact arithmetic assumed but a nonexact number encountered: " term))
(make-number-constant term))))
((symbol? term)
(cond ((or (memq term *local-parameters*)
(memq term *local-vars*)
(memq term *special-c-vars*)
(memq term *special-scm->c-functions*))
term)
((memq term *fast-vars-list*)
term)
((memq term *interpreter-defined-vars*)
(list *global-access* term))
((memq term *global-vars-list*)
(list *global-access* term))
((or (member-if (lambda (x) (eq? term (cadr x)))
*new-constant-list*)
(member-if (lambda (x) (eq? term (cadr x)))
*symbol-constant-table*)
(in-file-defined? term))
term)
(else (or (memq term *unknown-vars*)
(set! *unknown-vars* (cons term *unknown-vars*)))
(list *global-access* (make-unknown-constant term)))))
((boolean? term)
(list *bool-c->s* term))
((null? term)
'())
((not (pair? term))
(report-error "disallowed object: " term))
((eq? *special-pseudoquote* (car term))
term)
((eq? *actual-c-string* (car term))
term)
((eq? *actual-c-int* (car term))
term)
((eq? *actual-c-eval* (car term))
term)
((eq? 'quote (car term))
(cond ((or (string? (cadr term))
(vector? (cadr term))
(number? (cadr term))
(boolean? (cadr term))
(char? (cadr term))
(null? (cadr term)))
(type-const-pass (cadr term)))
((symbol? (cadr term))
(make-symbol-constant (cadr term)))
((pair? (cadr term))
(make-pair-constant (cadr term)))
(else
(report-error "disallowed object: " term))))
((and
*reckless-arithmetic-flag*
(not (modified-fun? (car term)))
(or (memq (car term) *always-num-arg-c-funs*)
(and (not *floats-flag*)
(memq (car term) *num-arg-c-funs*))))
(let* ((tmp (map type-const-pass (cdr term)))
(tmp2
(cons (car term)
(map (lambda (x)
(if (and (pair? x)
(eq? (car x) *num-c->s*))
(cadr x)
(list *num-s->c* x)))
tmp))))
(cond ((memq (car term) *num-res-c-funs*)
(list *num-c->s* tmp2))
((memq (car term) '(= < <= > >= %= %< %<= %> %>=))
(cond
((and (pair? (cadr tmp2))
(pair? (caddr tmp2))
(eq? (car (cadr tmp2)) (car (caddr tmp2)))
(eq? *num-s->c* (car (cadr tmp2))))
(list *bool-c->s*
(cons (car term) (map cadr (cdr tmp2)))))
((or (and (not (pair? (cadr tmp2)))
(pair? (caddr tmp2)))
(and (not (pair? (caddr tmp2)))
(pair? (cadr tmp2))))
(list *bool-c->s* (cons (car term) tmp)))
(else
(list *bool-c->s* tmp2))))
((and (not *floats-flag*)
(memq (car term) *bool-res-c-funs*))
(list *bool-c->s* tmp2))
((memq (car term) *always-bool-res-c-funs*)
(list *bool-c->s* tmp2))
(else
tmp2))))
((and (or (memq (car term) '(eq? char=? %eqv? %=))
(and (not *floats-flag*)
(or (eq? 'eqv? (car term))
(eq? '= (car term)))))
(not (modified-fun? (car term))))
(let ((tmp (map type-const-pass (cdr term))))
(if (and (pair? (car tmp))
(memq (caar tmp) *type-converters*)
(pair? (cadr tmp))
(memq (caadr tmp) *type-converters*))
(list *bool-c->s* (cons (car term) (map cadr tmp)))
(list *bool-c->s* (cons (car term) tmp)))))
((and (memq (car term) *bool-arg-c-funs*)
(not (modified-fun? (car term))))
(let* ((tmp (map type-const-pass (cdr term)))
(tmp2 (cons (car term) (map c-boolify tmp))))
(if (memq (car term) *bool-res-c-funs*)
(list *bool-c->s* tmp2)
tmp2)))
((and (not *floats-flag*)
(memq (car term) *bool-res-c-funs*)
(not (modified-fun? (car term))))
(list *bool-c->s*
(cons (car term) (map type-const-pass (cdr term)))))
((and (memq (car term) *always-bool-res-c-funs*)
(not (modified-fun? (car term))))
(list *bool-c->s*
(cons (car term) (map type-const-pass (cdr term)))))
((or (eq? 'if (car term)) (eq? *op-if* (car term)))
(let ((tmp (map type-const-pass (cdr term))))
(cons (car term)
(cons (c-boolify (car tmp)) (cdr tmp)))))
((eq? (car term) 'let*)
(set! *local-vars* (union (map car (cadr term)) *local-vars*))
(cons 'begin
(map type-const-pass
(begins->list
(append (map (lambda (x) (cons 'set! x)) (cadr term))
(cddr term))))))
((eq? (car term) *op-let*)
(set! *local-vars* (union (map car (cadr term)) *local-vars*))
(cons *op-begin*
(map type-const-pass
(begins->list
(append (map (lambda (x) (cons 'set! x)) (cadr term))
(cddr term))))))
((or (eq? 'begin (car term)) (eq? *op-begin* (car term)))
(cons (car term)
(begins->list (map type-const-pass (cdr term)))))
((eq? (car term) 'do)
(set! *local-vars* (union (map car (cadr term)) *local-vars*))
(let ((tmp (list* 'do
(map (lambda (x) (map type-const-pass x))
(cadr term))
(map type-const-pass (caddr term))
(map type-const-pass (cdddr term)))))
(if (null? (cdr (caddr tmp)))
(cons *do-not*
(begins->list
(cons (cadr tmp)
(cons (cons (c-negate
(c-boolify
(car (caddr tmp))))
(cdr (caddr tmp)))
(cdddr tmp)))))
(cons
'begin
(begins->list
(cons
(cons *do-not*
(begins->list
(cons (cadr tmp)
(cons (list
(c-negate
(c-boolify
(car (caddr tmp)))))
(cdddr tmp)))))
(begins->list (cdr (caddr tmp)))))))))
((eq? *function* (car term))
(cond ((or (memq (cadr term) *local-vars*)
(memq (cadr term) *local-parameters*))
(list *function* (cadr term)))
((memq (cadr term) *top-level-funs*)
; (report-error
; "In " *current-fun-name* " compiled function "
; (cadr term) " occurs as an argument. Use lambdaterm!")
(list *function* (cadr term)))
((in-file-defined? (cadr term))
(list *function* (cadr term)))
(else
(report-error
"In " *current-fun-name* " interpreted function "
(cadr term) " occurs as an argument. Use lambdaterm!"))))
((and (memq (car term) *cxr-funs*)
(not (modified-fun? (car term))))
(cxr-open (car term) (type-const-pass (cadr term))))
; the following always fails
((begin (set! term (fun-names-to-refs term)) #f))
((unknown-function? (car term) (cdr term))
(make-unknown-call term))
((and (eq? (car term) 'vector-set!)
(memq (cadr term) *stable-vector-names*))
(cons *st-vector-set*
(cons (string->symbol
(string-append
(symbol->string (cadr term))
*st-vector-postfix*))
(map type-const-pass (cddr term)))))
((and (eq? (car term) 'vector-ref)
(memq (cadr term) *stable-vector-names*))
(cons *st-vector-ref*
(cons (string->symbol
(string-append
(symbol->string (cadr term))
*st-vector-postfix*))
(map type-const-pass (cddr term)))))
(else
(cons (car term)
(map type-const-pass (cdr term))))))
(define (type-const-pass term)
(define res (type-const-pass-res term))
(if (and (pair? res) (or (eq? 'begin (car res))
(eq? *op-begin* (car res))))
(cons (car res) (begins->list (cdr res)))
res))
(define (fun-names-to-refs term)
(let ((hofdata (assq (car term) *liftable-hof-database*))
(tmp '()))
(if hofdata
(cons (car term)
(map (lambda (flag arg)
(cond
((not (symbol? arg)) arg)
(flag arg)
(else (fun-names-to-refs-aux arg))))
(cdr hofdata)
(cdr term)))
(cons (car term)
(map (lambda (arg)
(if (symbol? arg)
(fun-names-to-refs-aux arg)
arg))
(cdr term))))))
(define (fun-names-to-refs-aux name)
(if (and (not (memq name *local-parameters*))
(not (memq name *local-vars*))
(in-file-defined? name))
(let ((newname (make-closure-scmobj-name name)))
(if (not (memq name *symbol-and-fun-list*))
(begin
(set! *var-make-list*
(cons `(set!
,(make-closure-scmobj-name name)
(,*c-adr* (cdr (,*intern-function*
(,*actual-c-string*
,(symbol->string name))
,(string-length
(symbol->string name))))))
*var-make-list*))
(set! *symbol-and-fun-list* (cons name *symbol-and-fun-list*))))
(list *global-access* newname))
name))
(define (unknown-function? fn args)
(let ((len (length args)))
(or
(pair? fn)
(modified-fun? fn)
(not
(or (let ((tmp (memq fn *prohibited-funs*)))
(if tmp
(report-error "In " *current-fun-name*
" a prohibited function "
fn " is called."))
#f)
(eq? fn *current-fun-name*)
(memq fn *special-scm->c-functions*)
(assq fn *switch-args-table*)
(assq fn *add-args-table*)
(memq fn '(vector string if begin let* lambda set!))
(memq fn *internal-c-functions*)
(let ((tmp (if *floats-flag*
(assq fn *floats-s->c-fun-table*)
(assq fn *reckless-s->c-fun-table*))))
(if (and tmp (not (eqv? len (caddr tmp))))
(report-error "In " *current-fun-name* " function "
fn " is called with a wrong nr of args."))
tmp)
(let ((tmp (member-if (lambda (x) (eq? fn (cadr x)))
*to-do-fun-list*)))
(if (and tmp (not (eqv? len (length (cadr (caddar tmp))))))
(if (memq fn *top-level-funs*)
(report-error "In " *current-fun-name* " function "
fn " is called with a wrong nr of args.")
(report-error "In " *current-fun-name* " function "
fn
" is called with a wrong nr of args or builds closures.")))
tmp)
(let ((tmp (member-if (lambda (x) (eq? fn (cadr x))) *passed-defs*)))
(if (and tmp (not (eqv? len (length (cadr (caddar tmp))))))
(if (memq fn *top-level-funs*)
(report-error "In " *current-fun-name* " function "
fn " is called with a wrong nr of args.")
(report-error "In " *current-fun-name* " function "
fn
" is called with a wrong nr of args or builds closures.")))
tmp)
(memq fn *top-level-funs*))))))
(define (in-file-defined? fn)
(or (memq fn *top-level-funs*)
(eq? fn *current-fun-name*)
(member-if (lambda (x) (eq? fn (cadr x))) *to-do-fun-list*)
(member-if (lambda (x) (eq? fn (cadr x))) *passed-defs*)))
(define (top-nonlist-in-file-defined? fn)
(let ((x (or (member-if
(lambda (x) (or (eq? fn (cadr x))
(and (pair? (cadr x)) (eq? fn (caadr x)))))
*to-do-fun-list*)
(member-if
(lambda (x) (or (eq? fn (cadr x))
(and (pair? (cadr x)) (eq? fn (caadr x)))))
*passed-defs*))))
(and x
(let ((y (car x)))
(if (pair? (cadr y))
(list? (cadr y))
(and (pair? (cddr y))
(pair? (caddr y))
(eq? 'lambda (car (caddr y)))
(pair? (cdr (caddr y)))
(list? (cadr (caddr y)))))))))
(define (make-unknown-call term)
(let* ((fn (car term))
(args1 (map type-const-pass (cdr term)))
(args (map make-interpreter-usable args1))
(glob '()))
(if (pair? fn)
(set! glob (type-const-pass (car term)))
(if (or (memq fn *special-c-vars*)
(memq fn *local-parameters*)
(memq fn *local-vars*))
(set! glob fn)
(set! glob (list *global-access* (make-unknown-constant fn)))))
(or (pair? fn)
(memq fn *special-c-vars*)
(memq fn *local-parameters*)
(memq fn *local-vars*)
(memq fn *unknown-functions*)
(set! *unknown-functions* (cons fn *unknown-functions*)))
(list *sysapply*
glob
(if (null? args) '() (car args))
(if (null? args)
'()
(make-apply-second-arg (cdr args))))))
(define (make-unknown-call-aux term args)
(let ((fn (caar term)))
(if (or (in-file-defined? fn)
(memq fn *prohibited-funs*))
(report-error "In " *current-fun-name* " function "
fn " is assumed to return a closure.")
(make-unknown-call (car term)))))
(define (make-interpreter-usable term)
(let ((fn (if (pair? term)
(if (and (eq? *global-access* (car term))
(in-file-defined? (cadr term)))
(cadr term)
#f)
(if (and (symbol? term)
(in-file-defined? term))
term
#f)))
(tmp '()))
(if (not fn)
term
(make-interpreter-funname fn))))
(define (make-interpreter-funname fn)
(let ((tmp (assq fn *interpreter-funname-table*)))
(if tmp
(cdr tmp)
(begin
(set! tmp
(string->symbol
(string-append (symbol->string fn) *interpreter-suffix*)))
(set! *interpreter-funname-table*
(cons (cons fn tmp) *interpreter-funname-table*))
(list *global-access* tmp)))))
(define (make-unknown-constant var)
(if (memq var *global-vars-list*)
var
(begin
(set! *global-vars-list* (cons var *global-vars-list*))
(set! *var-make-list*
(cons `(set!
,var
(,*c-adr* (cdr (,*intern-function*
(,*actual-c-string*
,(symbol->string var))
,(string-length
(symbol->string var))))))
*var-make-list*))
var)))
(define (make-apply-second-arg args)
(if (null? args)
*listofnull*
(list 'cons
(car args)
(make-apply-second-arg (cdr args)))))
(define (make-string-constant str)
(let ((name (make-constant-name)))
(set! *new-constant-list*
(cons (list 'set!
name
(list 'scm-gc-protect
(list *makfromstr-function*
(list *actual-c-string* str)
(string-length str))))
*new-constant-list*))
name))
(define (make-number-constant num)
(let ((name (make-constant-name))
(str (number->string num)))
(set! *new-constant-list*
(cons (list 'set!
name
(list 'scm-gc-protect
(list *string->number-function*
(list *makfromstr-function*
(list *actual-c-string* str)
(string-length str))
(list *num-c->s* 10))))
*new-constant-list*))
name))
(define (make-vector-constant vect)
(let* ((name (make-constant-name))
(tmp (list 'set!
name
(list 'scm-gc-protect
(list 'list->vector
(make-pair-constant-aux
(vector->list vect)))))))
(set! *new-constant-list* (cons tmp *new-constant-list*))
name))
(define (make-pair-constant pair)
(let* ((name (make-constant-name))
(tmp (list 'set!
name
(list 'scm-gc-protect
(list 'cons
(make-pair-constant-aux (car pair))
(make-pair-constant-aux (cdr pair)))))))
(set! *new-constant-list* (cons tmp *new-constant-list*))
name))
(define (make-pair-constant-aux term)
(if (pair? term)
(list 'cons
(make-pair-constant-aux (car term))
(make-pair-constant-aux (cdr term)))
(type-const-pass (list 'quote term))))
(define (make-symbol-constant symb)
(let ((tmp (assq symb *symbol-constant-table*)))
(if tmp
(cadr tmp)
(let ((name (make-symbol-name symb))
(str (symbol->string symb))
(clname '()))
;; if the symb is also a top-level-fun, then avoid
;; applying make_subr to the symbol name string:
;; this would mess up symbol-names table for scm.
(if (and (memq symb *top-level-funs*)
(not (memq symb *symbol-and-fun-list*)))
(begin
(set! *var-make-list*
(cons `(set!
,(make-closure-scmobj-name symb)
(,*c-adr* (cdr (,*intern-function*
(,*actual-c-string*
,(symbol->string symb))
,(string-length
(symbol->string symb))))))
*var-make-list*))
(set! *symbol-and-fun-list*
(cons symb *symbol-and-fun-list*))))
(set! *symbol-constant-table*
(cons (list symb name) *symbol-constant-table*))
(set! *symbol-list*
(cons (list 'set!
name
`(scm-gc-protect
(car (,*intern-symbol-function*
(,*actual-c-string* ,str)
,(string-length str)))))
;;; (list 'string->symbol
;;; (list 'list->string
;;; (make-pair-constant-aux
;;; (string->list
;;; (symbol->string symb)))))
*symbol-list*))
name))))
(define (make-constant-name)
(set! *new-constant-num* (+ 1 *new-constant-num*))
(string->symbol (string-append *new-constant-prefix*
(number->string *new-constant-num*))))
(define (make-symbol-name symb)
(string->symbol (string-append (symbol->string symb)
*symbol-name-postfix*)))
(define (c-negate term)
(if (and (pair? term) (eq? *not?* (car term)))
(cadr term)
(list *not?* term)))
(define (cxr-open cxr arg)
(let* ((str (symbol->string cxr))
(chr #\c)
(len (string-length str))
(res arg))
(do ((n (- len 2) (- n 1)))
((= 0 n))
(set! chr (string-ref str n))
(set! res
(list (if (eqv? #\a chr) 'car 'cdr) res)))
res))
(define (c-boolify term)
(if (and (pair? term) (eq? *bool-c->s* (car term)))
(cadr term)
(list *bool-s->c* term)))
;===================================================================
;
; a pass for
; correcting higher-order function calls and
; dotted-arglist function calls.
;
;===================================================================
(define (ho-dot-wholedef term)
(set! *current-fun-name* (cadr term))
(ho-dot-pass term))
(define (ho-dot-pass term)
(cond ((or (not (pair? term)) (eq? 'quote (car term)))
term)
((memq (car term) *dot-arg-funs*)
(let* ((template (assq (car term) *dot-arg-templates*))
(new (make-listarg-arglist (cadr template) (cdr term))))
(if (and (memq (car term) *higher-order-funs*)
(liftable-hofname? (car term)))
(correct-ho-call
(cons (car term) (map ho-dot-pass new)))
(cons (car term) (map ho-dot-pass new)))))
((and (memq (car term) *higher-order-funs*)
(liftable-hofname? (car term)))
(correct-ho-call (map ho-dot-pass term)))
(else
(map ho-dot-pass term))))
(define (correct-ho-call term)
(let* ((add-args '())
(stay-args '())
(name (car term))
(data (assq name *higher-order-templates*))
(new-template '()))
(do ((args (cdr term) (cdr args))
(funtemplate (cadr data) (cdr funtemplate)))
((null? args))
(if (car funtemplate)
(begin
(if (and (not (pair? (car args)))
(and (primitive? (car args))
(if (fixed-arity-primitive? (car args))
#t
(report-error
"in function " *current-fun-name*
" a variable-arity primitive is passed to a higher-order fun: " term))))
(let*
((tmpargs (reverse
(list-tail '(w v u z y x)
(- 6 (primitive-arity (car args))))))
(newfun
(list 'lambda
tmpargs
(cons (car args) tmpargs)))
(newname (make-new-primitive-instname (car args))))
(set! *to-do-fun-list*
(cons (list 'define newname newfun)
*to-do-fun-list*))
(set! args (cons newname (cdr args)))))
(if (pair? (car args))
(begin
(set! add-args
(append (reverse (cdar args)) add-args))
(set! stay-args
(cons (caar args) stay-args))
(set! new-template
(cons (list
(length
(filter (lambda (x)
(or (not (pair? x))
(not (eq? *c-adr* (car x)))))
(cdar args)))
(length
(filter (lambda (x)
(and (pair? x)
(eq? *c-adr* (car x))))
(cdar args))))
new-template)))
(begin
(set! new-template (cons (list '0 '0) new-template))
(set! stay-args (cons (car args) stay-args)))))
(begin
(set! new-template (cons '0 new-template))
(set! stay-args (cons (car args) stay-args)))))
(set! new-template (reverse new-template))
(set! add-args (reverse add-args))
(set! stay-args (reverse stay-args))
(let ((attempt (assoc new-template (cddr data))))
(if attempt
(begin
(cons (cadr attempt)
(append add-args
(map (lambda (x y)
(if x (list *function* y) y))
(cadr data)
stay-args))))
(begin
(make-new-ho-instance term new-template data add-args stay-args)
(let ((attempt2 (assoc new-template (cddr data))))
(cons (cadr attempt2)
(append add-args
(map (lambda (x y)
(if x (list *function* y) y))
(cadr data)
stay-args)))))))))
(define (make-new-ho-instance term new-template data add-args stay-args)
(let* ((done-mainfun-flag #f)
(mainfun-place (member-if (lambda (x) (eq? (cadr x) (car term)))
*to-do-fun-list*))
(ho-fun (if mainfun-place
(begin
(set! done-mainfun-flag #f)
(car mainfun-place))
(begin
(set! mainfun-place
(member-if (lambda (x) (eq? (cadr x) (car term)))
*passed-defs*))
(if (not mainfun-place)
(report-error "Higher-order function "
(car term)
" is not defined."))
(set! done-mainfun-flag #t)
(car mainfun-place))))
(dot-data (assq (cadr ho-fun) *dot-arg-templates*))
(data (assq (car term) *higher-order-templates*))
(ho-term (caddr ho-fun))
(new-args '())
(new-name (make-new-instname (cadr ho-fun) (length (cddr data)))))
(set! *top-level-funs*
(cons new-name *top-level-funs*))
(set! *make-new-ho-data* '())
(for-each (lambda (x y)
(if (pair? x)
(let ((new (make-new-parameters x)))
(set! *make-new-ho-data*
(cons (cons (if (pair? y) (cadr y) y)
(args->list new))
*make-new-ho-data*))
(set! new-args
(append new new-args)))))
new-template
(args->list (cadr ho-term)))
(if dot-data
(begin (set! *dot-arg-funs* (cons new-name *dot-arg-funs*))
(set! *dot-arg-templates*
(cons (list new-name
(append new-args (cadr dot-data)))
*dot-arg-templates*))))
(set! ho-term (make-new-inst-aux
ho-term (args->list new-args) (cadr ho-fun) new-name))
(set! ho-term
(cons (car ho-term)
(cons (append new-args (cadr ho-term))
(cddr ho-term))))
(set! ho-fun
(list (car ho-fun) new-name ho-term))
(set-cdr! (my-last-pair data)
(list (list new-template (cadr ho-fun))))
(if done-mainfun-flag
(begin
(set-cdr! mainfun-place
(cons (car mainfun-place) (cdr mainfun-place)))
(set-car! mainfun-place ho-fun))
(begin
(set-cdr! mainfun-place
(cons ho-fun (cdr mainfun-place)))))))
(define (make-new-instname genname nr)
(let ((name
(string->symbol
(string-append (symbol->string genname)
*new-instfun-infix*
(number->string nr)))))
name))
(define (make-new-primitive-instname genname)
(set! *new-primitive-instnr* (+ 1 *new-primitive-instnr*))
(let ((name
(string->symbol
(string-append (symbol->string genname)
*new-instfun-infix*
(number->string *new-primitive-instnr*)))))
name))
(define (make-new-inst-aux term n-args o-name n-name)
(let ((tmp #f))
(cond ((or (not (pair? term)) (eq? 'quote (car term))) term)
((eq? *higher-order-call* (car term))
(set! tmp (assq (cadr term) *make-new-ho-data*))
(if tmp
(cons (car term)
(cons (cadr term)
(if (null? (cdr tmp))
(cddr term)
(append (cdr tmp) (cddr term)))))
(map (lambda (x) (make-new-inst-aux x n-args o-name n-name))
term)))
((eq? (car term) 'lambda)
(cons (car term)
(cons (cadr term)
(map (lambda (x)
(make-new-inst-aux x n-args o-name n-name))
(cddr term)))))
((eq? (car term) o-name)
(cons n-name
(append
n-args
(map (lambda (x)
(make-new-inst-aux x n-args o-name n-name))
(cdr term)))))
(else
(map (lambda (x) (make-new-inst-aux x n-args o-name n-name))
term)))))
(define (make-new-parameters nums)
(let* ((vars1 '())
(vars2 '()))
(do ((n (car nums) (- n 1)))
((zero? n))
(set! vars1 (cons (make-new-parameter) vars1)))
(do ((n (cadr nums) (- n 1)))
((zero? n))
(set! vars2 (cons (list *c-adr* (make-new-parameter)) vars2)))
(set! vars1 (reverse vars1))
(set! vars2 (reverse vars2))
(append vars1 vars2)))
(define (make-new-parameter)
(set! *new-parameter-nr* (+ 1 *new-parameter-nr*))
(string->symbol (string-append *new-parameter-prefix*
(number->string *new-parameter-nr*))))
;===================================================================
;
; statement-lifting & tail-recursion
;
;===================================================================
(define (lift-statements-wholedef defterm)
(set! *current-fun-name* (cadr defterm))
(set! *tailrec-flag* #f)
(set! *higher-order-flag* #f)
(let ((res '())
(res2 '())
(newname #f)
(tmp '())
(lambdaterm (caddr defterm)))
(set! *higher-order-args* (args->list (cadr lambdaterm)))
(set! *current-formal-args* (cadr lambdaterm))
(set! *current-formal-argslist* (args->list (cadr lambdaterm)))
(set! res (lift-statements lambdaterm '()))
(if (not (list? (cadr lambdaterm)))
(begin
(set! *dot-arg-funs*
(cons (cadr defterm) *dot-arg-funs*))
(set! *dot-arg-templates*
(cons (list (cadr defterm)
(cadr lambdaterm))
*dot-arg-templates*))))
(if (and *higher-order-flag*
(liftable-hofname? (cadr defterm)))
(begin
(set! *higher-order-args*
(map (lambda (x) (if (eq? x '#t) '#t '#f))
*higher-order-args*))
(set! *higher-order-funs*
(cons (cadr defterm) *higher-order-funs*))
(set! *higher-order-templates*
(cons
(list (cadr defterm)
*higher-order-args*
(list (map (lambda (x)
(if x (list '0 '0) '0))
*higher-order-args*)
(cadr defterm)))
*higher-order-templates*))
(if (and (memq *current-fun-name* *top-level-funs*)
(not (null? *export-functions*))
(or (not (pair? *export-functions*))
(memq *current-fun-name* *export-functions*)))
(begin
(set! newname
(string->symbol
(string-append (symbol->string *current-fun-name*)
*export-hof-postfix*)))
(set! *top-level-funs*
(cons newname *top-level-funs*))
(set! *export-table*
(cons (list *current-fun-name* newname)
*export-table*))
(set! tmp (assq *current-fun-name* *dot-arg-templates*))
(if tmp
(begin
(set! *dot-arg-templates*
(cons (list newname (cadr tmp))
*dot-arg-templates*))
(set! *dot-arg-funs*
(cons newname *dot-arg-funs*))))
(set! res2
(make-export-hof res))))
(set! res (cons (car res)
(cons (map (lambda (x y)
(if x (list *function* y) y))
*higher-order-args*
(maklist (cadr res)))
(cddr res))))))
(if *tailrec-flag*
(begin
(set! res (cons (car res)
(cons (cadr res)
(cons (list *mark-tailrec*)
(cddr res)))))
(if (not (null? res2))
(set! res2 (cons (car res2)
(cons (cadr res2)
(cons (list *mark-tailrec*)
(cddr res2))))))))
(set! res
(list 'define (cadr defterm)
(if (list? (cadr res))
res
(cons (car res)
(cons (maklist (cadr res))
(cddr res))))))
(if (null? res2)
(list res)
(list res
(list 'define newname
(if (list? (cadr res2))
res2
(cons (car res2)
(cons (maklist (cadr res2))
(cddr res2)))))))))
(define (maklist args)
(cond ((symbol? args)
(list args))
((null? args)
'())
(else (cons (car args) (maklist (cdr args))))))
(define (make-export-hof term)
(cond ((or (not (pair? term))
(eq? 'quote (car term)))
term)
((eq? 'lambda (car term))
(cons (car term)
(cons (cadr term)
(map make-export-hof (cddr term)))))
((eq? (car term) *higher-order-call*)
(list *sysapply*
(cadr term)
(if (null? (cddr term))
'()
(make-export-hof (caddr term)))
(if (null? (cddr term))
'()
(make-apply-second-arg
(make-export-hof (cdddr term))))))
((eq? (car term) *function*)
(cadr term))
((eq? (car term) *current-fun-name*)
(cons (string->symbol
(string-append (symbol->string *current-fun-name*)
*export-hof-postfix*))
(map make-export-hof (cdr term))))
(else
(map make-export-hof term))))
(define (lift-statements term checkvars)
(cond
((or (not (pair? term)) (eq? 'quote (car term)))
term)
((eq? 'lambda (car term))
(set! checkvars (args->list (cadr term)))
(append
(list 'lambda)
(list (cadr term))
(map (lambda (x) (lift-statements x checkvars))
(butlast (cddr term) 1))
(list
(lift-statements
(push-result-var-in *return* (car (my-last-pair term)))
checkvars))))
((and (eq? 'set! (car term))
(or (null? (cdr term)) (null? (cddr term))))
(report-error
" scheme syntax in fun " *current-fun-name* ": " term))
((and (eq? 'set! (car term))
(pair? (caddr term))
(memq (caaddr term) '(do if begin let*)))
(lift-statements (push-result-var-in (cadr term) (caddr term))
checkvars))
((eq? 'do (car term))
(set! checkvars (union (map car (cadr term)) checkvars))
(list* 'do
(map
(lambda (x)
(map (lambda (y) (lift-stat-aux y checkvars)) x))
(cadr term))
(append (list
(lift-stat-aux (car (caddr term)) checkvars))
(map (lambda (x)
(lift-statements x checkvars))
(cdr (caddr term))))
(map (lambda (x) (lift-statements x checkvars))
(cdddr term))))
((eq? 'if (car term))
(if (eq? 3 (length term))
(list 'if
(lift-stat-aux (cadr term) checkvars)
(lift-statements (caddr term) checkvars))
(list 'if
(lift-stat-aux (cadr term) checkvars)
(lift-statements (caddr term) checkvars)
(lift-statements (cadddr term) checkvars))))
((eq? 'begin (car term))
(append (list 'begin)
(map (lambda (x)
(lift-statements
(if (and (pair? x) (eq? 'set! (car x)))
(push-result-var-in (cadr x) (caddr x))
x)
checkvars))
(cdr term))))
((or (eq? 'let* (car term)) (eq? 'let (car term)))
(set! checkvars (union (map car (cadr term)) checkvars))
(append (list 'let*)
(list (map (lambda (x) (list (car x) *dummy*)) (cadr term)))
(map (lambda (x)
(lift-statements
(push-result-var-in (car x) (cadr x))
checkvars))
(cadr term))
(map (lambda (x) (lift-statements x checkvars))
(cddr term))))
((and (eq? 'set! (car term))
(pair? (caddr term))
(memq (caaddr term) '(do if begin let*)))
(lift-statements (push-result-var-in (cadr term) (caddr term))
checkvars))
(else
(lift-stat-aux term checkvars))))
(define (lift-stat-aux term checkvars)
(cond
((or (not (pair? term)) (eq? 'quote (car term)))
term)
((eq? (car term) 'if)
(if (and *lift-ifs-flag*
(or (lift-if-arg? (caddr term))
(and (not (null? (cdddr term)))
(lift-if-arg? (cadddr term)))))
(let ((argvars (free-vars term checkvars '()))
(newname (new-fun-name *current-fun-name*)))
(set! *to-do-fun-list*
(cons
(list 'define
newname
(list 'lambda
(make-arglist argvars '())
(fetchify (cadr argvars) term)))
*to-do-fun-list*))
(cons newname (make-arglist argvars '())))
(cons *op-if* (map (lambda (x) (lift-stat-aux x checkvars))
(cdr term)))))
((eq? (car term) 'begin)
(cons *op-begin* (map (lambda (x) (lift-stat-aux x checkvars))
(cdr term))))
((or (eq? (car term) 'let*) (eq? (car term) 'let))
(set! checkvars (union (map car (cadr term)) checkvars))
(append (list *op-let*)
(list (map (lambda (x) (lift-stat-aux x checkvars))
(cadr term)))
(map (lambda (x) (lift-stat-aux x checkvars))
(cddr term))))
((eq? (car term) 'do)
(let ((argvars (free-vars term checkvars '()))
(newname (new-fun-name *current-fun-name*)))
(set! *to-do-fun-list*
(cons
(list 'define
newname
(list 'lambda
(make-arglist argvars '())
(fetchify (cadr argvars) term)))
*to-do-fun-list*))
(cons newname (make-arglist argvars '()))))
((and (memq (car term) *current-formal-argslist*)
(liftable-hofname? *current-fun-name*))
(set! *higher-order-flag* #t)
(set! *higher-order-args*
(replaceq (car term) '#t *higher-order-args*))
(cons *higher-order-call*
(map (lambda (x) (lift-stat-aux x checkvars)) term)))
(else
(map (lambda (x) (lift-stat-aux x checkvars)) term))))
;;; lift-if-arg? says whether it is needed/sensible to lift
;;; the if-statement with such a as one of the resulting args
(define (lift-if-arg? term)
(and (pair? term)
(not (eq? 'quote (car term)))
(not (and (memq
(car term)
(cons *not?*
(cons *and?*
(cons *or?*
'(eq? = < > <= >=
number? boolean? null? pair? zero?
character? vector?
%= %< %> %<= %>=
%eqv? %number? %zero)))))
(not (member-if (lambda (x) (pair? x)) (cdr term)))))))
(define (push-result-var-in var term)
(cond ((or (not (pair? term)) (eq? 'quote (car term)))
(if (eq? var *return*)
(list *return* term)
(list 'set! var term)))
((eq? (car term) 'if)
(if (eq? 3 (length term))
(list 'if (cadr term)
(push-result-var-in var (caddr term)))
(list 'if (cadr term)
(push-result-var-in var (caddr term))
(push-result-var-in var (cadddr term)))))
((eq? (car term) 'begin)
(append (list 'begin)
(butlast (cdr term) 1)
(list (push-result-var-in var
(car (my-last-pair term))))))
((or (eq? (car term) 'let*) (eq? (car term) 'let))
(append (list 'let*)
(list (cadr term))
(butlast (cddr term) 1)
(list (push-result-var-in var
(car (my-last-pair term))))))
((eq? (car term) 'do)
(append (list 'do)
(list (cadr term))
(list (append
(list (car (caddr term)))
(if (null? (cdr (caddr term)))
(list (push-result-var-in var *unspecified*))
(append
(butlast (cdr (caddr term)) 1)
(list
(push-result-var-in
var
(car (my-last-pair (caddr term)))))))))
(cdddr term)))
;; ((eq? (car term) 'lambda)
;; (report-error
;; "Compiled function " *current-fun-name* " builds closures."))
((eq? var *return*)
(if (eq? (car term) *current-fun-name*)
(begin
(set! *tailrec-flag* #t)
(make-tailrec-call (cdr term)))
(list *return* term)))
(else
(list 'set! var term))))
(define (make-tailrec-call args)
(define (first-n-reverse n lst)
(if (zero? n) '() (cons (car lst) (first-n-reverse (- n 1) (cdr lst)))))
(let ((tmp1 '())
(tmp2 '())
(tmp3 '()))
(set! tmp3 (args->list *current-formal-args*))
(set! args (make-listarg-arglist *current-formal-args* args))
(do ((args-lst args (cdr args-lst))
(form-lst tmp3 (cdr form-lst)))
((null? args-lst))
(if (not (equal? (car args-lst) (car form-lst)))
(begin (set! tmp1 (cons (car args-lst) tmp1))
(set! tmp2 (cons (car form-lst) tmp2)))))
(set! tmp1 (reverse tmp1))
(set! tmp2 (reverse tmp2))
(cond
((null? tmp1) (list *goto-tailrec*))
((null? (cdr tmp1))
(list 'begin
(list 'set! (car tmp2) (car tmp1))
(list *goto-tailrec*)))
(else
(let ((tmplist
(first-n-reverse (length tmp1) *tmp-vars*)))
(append
(list 'let*)
(list (map (lambda (x y) (list x y)) tmplist tmp1))
(map (lambda (x y) (list 'set! x y)) tmp2 tmplist)
(list (list *goto-tailrec*))))))))
(define (make-listarg-arglist formals args)
(cond ((list? formals) args)
((symbol? formals) (list (normalize-list-aux args)))
((null? args)
(report-error
"In " *current-fun-name*
" a list-taking function is called with too few args."))
(else
(cons (car args)
(make-listarg-arglist (cdr formals) (cdr args))))))
(define (build-wrappers funs)
(define (build-wrapper-aux arity arg)
(cond ((null? arity)
'())
((not (pair? arity))
(list arg))
(else
(cons (list 'car arg)
(build-wrapper-aux (cdr arity) (list 'cdr arg))))))
(define (build-wrapper fun)
(let* ((name (cadr fun))
(export (assq name *export-table*))
(arity (cadr (caddr fun)))
(arity2 (assq name *dot-arg-templates*)))
(if arity2
(set! arity (cadr arity2)))
(if (or (not (memq name *export-functions*))
(symbol? arity)
(and (list? arity)
(< (length arity) 4)))
#f
`(define ,(string->symbol
(string-append (symbol->string name)
*wrapper-postfix*))
(lambda (x)
(,*return*
(,(if export (cadr export) name)
,@(build-wrapper-aux arity 'x))))))))
(let ((res '()))
(for-each (lambda (x)
(let ((new (build-wrapper x)))
(if new
(begin
(set! res (cons new res))
(set! *wrapper-table*
(cons (list (cadr x) (cadr new))
*wrapper-table*))))))
funs)
res))
(define (build-wrapped-interpreter-table)
(let ((new '())
(tmp '()))
(do ((part *interpreter-funname-table* (cdr part)))
((null? part)
(set! *interpreter-funname-table* new))
(set! tmp (assq (caar part) *wrapper-table*))
(if tmp
(set! new (cons (cons (cadr tmp) (cdar part)) new))
(begin
(set! tmp (assq (caar part) *export-table*))
(if tmp
(set! new (cons (cons (cadr tmp) (cdar part)) new))
(set! new (cons (car part) new))))))))
;===================================================================
;
; vars-simplifying and lambda-lifting
;
;==================================================================
(define *new-vars-nr-for-topfun* 0)
(define (vars-simplify-wholedef def)
(let ()
;;;(pretty-print def)
(set! def (compile-quasiquote def))
;;;(pretty-print def)
(set! def (normalize-defines def))
(set! *current-fun-name* (cadr def))
(set! *top-level-funs* (cons *current-fun-name* *top-level-funs*))
;;;(pretty-print def)
(set! def (if *full-inlining-flag*
(subst-inline-full def)
(subst-inline def)))
(set! def (normalize-delay def))
;;;(pretty-print def)
(set! def (rename-vars def))
(set! *new-vars-nr-for-topfun* 0)
(set! def (normalize def #f 1))
;;;(pretty-print def)
(set! def (normalize-def-letrecs def))
(set! def (beautify-lets def))
;;;(pretty-print def)
def))
;;; flatten-wholedef performs the first normalizing and lambda-lifting pass
(define (flatten-wholedef def)
(let ()
;;;(newline)
;;;(display "starting to flatten def: ") (newline)
;;;(pretty-print def)
(set! *current-fun-name* (cadr def))
(set! def (lettify-lambdas def 100 #t))
;;;(pretty-print def)
(set! def (remove-lambdasurrounding-let def))
;;;(pretty-print def)
(set! *new-funs-list* '())
(set! def (lambda-lift def '() '()))
;;;(pretty-print def)
(set! *new-funs-list* (cons def *new-funs-list*))
*new-funs-list*))
(define (lambda-lift term boundvars new-names-args)
(let ((tmp '()))
(cond
((symbol? term)
(set! tmp (assq term new-names-args))
(if tmp
(cons (cadr tmp) (make-arglist (caddr tmp) '()))
term))
((not (pair? term)) term)
((eq? (car term) 'quote) term)
((eq? (car term) 'lambda)
(set! tmp (union (args->list (cadr term)) boundvars))
(cons 'lambda
(cons (cadr term)
(map (lambda (x)
(lambda-lift x tmp new-names-args))
(cddr term)))))
((memq (car term) '(let let* letrec))
(lift-let term boundvars new-names-args))
((eq? (car term) 'do)
;; check next line!!!
(set! tmp (union (map car (cadr term)) boundvars))
(cons 'do
(cons (map (lambda (x)
(if (null? (cddr x))
(list (car x)
(lambda-lift (cadr x) boundvars
new-names-args))
(list (car x)
(lambda-lift (cadr x) boundvars
new-names-args)
(lambda-lift (caddr x)
tmp
new-names-args))))
(cadr term))
(map (lambda (x)
(lambda-lift x tmp new-names-args))
(cddr term)))))
((symbol? (car term))
(set! tmp (assq (car term) new-names-args))
(let ((args (map (lambda (x)
(lambda-lift x boundvars new-names-args))
(cdr term))))
(if tmp
(cons (cadr tmp)
(make-arglist (caddr tmp) args))
(cons (car term) args))))
(else
(cons (lambda-lift (car term) boundvars new-names-args)
(map (lambda (x)
(lambda-lift x boundvars new-names-args))
(cdr term)))))))
(define (lift-let letterm boundvars new-names-args)
(let* ((bindings (cadr letterm))
(newvars (map car bindings))
(body (cddr letterm))
(fun-bindings
(filter (lambda (x)
(and (pair? (cadr x))
(eq? (caadr x) 'lambda)))
bindings))
(other-bindings
(filter (lambda (x)
(not (memq x fun-bindings)))
bindings))
(next-bound (union (map car other-bindings) boundvars)))
(cond ((null? fun-bindings))
((memq (car letterm) '(let* let))
(set! new-names-args
(make-new-funs-let
fun-bindings next-bound new-names-args #f)))
((eq? (car letterm) 'letrec)
(set! new-names-args
(make-new-funs-letrec
fun-bindings next-bound new-names-args #f)))
(else (report-error "lift-let applied to non-let term " letterm)))
(cond ((not (null? other-bindings))
(cons (car letterm)
(cons (map (lambda (x)
(list (car x)
(lambda-lift (cadr x)
next-bound
new-names-args)))
other-bindings)
(map (lambda (x)
(lambda-lift x next-bound new-names-args))
body))))
((null? (cdr body))
(lambda-lift (car body) next-bound new-names-args))
(else
(lambda-lift (cons 'begin body) next-bound new-names-args)))))
(define (fetchify vars term)
(if (null? vars) term (fetchify-aux vars term)))
(define (fetchify-aux vars term)
(cond ((symbol? term)
(if (memq term vars)
(list *c-fetch* term)
term))
((not (pair? term))
term)
((eq? 'quote (car term))
term)
((and (eq? *c-adr* (car term))
(memq (cadr term) vars))
(cadr term))
(else
(cons (fetchify-aux vars (car term))
(fetchify-aux vars (cdr term))))))
(define (make-arglist new-args args)
(if (null? (cadr new-args))
(append (car new-args) args)
(append (map (lambda (x) (list *c-adr* x)) (cadr new-args))
(car new-args)
args)))
(define (normalize-def-letrecs def)
(let ((tmp '()))
(set! *current-fun-name* (cadr def))
(set! tmp
(normalize-def-letrecs-aux (caddr def)))
(list* (car def) (cadr def) (list tmp))))
(define (normalize-def-letrecs-aux term)
(cond ((not (pair? term)) term)
((eq? 'quote (car term)) term)
((eq? 'lambda (car term))
(list* (car term) (cadr term)
(map normalize-def-letrecs-aux (cddr term))))
((eq? 'letrec (car term))
(if (null? (cadr term))
(list* 'let* '() (map normalize-def-letrecs-aux (cddr term)))
(restructure-letrec (map normalize-def-letrecs-aux term))))
(else
(map normalize-def-letrecs-aux term))))
(define (restructure-letrec letterm)
(let* ((vars (map car (cadr letterm)))
(dependencies
(map (lambda (x)
(list (car x)
(occurrences-of vars (cadr x))))
(cadr letterm)))
(groups (build-sconnected-groups dependencies vars '())))
(set! groups (topo-sort dependencies groups))
(build-letrec-struct letterm dependencies groups)))
(define (build-letrec-struct letterm deps groups)
(if (null? groups)
(list (cddr letterm))
(let ((bind (filter (lambda (x) (memq (car x) (car groups)))
(cadr letterm)))
(body (build-letrec-struct letterm deps (cdr groups))))
(cond
((and (null? (cdar groups))
(not (memq (caar groups) (cadr (assq (caar groups) deps)))))
(cons 'let
(if (symbol? (car body))
(list bind body)
(cons bind (car body)))))
(else
(cons 'letrec
(if (symbol? (car body))
(list bind body)
(cons bind (car body)))))))))
;;; lettify-lambdas has a topflag parameter, which is true iff
;;; the term is a third arg of a toplevel def
(define (lettify-lambdas term var-nr topflag)
(cond ((not (pair? term)) term)
((eq? 'quote (car term)) term)
((memq (car term) '(define lambda))
(if (not (list? (cddr term)))
(report-error
*current-fun-name* " has incorrect syntax."))
(cons (car term)
(cons (cadr term)
(map (lambda (x) (lettify-lambdas x var-nr topflag))
(cddr term)))))
((and (pair? term)
(not (list? term)))
(report-error
*current-fun-name* " has incorrect syntax."))
((memq (car term) '(let let* letrec))
(if (not topflag)
(cons (car term)
(list* (map (lambda (x)
(list (car x)
(lettify-lambdas
(cadr x) var-nr #f)))
(cadr term))
(lettify-lambdas (cddr term) var-nr #f)))
(cons (car term)
(list* (map (lambda (x)
(list (car x)
(lettify-lambdas
(cadr x) var-nr #f)))
(cadr term))
(map
(lambda (x) (lettify-lambdas x var-nr #f))
(cddr term))))))
((and (memq (car term) '(cond))
(find-if (lambda (cl)
(find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x))))
(cdr cl)))
(cdr term)))
(let* ((lcl
(find-if (lambda (cl)
(find-if (lambda (x) (and(pair? x) (eq? 'lambda (car x))))
(cdr cl)))
(cdr term)))
(lterm
(find-if (lambda (x) (and(pair? x) (eq? 'lambda (car x)))) lcl))
(newvar (make-new-funname))
(newlcl (replaceq lterm newvar lcl))
(newclauses (replaceq lcl newlcl (cdr term))))
`(let ((,newvar ,(lettify-lambdas lterm (+ 1 var-nr) #f)))
,(lettify-lambdas
(cons 'cond newclauses) (+ 1 var-nr) #f))))
((find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x)))) term)
(let* ((lterm (find-if (lambda (x) (and (pair? x) (eq? 'lambda (car x))))
term))
(newvar (make-new-funname))
(newterm (replaceq lterm newvar term)))
`(let ((,newvar ,(lettify-lambdas lterm (+ 1 var-nr) #f)))
,(lettify-lambdas newterm (+ 1 var-nr) #f))))
(else
(map (lambda (x) (lettify-lambdas x var-nr #f)) term))))
(define (make-new-funname)
(set! *new-fun-nr* (+ 1 *new-fun-nr*))
(let ((name
(string->symbol
(string-append (symbol->string *current-fun-name*)
*new-letfun-infix*
(number->string *new-fun-nr*)))))
(set! *new-fun-names* (cons name *new-fun-names*))
name))
(define (beautify-lets term)
(cond ((not (pair? term)) term)
((eq? 'quote (car term)) term)
((eq? (car term) 'lambda)
(cons (car term)
(cons (cadr term)
(map beautify-lets (cddr term)))))
((and (memq (car term) '(let let*))
(eq? 3 (length term))
(pair? (caddr term))
(memq (car (caddr term)) '(let let*)))
(beautify-lets
(list* 'let*
(map beautify-lets
(append (cadr term) (cadr (caddr term))))
(cddr (caddr term)))))
(else (map beautify-lets term))))
;--------------------------------------------------------------
;
; topological sorting by dependencies
;
;--------------------------------------------------------------
(define (topo-sort deps groups)
(let ((res (cons '() '())))
(do ((part groups (cdr part)))
((null? part) (cdr res))
(topo-insert (car part) res deps))))
(define (topo-insert el lst deps)
(let ((found-flag #f))
(do ((last-part lst (cdr last-part)))
((or found-flag (null? (cdr last-part)))
(if (not found-flag)
(set-cdr! last-part (list el)))
lst)
(if (is-path? (caadr last-part) (car el) deps '())
(begin
(set-cdr! last-part (cons el (cdr last-part)))
(set! found-flag #t))))))
(define (build-sconnected-groups deps input groups)
(let ((tmp '()))
(cond
((null? input) groups)
((begin (set! tmp
(find-if
(lambda (grp)
(and (not (null? (cdr grp)))
(is-path? (car input) (car grp) deps '())
(is-path? (car grp) (car input) deps '())))
groups))
tmp)
(build-sconnected-groups deps (cdr input)
(cons (cons (car input) tmp) (remove tmp groups))))
((begin (set! tmp
(find-if
(lambda (in)
(and (is-path? (car input) in deps '())
(is-path? in (car input) deps '())))
(cdr input)))
tmp)
(build-sconnected-groups deps (remove tmp (cdr input))
(cons (list (car input) tmp) groups)))
(else
(build-sconnected-groups deps (cdr input)
(cons (list (car input)) groups))))))
(define (is-path? a b deps visited)
(set! visited (cons a visited))
(set! a (cadr (assq a deps)))
(or (memq b a)
(find-if (lambda (x)
(and (not (memq x visited))
(is-path? x b deps visited)))
a)))
(define (occurrences-of vars term)
(cond ((symbol? term)
(if (memq term vars)
(list term)
'()))
((not (pair? term)) '())
((eq? (car term) 'quote) '())
(else
(union (occurrences-of vars (car term))
(occurrences-of vars (cdr term))))))
;---------------------------------------------------------------------
;
; build auxiliary functions
;
;--------------------------------------------------------------------
(define (make-new-funs-let fun-bindings boundvars new-names-args lazy-flag)
(for-each
(lambda (b)
(let* ((freevars (merge-free-vars
(introduced-free-vars (cadr b) new-names-args)
(free-vars (cadr b) boundvars '())))
(new-name (make-new-funname))
(tmp (list 'define
new-name
(cons (caadr b)
(cons (make-arglist freevars (cadadr b))
(map (lambda (y)
(fetchify
(cadr freevars)
(lambda-lift
y
(union (args->list (cadadr b))
boundvars)
new-names-args)))
(cddadr b)))))))
(set! *new-funs-list* (cons tmp *new-funs-list*))
(set! new-names-args
(cons (list (car b) new-name freevars)
new-names-args))))
fun-bindings)
new-names-args)
(define (make-new-funs-letrec fun-bindings boundvars new-names-args lazy-flag)
(let* ((fun-bodies (cons 'begin (map cadr fun-bindings)))
(intro-vars (introduced-free-vars fun-bodies new-names-args))
(freevars (merge-free-vars intro-vars
(free-vars fun-bodies boundvars '())))
(new-names-args
(append
(map (lambda (b)
(list (car b) (make-new-funname) freevars))
fun-bindings)
new-names-args)))
(for-each
(lambda (b)
(set! *new-funs-list*
(cons
(list 'define
(cadr (assq (car b) new-names-args))
(cons (caadr b)
(cons (make-arglist freevars (cadadr b))
(map (lambda (y)
(fetchify (cadr freevars)
(lambda-lift y
(union
(args->list (cadadr b))
boundvars)
new-names-args)))
(cddadr b)))))
*new-funs-list*)))
fun-bindings)
new-names-args))
(define (introduced-free-vars term names-args)
(if (null? names-args)
(list '() '())
(introduced-free-vars-aux term names-args)))
(define (introduced-free-vars-aux term names-args)
(cond ((symbol? term)
(let ((tmp (assq term names-args)))
(if tmp (caddr tmp) '(() ()))))
((not (pair? term)) '(() ()))
((eq? 'quote (car term)) '(() ()))
(else
(merge-free-vars
(introduced-free-vars-aux (car term) names-args)
(introduced-free-vars-aux (cdr term) names-args)))))
(define (new-fun-name a)
(if (memq a *new-fun-names*)
a
(string->symbol
(string-append (symbol->string a)
*new-fun-infix*
(begin (set! *new-fun-nr* (+ 1 *new-fun-nr*))
(number->string *new-fun-nr*))))))
;-------------------------------------------------------------------
;
; free-vars collectors
;
;------------------------------------------------------------------
;;; all-free-vars takes a term and returns a list (a set) of all
;;; all free variables in term.
(define (all-free-vars term)
(set! *free-vars-list* '())
(all-free-aux! term '())
*free-vars-list*)
(define (all-free-aux! term bound)
(cond
((symbol? term)
(if (and (not (memq term bound))
(not (memq term *free-vars-list*)))
(set! *free-vars-list* (cons term *free-vars-list*))))
((not (pair? term)))
((eq? 'quote (car term)))
((eq? 'lambda (car term))
(let ((new (union (args->list (cadr term)) bound)))
(for-each (lambda (x) (all-free-aux! x new)) (cddr term))))
((eq? 'let (car term))
(let ((new (union (map car (cadr term)) bound)))
(for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
(for-each (lambda (x) (all-free-aux! x new)) (cddr term))))
((eq? 'let* (car term))
(for-each (lambda (x)
(all-free-aux! (cadr x) bound)
(if (not (memq (car x) bound))
(set! bound (cons (car x) bound))))
(cadr term))
(for-each (lambda (x) (all-free-aux! x bound)) (cddr term)))
((eq? 'letrec (car term))
(set! bound (union (map car (cadr term)) bound))
(for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
(for-each (lambda (x) (all-free-aux! x bound)) (cddr term)))
((eq? 'do (car term))
(let ((new (union (map car (cadr term)) bound)))
(for-each (lambda (x) (all-free-aux! (cadr x) bound)) (cadr term))
(for-each (lambda (x)
(if (not (null? (cddr x)))
(all-free-aux! (caddr x) new)))
(cadr term))
(for-each (lambda (x) (all-free-aux! x new)) (caddr term))
(for-each (lambda (x) (all-free-aux! x new)) (cdddr term))))
(else
(for-each (lambda (x) (all-free-aux! x bound)) term))))
;;; free-vars takes a term, a list of candidates for free vars (vars bound
;;; somewhere higher in the term) and a list of bound variables.
;;; The list of candidates is used in order not to consider the global
;;; variables (external function definitions, *vars*, etc) to be free.
;;; It returns a list of two disjoint sets: (),
;;; where is a list of free variables which have a set!
;;; applied to them somewhere in the term.
;;; The differentiation is important, as ordinary (non-set!)
;;; free variables are passed as ordinary additional variables
;;; during lambda-lifting, whereas set!-variables have to be passed
;;; by reference and treated accordingly (fortunately this is simple
;;; in C: instead of x always write (*x)).
(define (free-vars term checkvars boundvars)
(cond ((and (symbol? term) (memq term checkvars))
(if (memq term boundvars)
'(() ())
(list (list term) '())))
((not (pair? term)) '(() ()))
((eq? (car term) 'quote) '(() ()))
((eq? (car term) 'set!)
(if (or (memq (cadr term) boundvars)
(not (memq (cadr term) checkvars)))
(free-vars (caddr term) checkvars boundvars)
(merge-free-vars (list '() (list (cadr term)))
(free-vars (caddr term) checkvars boundvars))))
((eq? (car term) 'lambda)
(free-vars (cddr term)
checkvars
(append (args->list (cadr term))
boundvars )))
((memq (car term) '(let let* letrec))
(free-vars (append (map cadr (cadr term))
(cddr term))
checkvars
(append (map car (cadr term))
boundvars )))
((eq? (car term) 'do)
(free-vars (append (map cadr (cadr term))
(map (lambda (x)
(if (null? (cddr x)) 1 (caddr x)))
(cadr term))
(cddr term))
checkvars
(append (map car (cadr term))
boundvars )))
(else
(merge-free-vars (free-vars (car term) checkvars boundvars)
(free-vars (cdr term) checkvars boundvars)))))
(define (merge-free-vars pair-a pair-b)
(let* ((norm-a (car pair-a))
(norm-b (car pair-b))
(set-a (cadr pair-a))
(set-b (cadr pair-b))
(set-res (union set-a set-b)))
(list (set-difference (union norm-a norm-b) set-res)
set-res )))
(define *var-nr* 0)
;================================================================
;
; substituting in inlined-functions and
; converting one-arg map-s to map1-s
;
;================================================================
(define (subst-inline-full term)
(let ((new (subst-inline term)))
(if (equal? term new)
term
(subst-inline-full new))))
(define (subst-inline term)
(cond ((symbol? term)
(let ((tmp (assq term *inline-vars-data*)))
(if tmp (cadr tmp) term)))
((not (pair? term)) term)
((eq? 'quote (car term))
term)
((and (eq? (car term) 'map)
(= 3 (length term))
(not *always-map->do-flag*)
(guaranteed-all-liftable? (list (car term) (cadr term))))
(set! *map1-needed-flag* #t)
(if (or (pair? (cadr term))
(top-nonlist-in-file-defined? (cadr term)))
(subst-inline (cons *map1-function* (cdr term)))
(subst-inline
(list *map1-function*
`(lambda (x) (,(cadr term) x))
(caddr term)))))
((and (eq? (car term) 'for-each)
(= 3 (length term))
(not *always-for-each->do-flag*)
(guaranteed-all-liftable? (list (car term) (cadr term))))
(set! *for-each1-needed-flag* #t)
(if (or (pair? (cadr term))
(top-nonlist-in-file-defined? (cadr term)))
(subst-inline (cons *for-each1-function* (cdr term)))
(subst-inline
(list *for-each1-function*
`(lambda (x) (,(cadr term) x))
(caddr term)))))
((memq (car term) *inline-funs*)
(let ((data (assq (car term) *inline-funs-data*))
(tmp (subst-inline (cdr term))))
(subst-inline-aux
(caddr (cadr data))
(map (lambda (par arg)
(list par arg))
(cadr (cadr data))
tmp))))
((and (eq? (car term) 'set!)
(assq (cadr term) *inline-vars-data*))
(cons 'set! (cons (cadr term) (map subst-inline (cddr term)))))
((list? term)
(map subst-inline term))
(else
term)))
(define (subst-inline-aux term pairs)
(cond ((symbol? term)
(let ((tmp (assq term pairs)))
(if tmp
(cadr tmp)
term)))
((not (pair? term))
term)
(else
(cons (subst-inline-aux (car term) pairs)
(subst-inline-aux (cdr term) pairs)))))
;================================================================
;
; normalization (simplifying transformation)
;
;================================================================
;;; normalize is a main normalizing function, which should
;;; normalize a term in one pass.
;;;
;;; MB! Quasiquote-compiler, normalize-defines and rename-vars
;;; must have been applied before the application of the current
;;; transformer.
(define (normalize term bool-flag var-nr)
(cond ((not (pair? term)) term)
((eq? (car term) 'quote) term)
((memq (car term) '(set! set-car! set-cdr! vector-set!))
(list 'begin
(map (lambda (x) (normalize x bool-flag var-nr)) term)
*unspecified*))
((eq? (car term) 'if)
(normalize-if (cdr term) bool-flag var-nr))
((eq? (car term) 'cond)
(normalize-cond (cdr term) bool-flag var-nr))
((eq? (car term) 'not)
(normalize-not (cdr term) bool-flag var-nr))
((eq? (car term) 'and)
(normalize-and (cdr term) bool-flag var-nr))
((eq? (car term) 'or)
(normalize-or (cdr term) bool-flag var-nr))
((eq? (car term) 'case)
(normalize-case term bool-flag var-nr))
((eq? (car term) 'do)
(normalize-do (cdr term) bool-flag var-nr))
((eq? (car term) 'lambda)
(cons (car term)
(cons (cadr term)
(normalize (cddr term) bool-flag var-nr))))
((eq? 'letrec (car term))
;;(restructure-letrec
;; (map (lambda (x) (normalize x bool-flag var-nr)) term))
(map (lambda (x) (normalize x bool-flag var-nr)) term))
((modified-fun? (car term))
(map (lambda (x) (normalize x bool-flag var-nr)) term))
((eq? (car term) 'list)
(normalize-list term bool-flag var-nr))
((eq? (car term) 'for-each)
(for-each->do term bool-flag var-nr))
((eq? (car term) 'map)
(map->do term bool-flag var-nr))
((eq? (car term) 'open-input-file)
(normalize-open-input-file (cdr term) bool-flag var-nr))
((eq? (car term) 'open-output-file)
(normalize-open-output-file (cdr term) bool-flag var-nr))
((eq? (car term) 'call-with-input-file)
(normalize-call-with-input-file (cdr term) bool-flag var-nr))
((eq? (car term) 'call-with-output-file)
(normalize-call-with-output-file (cdr term) bool-flag var-nr))
((eq? (car term) 'with-input-from-file)
(normalize-with-input-from-file (cdr term) bool-flag var-nr))
((eq? (car term) 'with-output-to-file)
(normalize-with-output-to-file (cdr term) bool-flag var-nr))
((eq? 'string-append (car term))
(normalize-string-append term bool-flag var-nr))
((assq (car term) *associative-fun-table*)
(normalize-associative
(assq (car term) *associative-fun-table*)
(cdr term) bool-flag var-nr))
((assq (car term) *comparison-fun-table*)
(normalize-comparison
(assq (car term) *comparison-fun-table*)
(cdr term) bool-flag var-nr))
(else
(map (lambda (x) (normalize x bool-flag var-nr)) term))))
;;; for-each->do converts a for-each application to a do cycle.
;;; The aim is to convert a do cycle into the C for cycle later.
;;;
;;; NB! here and in the following transformers bool-flag denotes
;;; whether the current term occurs as a term of boolean type -
;;; eg, (if (for-each ....) term1 term2). This allows some
;;; optimizations (although not directly in for-each, of course).
;;;
;;; var-nr is a number of the last generated new variable.
(define (for-each->do term bool-flag var-nr)
(let* ((fun (cadr term))
(args (cddr term))
(names (map (lambda (x)
(set! var-nr (+ 1 var-nr)) (make-new-var var-nr))
args )))
`(do
,(map (lambda (x y) (list x y (list 'cdr x)))
names
(map (lambda (x) (normalize x #f (+ 1 var-nr))) args))
,(list (normalize
(if (null? (cdr args))
(list 'not (list 'pair? (car names)))
(list 'not (cons 'and (map (lambda (x)
(list 'pair? x))
names))))
#t var-nr)
*unspecified*)
,(cons (normalize fun #f (+ 1 var-nr))
(map (lambda (x) (list 'car x)) names)))))
;;; map->do converts a map application to a do cycle.
(define (map->do term bool-flag var-nr)
(let* ((fun (cadr term))
(args (cddr term))
(res (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
(res-end (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
(tmp (begin (set! var-nr (+ 1 var-nr)) (make-new-var var-nr)))
(names (map (lambda (x)
(set! var-nr (+ 1 var-nr)) (make-new-var var-nr))
args )))
`(do
(,@(map (lambda (x y) (list x y (list 'cdr x)))
names
(map (lambda (x) (normalize x #f (+ 1 var-nr))) args))
(,res '())
(,res-end '())
(,tmp '()))
,(list (normalize
(if (null? (cdr args))
(list 'not (list 'pair? (car names)))
(list 'not (cons 'and (map (lambda (x)
(list 'pair? x))
names))))
#t var-nr)
res)
(set! ,tmp ,(normalize
(cons fun (map (lambda (x) (list 'car x)) names))
#f (+ 1 var-nr)))
(if (null? ,res)
(begin (set! ,res (cons ,tmp '()))
(set! ,res-end ,res))
(begin (set-cdr! ,res-end (cons ,tmp '()))
(set! ,res-end (cdr ,res-end)))))))
(define (normalize-if term bool-flag var-nr)
(if (null? (cddr term))
(list 'if
(normalize (car term) #t var-nr)
(normalize (cadr term) bool-flag var-nr)
*unspecified*)
(list 'if
(normalize (car term) #t var-nr)
(normalize (cadr term) bool-flag var-nr)
(normalize (caddr term) bool-flag var-nr))))
(define (normalize-do term bool-flag var-nr)
(if (or (null? (car term))
(null? (cdar term)))
(list* 'do
(map (lambda (x) (normalize x #f var-nr))
(car term))
(cons (normalize (caadr term) #t var-nr)
(map (lambda (x) (normalize x #f var-nr))
(cdadr term)))
(map (lambda (x) (normalize x #f var-nr))
(cddr term)))
(begin
(let* ((actual (filter (lambda (x) (not (null? (cddr x))))
(car term)))
(non-actual (filter (lambda (x) (null? (cddr x)))
(car term)))
(vars (map car actual))
(inits (map cadr actual))
(bodies (map caddr actual))
(new-var '())
(new-var-pairs '())
(new-bodies '()))
(do ((part actual (cdr part))
(vars-part vars (cdr vars-part))
(bodies-part bodies (cdr bodies-part)))
((null? part))
(if (inside-term? (car vars-part) (cdr bodies-part))
(begin
(set! var-nr (+ 1 var-nr))
(set! new-var (make-new-var var-nr))
(set! new-var-pairs
(cons (list new-var (car vars-part))
new-var-pairs))
(set! bodies-part
(cons (car bodies-part)
(subst-term new-var
(car vars-part)
(cdr bodies-part))))
(set! new-bodies
(cons (car bodies-part) new-bodies)))
(begin
(set! new-bodies
(cons (car bodies-part) new-bodies)))))
(if (null? new-var-pairs)
(list* 'do
(map (lambda (x) (normalize x #f var-nr))
(car term))
(cons (normalize (caadr term) #t var-nr)
(map (lambda (x) (normalize x #f var-nr))
(cdadr term)))
(map (lambda (x) (normalize x #f var-nr))
(cddr term)))
(list 'let*
(append
non-actual
(map (lambda (x) (list (car x) *dummy*)) new-var-pairs))
(list* 'do
(map (lambda (x y z)
(list x (normalize y #f var-nr)
(normalize z #f var-nr)))
vars
inits
(reverse new-bodies))
(cons (normalize (caadr term) #t var-nr)
(map (lambda (x) (normalize x #f var-nr))
(cdadr term)))
(append (map (lambda (x) (normalize x #f var-nr))
(cddr term))
(map (lambda (x) (cons 'set! x))
new-var-pairs)))))))))
;;; normalize-cond is one of the main transformers.
;;; It converts a cond to the if-ladder, introducing
;;; lets and new variables where needed.
;;;
;;; NB! In the following *and?* and *or?* are special new functions,
;;; which are considered to be strictly boolean, and can be
;;; converted directly to corresponding C operators.
(define (normalize-cond term bool-flag var-nr)
(cond
((null? term) *unspecified*)
((null? (cdar term))
(if bool-flag
`(*and?* ,(normalize (caar term) #t var-nr)
,(normalize-cond (cdr term) #t var-nr))
(let ((new-var (make-new-var (+ 1 var-nr))))
`(let* ((,new-var ,(normalize (caar term) #f (+ 1 var-nr))))
(if ,new-var ,new-var
,(normalize-cond (cdr term) #f var-nr))))))
((eq? (cadar term) '=>)
(let ((new-var (make-new-var (+ 1 var-nr))))
`(let* ((,new-var ,(normalize (caar term) #f (+ 1 var-nr))))
(if ,new-var
,(normalize (list (caddar term) new-var)
bool-flag (+ 1 var-nr))
,(normalize-cond (cdr term) bool-flag (+ 1 var-nr))))))
((eq? (caar term) 'else)
(if (null? (cddar term))
(normalize (cadar term) bool-flag var-nr)
(normalize (cons 'begin (cdar term)) bool-flag var-nr)))
((null? (cddar term))
`(if ,(normalize (caar term) #t var-nr)
,(normalize (cadar term) bool-flag var-nr)
,(normalize-cond (cdr term) bool-flag var-nr)))
(else
`(if ,(normalize (caar term) #t var-nr)
,(normalize (cons 'begin (cdar term)) bool-flag var-nr)
,(normalize-cond (cdr term) bool-flag var-nr)))))
;;; normalize-not creates a c-not (*not?* => !) or a scheme-not (not)
(define (normalize-not lst bool-flag var-nr)
(if bool-flag
(normalize (cons *not?* lst) #t var-nr)
(list 'not (normalize (car lst) #t var-nr))))
;;; normalize-and and normalize-or make some optimizations
;;; and convert terms to if-ladders of *and?* and *or?*.
(define (normalize-and lst bool-flag var-nr)
(cond ((null? lst) #t)
((null? (cdr lst)) (normalize (car lst) bool-flag var-nr))
((and bool-flag (not *lift-and-or-flag*))
(normalize (cons *and?* lst) #t var-nr))
(else
`(if ,(normalize (car lst) #t var-nr)
,(normalize-and (cdr lst) bool-flag var-nr)
#f ))))
(define (normalize-or lst bool-flag var-nr)
(cond ((null? lst) #f)
((null? (cdr lst)) (normalize (car lst) bool-flag var-nr))
((and bool-flag (not *lift-and-or-flag*))
(normalize (cons *or?* lst) #t var-nr))
(bool-flag
`(if ,(normalize (car lst) #t var-nr)
#t
,(normalize-or (cdr lst) #t var-nr)))
(else
(normalize `(cond ,@(map list (butlast lst 1))
(else ,(car (my-last-pair lst))))
bool-flag var-nr ))))
;;; normalize-case does the obvious thing.
(define (normalize-case term bool-flag var-nr)
(let* ((new-var (make-new-var (+ 1 var-nr)))
(tmp
`(let* ((,new-var ,(cadr term)))
(cond
,@(normalize-case-aux new-var (cddr term))))))
(normalize tmp bool-flag (+ 1 var-nr))))
(define (normalize-case-aux var lst)
(cond ((null? lst) '())
((eq? (caar lst) 'else) (list (car lst)))
((list? (caar lst))
(append (map (lambda (x) `((eqv? (quote ,x) ,var) ,@(cdar lst)))
(caar lst))
(normalize-case-aux var (cdr lst))))
(else (report-error "Bad case clause syntax:" lst))))
;;; file-opening and calling with normalization assumes a single
;;; generic file opening two-arg function *open-file-function* and
;;; corresponding strings for input and output.
;;; Calling with files is normalized into a let with assuming
;;; a function *set-current-input-port-function* and a function
;;; *set-current-output-port-function*
(define (normalize-open-input-file term bool-flag var-nr)
(list *open-file-function*
(normalize (car term) #f var-nr)
*input-file-modifier*))
(define (normalize-open-output-file term bool-flag var-nr)
(list *open-file-function*
(normalize (car term) #f var-nr)
*output-file-modifier*))
(define (normalize-with-input-from-file term bool-flag var-nr)
(let* ((new-var1 (make-new-var (+ 1 var-nr)))
(new-var2 (make-new-var (+ 2 var-nr)))
(new-var3 (make-new-var (+ 3 var-nr))))
`(let* ((,new-var1 (,*open-file-function*
,(normalize (car term) #f new-var3)
,*input-file-modifier*))
(,new-var2 (,*set-current-input-port-function* ,new-var1))
(,new-var3 (,(normalize (cadr term) bool-flag new-var3))))
(close-input-port ,new-var1)
(,*set-current-input-port-function* ,new-var2)
,new-var3)))
(define (normalize-with-output-to-file term bool-flag var-nr)
(let* ((new-var1 (make-new-var (+ 1 var-nr)))
(new-var2 (make-new-var (+ 2 var-nr)))
(new-var3 (make-new-var (+ 3 var-nr))))
`(let* ((,new-var1 (,*open-file-function*
,(normalize (car term) #f new-var3)
,*output-file-modifier*))
(,new-var2 (,*set-current-output-port-function* ,new-var1))
(,new-var3 (,(normalize (cadr term) bool-flag new-var3))))
(,*set-current-output-port-function* ,new-var2)
(close-output-port ,new-var1)
,new-var3)))
(define (normalize-call-with-input-file term bool-flag var-nr)
(let* ((new-var1 (make-new-var (+ 1 var-nr)))
(new-var2 (make-new-var (+ 2 var-nr))))
`(let* ((,new-var1 (,*open-file-function*
,(normalize (car term) #f new-var2)
,*input-file-modifier*))
(,new-var2 (,(normalize (cadr term) bool-flag new-var2)
,new-var1)))
(close-input-port ,new-var1)
,new-var2)))
(define (normalize-call-with-output-file term bool-flag var-nr)
(let* ((new-var1 (make-new-var (+ 1 var-nr)))
(new-var2 (make-new-var (+ 2 var-nr))))
`(let* ((,new-var1 (,*open-file-function*
,(normalize (car term) #f new-var2)
,*output-file-modifier*))
(,new-var2 (,(normalize (cadr term) bool-flag new-var2)
,new-var1)))
(close-output-port ,new-var1)
,new-var2)))
;;; The following normalize-comparisons and
;;; normalize-associative convert associative functions into
;;; functions of exactly the arity two. List function is replaced
;;; by a corresponding cons structure.
(define (normalize-list term bool-flag var-nr)
(normalize (normalize-list-aux (cdr term)) bool-flag var-nr))
(define (normalize-list-aux lst)
(cond ((null? lst) ''())
((null? (cdr lst)) `(cons ,(car lst) '()))
(else
`(cons ,(car lst)
,(normalize-list-aux (cdr lst))))))
(define (normalize-list-for-c lst)
(cond ((null? lst) '())
((null? (cdr lst)) `(cons ,(car lst) ()))
(else
`(cons ,(car lst)
,(normalize-list-for-c (cdr lst))))))
(define (normalize-comparison data lst bool-flag var-nr)
(cond ((null? lst) (report-error "too few args in comparison " (car data)))
((null? (cdr lst))
(report-error "too few args in comparison " (car data)))
((null? (cddr lst))
(list (car data)
(normalize (car lst) #f var-nr)
(normalize (cadr lst) #f var-nr)))
;;at least three args left
(else (list *and?*
(normalize-comparison data (butlast lst 1)
#t var-nr)
(let* ((rev (reverse lst))
(tmp (list
(normalize (cadr rev) #t var-nr)
(normalize (car rev) #t var-nr))))
(cons (car data) tmp))))))
(define (normalize-string-append term bool-flag var-nr)
(list (car term)
(normalize (normalize-list-aux (cdr term)) #f var-nr)))
(define (normalize-associative data lst bool-flag var-nr)
(cond ((null? lst) (cadr data))
((null? (cdr lst))
(list (car data)
(cadr data)
(normalize (car lst) (boolean? (cadr data)) var-nr)))
((null? (cddr lst))
(list (car data)
(normalize (car lst) (boolean? (cadr data)) var-nr)
(normalize (cadr lst) (boolean? (cadr data)) var-nr)))
;;at least three args left
((boolean? (cadr data)) ; *or?* and *and?*
(list (car data)
(normalize (car lst) #t var-nr)
(normalize-associative data (cdr lst) #t var-nr)))
(else
(list (car data)
(normalize-associative data (butlast lst 1) #f var-nr)
(normalize (car (my-last-pair lst)) #f var-nr)))))
(define *associative-fun-table*
(append
(list (cons *or?* '(#f bool)) (cons *and?* '(#t bool)))
'((append '() lst) ;;; (string-append "" str)
(+ 0 num) (- 0 num) (* 1 num) (/ 1 num) (max -99999 num) (min 99999 num)
(%+ 0 num) (%- 0 num) (%* 1 num) (%/ 1 num))))
(define *comparison-fun-table*
'((= num) (< num) (> num) (<= num) (>= num)
(%= num) (%< num) (%> num) (%<= num) (%>= num)
(char=? chr) (char? chr) (char<=? chr) (char>=? chr)
(char-ci=? chr) (char-ci? chr)
(char-ci<=? chr) (char-ci>=? chr)
(string=? str) (string? str) (string<=? str) (string>=? str)
(string-ci=? str) (string-ci? str)
(string-ci<=? str) (string-ci>=? str)))
; pre-4d-version:
;(define (make-new-var nr)
; (string->symbol (string-append *new-var-name* (number->string nr))))
; from-4d-version:
(define (make-new-var nr)
(set! *new-vars-nr-for-topfun* (+ 1 *new-vars-nr-for-topfun*))
(string->symbol (string-append *new-var-name*
(number->string *new-vars-nr-for-topfun*))))
;==================================================================
;
; delay transformer
;
;=================================================================
;;; The following normalizes applications of 'delay'.
;;; It should be used as a preprocessor to normalizer.
(define (normalize-delay term)
(cond ((not (pair? term)) term)
((not (some-in-fun-position? '(delay force) term))
term)
((eq? (car term) 'quote) term)
((eq? (car term) 'lambda)
`(lambda ,(cadr term) ,@(normalize-delay (cddr term))))
((eq? (car term) 'define)
(cons 'define
(cons (cadr term)
(normalize-delay (cddr term)))))
((and (eq? (car term) 'delay)
(pair? (cdr term))
(null? (cddr term)))
`(,*make-promise-function*
(lambda () ,(normalize-delay (cadr term)))))
((and (eq? (car term) 'force)
(pair? (cdr term))
(null? (cddr term)))
`(,*force-function* ,(normalize-delay (cadr term))))
(else
(map normalize-delay term))))
;==================================================================
;
; quasiquote transformer
;
;=================================================================
;;; The following compiles quasiquotes. It should be used as a
;;; preprocessor to normalizer. It should compile the full
;;; quasiquote syntax, including nested quasiquotes.
(define (compile-quasiquote term)
(cond ((not (pair? term)) term)
((not (occurs-in-function-position? 'quasiquote term)) term)
((eq? (car term) 'quote) term)
((eq? (car term) 'lambda)
`(lambda ,(cadr term) ,@(compile-quasiquote (cddr term))))
((eq? (car term) 'define)
(cons 'define
(cons (cadr term)
(compile-quasiquote (cddr term)))))
((eq? (car term) 'quasiquote)
(normalize-quasiquote (cadr term) 1))
(else
(map compile-quasiquote term))))
(define (normalize-quasiquote term depth)
(cond
;;; ((not (or (occurs-in-function-position? 'unquote term)
;;; (occurs-in-function-position? 'unquote-splicing term)))
;;; `(quote ,term))
((vector? term)
`(apply vector ,(normalize-quasiquote (vector->list term) depth)))
((not (pair? term))
`(quote ,term))
((and (eq? (car term) 'unquote) (eqv? depth 1))
(car (compile-quasiquote (cdr term))))
((not (pair? (car term)))
`(cons (quote ,(car term))
,(normalize-quasiquote (cdr term) depth)))
((eq? (caar term) 'unquote)
(if (eqv? depth 1)
`(cons ,(compile-quasiquote (cadar term))
,(normalize-quasiquote (cdr term) depth))
(list 'cons
(list 'cons
''unquote
(normalize-quasiquote (cdar term) (- depth 1)))
(normalize-quasiquote (cdr term) depth))))
((eq? (caar term) 'unquote-splicing)
(if (eqv? depth 1)
`(append ,(compile-quasiquote (cadar term))
,(normalize-quasiquote (cdr term) depth))
(list 'cons
(list 'cons
''unquote-splicing
(normalize-quasiquote (cdar term) (- depth 1)))
(normalize-quasiquote (cdr term) depth))))
((eq? (caar term) 'quasiquote)
`(cons ,(normalize-quasiquote (car term) (+ 1 depth))
,(normalize-quasiquote (cdr term) depth)))
(else
`(cons ,(normalize-quasiquote (car term) depth)
,(normalize-quasiquote (cdr term) depth)))))
(define (occurs-in-function-position? f term)
(and (pair? term)
(or (and (eq? (car term) f) (list? (cdr term)))
(occurs-in-function-position? f (car term))
(occurs-in-function-position? f (cdr term)))))
;=============================================================
;
; removing topmost surrounding let's
;
;===========================================================
(define (remove-lambdasurrounding-let def)
(if (and (list? def)
(eq? 3 (length def))
(pair? (caddr def))
(or (eq? 'let (car (caddr def)))
(eq? 'let* (car (caddr def))))
(pair? (cddr (caddr def)))
(pair? (caddr (caddr def)))
(null? (cdddr (caddr def)))
(eq? 'lambda (car (caddr (caddr def)))))
(remove-lambdasurrounding-let-aux def)
def))
(define (remove-lambdasurrounding-let-aux def)
(let* ((letbindings (cadr (caddr def)))
(lambdaterm (caddr (caddr def))))
(set! *global-vars-list*
(append *global-vars-list* (map car letbindings)))
(set! *top-actions-list*
(append (map (lambda (x)
(let ((name (make-constant-name)))
(set! *var-make-list*
(cons
(list 'set! (car x)
(list 'scm-gc-protect
(list *c-adr* name)))
*var-make-list*))
(set! *via-interpreter-defined*
(cons (car x) *via-interpreter-defined*))
(list 'set! (car x) (cadr x))))
letbindings)
*top-actions-list*))
(list (car def) (cadr def) lambdaterm)))
;=============================================================
;
; variable renaming
;
;============================================================
;;; rename-vars performs a very important function: it renames
;;; vars, removing clashes of bound variable names.
;;; rename-vars tries to rename as few variables as possible;
;;; in doing that it takes into account that all variable declarations
;;; in the term should be liftable to the very top of the term.
;;;
;;; After applying rename-vars, all variable bindings in lets can
;;; (and should) be changed to simple set!s in the corresponding order.
;;;
;;; That is, the resulting let is actually a let*, or, better yet,
;;; (let ((a b) ... (g h)) ...) should be treated
;;; as (begin (set! a b) ... (set! g h) ...).
;;; All the variables introduced in such lets should be declared
;;; as local variables of a pointer type in the corresponding
;;; c function, and set! should be translated to = in the
;;; obvious way. Thus the resulting let can be translated to the
;;; C block, for example.
;;;
;;; NB! Different types of lets (including the one in do) are all
;;; converted to the scheme explained above.
;;;
;;; NB! Letrec is not handled fully here, in the sense that when
;;; we perform lambda-lifting, there are some special complexities
;;; which must be handled.
(define *passed-locvars-list* '())
(define (rename-vars term)
(set! *var-nr* 0)
(set! *passed-locvars-list* '())
(set! *free-vars-list* (all-free-vars term))
(rename-vars-aux term '() #t))
;;; rename-vars-aux takes a topflag, which is true iff term is NOT yet
;;; inside some lambdaterm. In that case all the vars bound in let are
;;; renamed by a global scheme in order to be initialized in the
;;; initialization function.
(define (rename-vars-aux term env topflag)
(cond
((symbol? term)
(cond ((assq term env) => cdr)
(else term)))
((not (pair? term)) term)
((eq? 'quote (car term)) term)
((eq? 'lambda (car term))
`(lambda
,@(rename-vars-aux (cdr term)
(make-new-env-lambda
(args->list (cadr term))
env)
#f)))
((eq? 'let (car term))
(let ((new-env (make-new-env (map car (cadr term)) env topflag)))
`(let
,(map (lambda (x)
(list (rename-vars-aux (car x) new-env topflag)
(rename-vars-aux (cadr x) env topflag)))
(cadr term))
,@(rename-vars-aux (cddr term) new-env topflag))))
((eq? 'do (car term))
(let ((new-env (make-new-env (map car (cadr term)) env #f)))
`(do
,(map (lambda (x)
(cons (rename-vars-aux (car x) new-env #f)
(cons (rename-vars-aux (cadr x) env #f)
(rename-vars-aux (cddr x)
new-env #f))))
(cadr term))
,@(rename-vars-aux (cddr term) new-env #f))))
((eq? 'let* (car term))
(let ((new-env env)
(old-env env)
(new-args '()))
(do ((part (cadr term) (cdr part)))
((null? part)
`(let
,(reverse new-args)
,@(rename-vars-aux (cddr term) new-env topflag)))
(set! old-env new-env)
(set! new-env (make-new-env (list (caar part)) new-env topflag))
(set! new-args
(cons (list (rename-vars-aux (caar part) new-env topflag)
(rename-vars-aux
(cadar part) old-env topflag))
new-args )))))
((eq? 'letrec (car term))
(let ((new-env (make-new-env (map car (cadr term)) env topflag)))
`(letrec ,@(rename-vars-aux (cdr term) new-env topflag))))
((eq? 'define (car term))
(map (lambda (x) (rename-vars-aux x env topflag)) term))
((list? term)
(map (lambda (x) (rename-vars-aux x env #f)) term))
(else (cons (rename-vars-aux (car term) env #f)
(rename-vars-aux (cdr term) env #f)))))
(define (args->list args)
(cond ((symbol? args) (list args))
((list? args)
(map (lambda (x) (if (pair? x) (cadr x) x)) args))
((pair? args)
(cons (if (pair? (car args)) (cadar args) (car args))
(args->list (cdr args))))
(else (report-error "Bad argument list:" args))))
(define (make-new-env vars env topflag)
(let ((name '()))
(append (map (lambda (x)
(cond
((or (memq x *new-fun-names*)
(and (not (assq x env))
(not topflag)
(not (memq x *keywords*))
(not (memq x *primitives*))
(not (memq x *top-level-names*))
(not (memq x *passed-locvars-list*))
(not (memq x *free-vars-list*))))
(set! *passed-locvars-list*
(cons x *passed-locvars-list*))
(cons x x))
((not topflag)
(set! *var-nr* (+ 1 *var-nr*))
(cons x
(string->symbol
(string-append
(symbol->string x)
*local-var-infix*
(number->string *var-nr*)))))
(else
(set! *new-fun-nr* (+ 1 *new-fun-nr*))
(cons x
(string->symbol
(string-append
(symbol->string x)
*new-fun-infix*
(number->string *new-fun-nr*)))))))
vars)
env )))
(define (make-new-env-lambda vars env)
(append (map (lambda (x)
(if (or (assq x env)
(memq x *keywords*)
(memq x *primitives*)
(memq x *top-level-names*))
(cons x
(string->symbol
(string-append
(symbol->string x)
*local-var-infix*
(begin (set! *var-nr* (+ 1 *var-nr*))
(number->string *var-nr*)))))
(cons x x)))
vars )
env ))
;===============================================================
;
; define - transformer
;
;===============================================================
;;; normalize-defines converts fancy defines into basic ones.
(define (normalize-defines term)
(cond
((not (pair? term)) term)
((eq? (car term) 'quote) term)
((eq? (car term) 'define)
;; the coming if removes let in the case:
;; (define foo (let ((bar bar)) ...))
;; (if (and (pair? (cdr term))
;; (pair? (cddr term))
;; (pair? (caddr term))
;; (memq (car (caddr term)) '(let let* letrec))
;; (pair? (cadr (caddr term)))
;; (not (find-if (lambda (x) (not (eq? (car x) (cadr x))))
;; (cadr (caddr term)))))
;; (set! term (cons 'define (cons (cadr term) (cddr (caddr term))))))
(if (pair? (cadr term))
`(define ,(caadr term)
,(normalize-defines
(cons 'lambda (cons (cdadr term) (cddr term)))))
`(define ,(cadr term) ,(normalize-defines (caddr term)))))
((and (memq (car term) '(let* letrec))
(not (list? (cadr term))))
(report-error
"In " *current-fun-name* " there is wrong let: " term))
;;; the next case rewrites a named let to a letrec, never succeeds.
((begin
(if (and (eq? (car term) 'let)
(not (null? (cdr term)))
(not (null? (cddr term)))
(symbol? (cadr term))
(not (null? (cadr term))))
;;; a named let
(if (find-if (lambda (x)
(or (null? x) (not (list? x)) (null? (cdr x))))
(caddr term))
(report-error
*current-fun-name*
" contains an incorrect named let: " term)
(let ((param (map car (caddr term)))
(args (map cadr (caddr term))))
(set! term
(list 'letrec
(list
(list (cadr term)
(list* 'lambda param (cdddr term))))
(cons (cadr term) args))))))
#f))
((and (memq (car term) '(lambda let let* letrec do))
(pair? (caddr term))
(eq? 'define (caaddr term)))
(let ((defs (normalize-defines-aux (cddr term)))
(other (member-if
(lambda (x)
(or (not (pair? x)) (not (eq? (car x) 'define))))
(cddr term))))
(if (not other) (report-error "Body is missing:" term))
`(,(car term)
,(normalize-defines (cadr term))
,(normalize-defines (cons 'letrec (cons defs other))))))
((list? term)
(map normalize-defines term))
(else
(cons (normalize-defines (car term))
(normalize-defines (cdr term))))))
(define (normalize-defines-aux lst)
(if (and (not (null? lst)) (pair? (car lst)) (eq? 'define (caar lst)))
(cons (cdr (normalize-defines (car lst)))
(normalize-defines-aux (cdr lst)))
'()))
;=================================================================
;
; Global analysis
;
;=================================================================
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; analysis for liftability and mutability
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
; lift-analyse-def! takes a def where all the lambdas are renamed
; (by taking extra let-s with names), vars are renamed and letrecs
; are ordered.
;
; it dest. changes the def body by replacing the leading lambda of
; all the liftable lambdaterms with the value of *liftable-lambda*
(define *local-liftnames* '())
(define *liftable-lambda* '**liftable-lambda**)
(define *def-hofname* '())
(define (lift-analyse-def! def)
(let* ((funname (cadr def))
(lterm (caddr def)))
(set! *local-liftnames* '())
(set! *def-hofname* funname)
(lift-analyse-def-aux! lterm)
(if (and (pair? lterm)
(not (all-liftable? (cdr lterm))))
(set! *not-all-liftable-names*
(cons funname *not-all-liftable-names*)))))
; lift-analyse-def-aux! term:
; term is a term
;
; all lambdaterms must be named.
;
; liftable lambdas are destr. replaced by *liftable-lambda*,
; their names are added to *local-liftnames*
;
(define (lift-analyse-def-aux! term)
(let* ((name '())
(passed '())
(tmp '()))
(cond
((not (pair? term)))
((eq? 'quote (car term)))
((eq? 'lambda (car term))
(for-each (lambda (x) (lift-analyse-def-aux! x)) (cddr term)))
;;; ((eq? *liftable-lambda* (car term))
;;; (for-each (lambda (x) (lift-analyse-def-aux! x)) (cddr term)))
((and (pair? (car term))
(eq? 'lambda (caar term)))
(for-each lift-analyse-def-aux! (cddar term))
(if (all-liftable? (cddar term))
(set-car! (car term) *liftable-lambda*))
(for-each lift-analyse-def-aux! (cdr term)))
((memq (car term) '(let* let))
(for-each lift-analyse-def-aux! (cddr term))
(do ((part (reverse (cadr term)) (cdr part)))
((null? part))
(set! name (caar part))
(lift-analyse-def-aux! (cadar part))
(if (and (pair? (cadar part))
(eq? 'lambda (caadar part))
(all-liftable? (cddr (cadar part)))
(liftable-nameocc? name (cddr (cadar part)))
(liftable-nameocc? name (cons 'begin passed))
(liftable-nameocc? name (cons 'begin (cddr term))))
(begin
(set! *local-liftnames*
(cons name *local-liftnames*))
(set-car! (cadar part) *liftable-lambda*)))
(set! passed (cons (cadar part) passed))))
((eq? (car term) 'letrec)
(for-each lift-analyse-def-aux! (cddr term))
(for-each (lambda (el) (lift-analyse-def-aux! (cadr el))) (cadr term))
(if (and (every1 (lambda (el)
(and (pair? (cadr el))
(eq? 'lambda (caadr el))
(all-liftable? (cddr (cadr el)))))
(cadr term))
(every1 (lambda (el)
(and (liftable-nameocc? (car el)
(cons 'begin (cddr term)))
(every1 (lambda (el2)
(liftable-nameocc?
(car el) (cddr (cadr el2))))
(cadr term))))
(cadr term)))
(for-each (lambda (el)
(set! *local-liftnames*
(cons (car el) *local-liftnames*))
(set-car! (cadr el) *liftable-lambda*))
(cadr term))))
((and (liftable-hofname? (car term))
(not (eq? (car term) *def-hofname*)))
(set! tmp (assq (car term) *liftable-hof-database*))
;; (if tmp (begin (newline) (display "term: ") (display term) (newline)))
(if tmp
;; case for top-level def of a higher-order fun:
(if (every1 (lambda (x)
;; (newline) (display "x: ") (display x) (newline)
(let ((param (car x))
(arg (cdr x)))
;; (display "param: ") (display param) (newline)
;; (display "arg: ") (display arg) (newline)
(if param
(or (and (pair? arg)
(or (eq? 'lambda (car arg))
(eq? *liftable-lambda*
(car arg)))
(begin
(for-each
lift-analyse-def-aux!(cddr arg))
;; (newline) (display "cddr arg:")
;; (display (cddr arg)) (newline)
(all-liftable? (cddr arg))))
(and (symbol? arg)
(memq arg *top-level-names*)
(not (modified-fun? arg))))
#t)))
(map cons (cdr tmp) (cdr term)))
(for-each (lambda (param arg)
(if (and param
(pair? arg)
(eq? 'lambda (car arg))
(all-liftable? (cddr arg)))
(set-car! arg *liftable-lambda*)))
(cdr tmp)
(cdr term))
(let ((name
(string->symbol
(string-append (symbol->string (car term))
*export-hof-postfix*))))
(set! *top-level-names*
(cons name *top-level-names*))
(set-car! term name)))
;; case for map and for-each:
(for-each (lambda (arg)
(if (and (pair? arg)
(eq? 'lambda (car arg)))
(set-car! arg *liftable-lambda*)))
(cdr term)))
(for-each (lambda (x) (lift-analyse-def-aux! x)) (cdr term)))
(else
(for-each (lambda (x) (lift-analyse-def-aux! x)) term)))))
(define (all-liftable? term)
(cond ((not (pair? term)) (not (eq? 'lambda term)))
((eq? 'quote (car term)) #t)
(else (and (all-liftable? (car term))
(all-liftable? (cdr term))))))
(define (guaranteed-all-liftable? term)
(cond ((not (pair? term)) (not (eq? 'lambda term)))
((eq? 'quote (car term)) #t)
((and (or (eq? 'map (car term)) (eq? 'for-each (car term))
(eq? *map1-function* (car term))
(eq? *for-each1-function* (car term)))
(pair? (cdr term))
(pair? (cadr term)))
(and (guaranteed-all-liftable? (cdadr term))
(guaranteed-all-liftable? (cddr term))))
(else (and (guaranteed-all-liftable? (car term))
(guaranteed-all-liftable? (cdr term))))))
(define (lift-unmark-def! term)
(cond
((not (pair? term)))
((eq? 'quote (car term)))
((eq? *liftable-lambda* (car term))
(set-car! term 'lambda)
(for-each lift-unmark-def! (cdr term)))
((list? term)
(for-each lift-unmark-def! term))
(else term)))
; liftable-nameocc? name term:
; name a name of some fun,
; term is the term where the use of name is checked.
;
; gives #f iff name is used in the nonliftable context
(define (liftable-nameocc? name term)
(cond
((not (pair? term)) #t)
((eq? 'quote (car term)) #t)
((eq? 'lambda (car term))
(not (inside-term? name (cddr term))))
((and (memq name (cdr term))
(not (liftable-hofname? (car term))))
#f)
(else
(every1 (lambda (x) (liftable-nameocc? name x)) term))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; checking liftability of higher-order funs
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define *liftable-hof-primitives*
(list *map1-function* *for-each1-function* 'map 'for-each))
(define (liftable-hofname? name)
(and (or (memq name *liftable-hof-primitives*)
(memq name *liftable-hof-names*))
(not (modified-fun? name))))
; liftable-hof? lterm name:
; checks whether lterm with name is a liftable hof
(define (liftable-hof? lterm name)
(let* ((args (args->list (cadr lterm)))
(hof-args (filter-hof-args lterm args)))
(if (and (not (null? hof-args))
(liftable-nameocc? name (cddr lterm))
(not (member-if (lambda (x)
(not (liftable-hofvars-usage?
x name hof-args args)))
(cddr lterm))))
(begin
(set! *liftable-hof-database*
(cons (cons name (map (lambda (x) (if (memq x hof-args) #t #f))
args))
*liftable-hof-database*))
#t)
(if (not (null? hof-args))
(begin (set! *non-liftable-hof-names*
(cons name *non-liftable-hof-names*))
#f)
#f))))
; filter-hof-args term args:
; filters out the functional args from args
(define *found-hof-args* '())
(define *check-hof-args* '())
(define (filter-hof-args term args)
(if (null? args)
'()
(begin
(set! *check-hof-args* args)
(set! *found-hof-args* '())
(filter-hof-args-aux! term)
*found-hof-args*)))
(define (filter-hof-args-aux! term)
(let* ((tmp '()))
(cond
((null? *check-hof-args*))
((not (pair? term)))
((eq? 'quote (car term)))
((eq? 'lambda (car term))
(for-each filter-hof-args-aux! (cddr term)))
((begin (set! tmp (memq (car term) *check-hof-args*))
tmp)
(set! *found-hof-args* (cons (car tmp) *found-hof-args*))
(set! *check-hof-args* (remove-one (car tmp) *check-hof-args*))
(for-each filter-hof-args-aux! term))
(else
(for-each filter-hof-args-aux! term)))))
; liftable-hofvars-usage? term name hof-args:
; checks that hof-args are used in the term with name only
; in the function position or as same args to name itself and
; that the name is not called with lambdaterms at hof-places
; and that hof-places are exactly the same args.
; hof-args may also not occur in the inside lambda-terms.
(define (liftable-hofvars-usage? term name hof-args args)
(cond
((not (pair? term)) #t)
((eq? 'quote (car term)) #t)
((or (eq? 'lambda (car term)) (eq? *liftable-lambda* (car term)))
(not (find-if (lambda (x) (some-inside-term? hof-args x)) (cddr term))))
((eq? name (car term))
(every1 (lambda (x)
(let ((param (car x))
(arg (cdr x)))
(if (memq param hof-args)
(eq? param arg)
(and (not (memq arg hof-args))
(not (and (pair? arg) (eq? 'lambda (car arg))))))))
(map cons args (cdr term))))
(else
(and (every1 (lambda (el) (not (memq el hof-args))) (cdr term))
(every1 (lambda (x) (liftable-hofvars-usage? x name hof-args args))
term)))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; checking for redefining of functions
;
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define *keywords*
'(=> and begin case cond define delay do else if lambda
let let letrec or quasiquote quote set! unquote
unquote-splicing))
(define (modified-fun? name)
(cond
(*all-funs-modified-flag*
(or (memq name *primitives*)
(memq name *top-level-names*)))
(*new-funs-modified-flag*
(or (memq name *modified-primitives*)
(memq name *top-level-names*)))
(else
(or (memq name *modified-primitives*)
(memq name *modified-top-level-names*)))))
(define *top-level-names* '())
(define *modified-primitives* '())
(define *modified-top-level-names* '())
(define (make-top-level-namelist! expr-list)
(set! *top-level-names* '())
(set! *modified-primitives* '())
(set! *modified-top-level-names* '())
(set! *check-redefining-passed* '())
(make-top-level-namelist-aux! expr-list #f)
;;; (pretty-print expr-list)
(make-top-level-namelist-aux! expr-list #t)
;;; (pretty-print expr-list)
(set! *modified-primitives*
(set-difference *modified-primitives* *general-transcedentals*))
*top-level-names*)
(define *general-transcedentals*
'(sqrt log expt exp sin cos tan asin acos atan sinh cosh tanh asinh tanh
asinh acosh atanh))
(define (make-top-level-namelist-aux! expr-list redefining-flag)
(if (and (pair? expr-list) (list? expr-list))
(for-each
(lambda (expr)
(cond
((not (pair? expr)))
((not (list? expr)))
((eq? 'quote (car expr)))
((eq? (car expr) 'define)
(let ((new (normalize-top-define expr)))
(if redefining-flag
(check-redefining! new #t)
(set! *top-level-names*
(cons (cadr new) *top-level-names*)))))
((and (eq? 'set! (car expr))
redefining-flag)
(check-redefining! expr #t))
((not redefining-flag)
(for-each (lambda (x) (make-top-level-namelist-aux! x #f))
expr))))
expr-list)))
(define (compute-floats-flag! term opsflag)
(cond (*floats-flag* #t)
((pair? term)
(if (eq? 'quote (car term))
(compute-floats-flag! (cdr term) #f)
(or (compute-floats-flag! (car term) opsflag)
(compute-floats-flag! (cdr term) opsflag))))
((vector? term)
(do ((i (- (vector-length term) 1) (- i 1)))
((< i 0) *floats-flag*)
(compute-floats-flag! (vector-ref term i) opsflag)))
((number? term)
(if (or (not (integer? term))
(not (exact? term))
(> term most-positive-fixnum)
(< term most-negative-fixnum))
(begin (set! *floats-flag* term) #t)
#f))
((not opsflag) #f)
((symbol? term)
(if (memq term *float-recognize-ops*)
(begin (set! *floats-flag* term) #t)
#f))
(else #f)))
(define *float-recognize-ops*
'(ln sqrt log exp
sin cos tan asin acos atan
sinh cosh tanh asinh acosh atanh
real-sin real-cos real-tan
real-asin real-acos real-atan
real-sinh real-cosh real-tanh
real-asinh real-acosh real-atanh
real-sqrt real-expt real-ln real-exp
$sin $cos $tan $asin $acos $atan
$sinh $cosh $tanh $asinh $acosh $atanh
$sqrt $expt $log $abs $exp))
(define *check-redefining-passed* '())
(define (check-redefining! term top-level-flag)
(let* ((new '()))
(cond
((not (pair? term)))
((not (list? term)))
((eq? 'quote (car term)))
((or (eq? 'set! (car term))
(and top-level-flag (eq? 'define (car term))))
(if (eq? 'define (car term))
(set! new (normalize-top-define term))
(set! new term))
(if (not (eq? 3 (length term)))
(report-error " wrong set! or define syntax: " term))
(if (memq (cadr new) *keywords*)
(report-error " a keyword is set! or defined: " term))
(if (memq (cadr new) *primitives*)
(or (memq (cadr new) *modified-primitives*)
(set! *modified-primitives*
(cons (cadr term) *modified-primitives*))))
(if (and (memq (cadr new) *top-level-names*)
(not (memq (cadr new) *hobbit-declaration-vars*)))
(or (memq (cadr new) *modified-top-level-names*)
(if (and (eq? 'define (car new))
(not (memq (cadr new) *check-redefining-passed*)))
(set! *check-redefining-passed*
(cons (cadr new) *check-redefining-passed*))
(set! *modified-top-level-names*
(cons (cadr new) *modified-top-level-names*)))))
(check-redefining! (caddr new) #f))
((eq? 'begin (car term))
(for-each (lambda (x) (check-redefining! x #t)) term))
(else
(for-each (lambda (x) (check-redefining! x #f)) term)))))
;=====================================================================
;
; Building closures
;
;====================================================================
;(define *closure-name-suffix* "_cl")
;(define *closure-name-nr* 0)
;(define *closure-vector-name* "clargsv_")
;(define *closure-vector-name-nr* 0)
;(define *closurefun-arg* 'closurearg_0)
;(define *closurefun-arg-car* 'closurearg_car_0)
; The whole closurebuilding process is carried on top-down breadth-first:
; there is no excplicit recursion. Instead, once a new closurefun def
; is created, it is put into the list *lifted-closures-to-do*, which
; is afterwards passed and the lambdaterms inside these new funs are
; made into closures again, etc, until *lifted-closures-to-do* is empty.
; try-closure-making-def is the topmost closure-builder applied to a def.
(define (try-closure-making-def def)
(let* ((body (caddr def)))
(set! *letrec-closure-nr* 0)
(cond ((not (pair? body)) def)
((eq? 'quote (car body)) def)
((eq? 'lambda (car body)) (try-closure-making-ldef def))
(else (report-error "try-closure-making-non-ldef called")))))
; try-closure-making-ldef builds closures for lambdaterm-defs.
; It is never called from anywhere except try-closure-making-def
; (the topmost closurebuilder)
(define (try-closure-making-ldef def)
(let* ((lterm (caddr def))
(lvars (args->list (cadr lterm)))
(letvars (collect-local-vars (cddr lterm)))
(vars (union lvars letvars))
;; closurevars is the subset of set! inside lambdas:
(closurevars (closure-building-vars (cddr lterm) vars))
(vectname (make-closure-vector-name)))
(set! *current-fun-name* (cadr def))
(if (null? closurevars)
;; no set! closurevars found:
(list (car def) (cadr def)
(list* (car lterm) (cadr lterm)
(map (lambda (x)
(cdr (make-closure-making
x vars closurevars
*closurefun-arg-car* vectname)))
(cddr lterm))))
;; in the next case some closurevars were found.
(let* ((tmp (make-closure-making
(cddr lterm) vars closurevars
*closurefun-arg-car* vectname))
(varsmapping (car tmp))
(newterm (cdr tmp))
(initialize-argsv
(make-initialize-closureargsv vectname lvars varsmapping)))
(if (not (null? varsmapping))
(beautify-closure
(list
(car def)
(cadr def)
(cons (car lterm)
(list (cadr lterm)
(cons 'let*
(cons (cons (list vectname
(list 'make-vector
(length closurevars)))
'())
(append initialize-argsv
newterm)))))))
(beautify-closure
(list
(car def)
(cadr def)
(cons (car lterm)
(list (cadr lterm)
(append initialize-argsv newterm))))))))))
; make-closure-vector-name builds a new vector for these local vars
; which are passed to (and set! inside) closures.
; default: clargsv_
;
; It is called from try-closure-making-ldef, ..-non-ldef, ...-lterm.
;
; The created vector-name is added to *closure-var-vectornames*
; for later recognition as such.
(define (make-closure-vector-name)
(set! *closure-vector-name-nr* (+ 1 *closure-vector-name-nr*))
(let ((res (string->symbol
(string-append *closure-vector-name*
(number->string *closure-vector-name-nr*)))))
(if (not (memq res *closure-var-vectornames*))
(set! *closure-var-vectornames* (cons res *closure-var-vectornames*)))
res))
; make-closure-name adds a suffix (default: _cl (+nr)) to the
; argument functionname. The returned name will be used as a name
; of the created closurefunction.
;
; called from: make-closure-making-aux and make-trivial-closuremaking
(define (make-closure-name currentfunname)
(set! *closure-name-nr* (+ 1 *closure-name-nr*))
(string->symbol (string-append (symbol->string currentfunname)
*closure-name-suffix*
(number->string *closure-name-nr*))))
; make-initialize-closureargsv takes a vectorname
; (made by make-closure-vector for keeping local vars to be passed),
; lvars (argument vars of a lambdaterm) and varsmapping
; (mapping of local vars to be kept in vector 'vectorname' to the
; elements of this vector)
;
; It adds vector-set! to each element of varsmapping and filters
; out (keeps) exactly these which are in lvars. The resulting
; sequence of assigments ... (set! (vector-ref clargsv_nrn nrx) x)
; is inserted into function body after creating vector 'vectorname'
; in order to use the vector-elements instead of the parametric vars
; of the lambdaterm.
;
; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm.
(define (make-initialize-closureargsv vectname lvars varsmapping)
(filter-map (lambda (x)
(if (memq (car x) lvars)
(list 'vector-set! vectname
(cdr x) (car x))
#f))
varsmapping))
; make-trivial-closuremaking is called in case the argument term
; contains no mutable vars in the environment, ie when it does not have
; to be a proper closure at all, but just a function without a
; local environment. It returns just the name of the function, to
; be inserted into the surrounding procedure at the place of the
; original lambdaterm.
;
; called from: make-closuremaking-aux and try-closure-making-ldef, ...-lterm.
(define (make-trivial-closuremaking term)
(cond
((not (pair? term)) term)
((eq? 'quote (car term)) term)
((eq? 'lambda (car term))
(let* ((fun-name (make-closure-name *current-fun-name*))
(procname (make-closure-scmobj-name fun-name))
(newdef (list 'define fun-name term)))
(set! *lifted-trivial-closure-names*
(cons fun-name *lifted-trivial-closure-names*))
(set! *top-level-funs*
(cons fun-name *top-level-funs*))
(if (not (memq procname *special-c-vars*))
(set! *special-c-vars* (cons procname *special-c-vars*)))
(set! *lifted-closures-to-do*
(cons newdef *lifted-closures-to-do*))
procname))
((not (list? term)) term)
(else
(map (lambda (x) (make-trivial-closuremaking x)) term))))
; - - - - - - - - - proper closure-body-building begins - - - - - - - -
; make-closure-making creates the correct body of the closure (inside
; non-liftable lambdaterm which is used together with the vector
; of its environment) together with the creation/instantiation code
; inserted into the surrounding fun at the place of the original lambdaterm.
;
; vars is the set of environment vars, closurevars is the set of
; set! environment vars.
; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm
(define (make-closure-making term vars closurevars vectname clvectname)
(let* ((varsnr (length closurevars))
(tmp -1)
(clvarsmapping (map (lambda (x)
(set! tmp (+ 1 tmp)) (cons x tmp))
closurevars))
(newterm '()))
(set! newterm (vars->closureaccess
term '() clvarsmapping vectname clvectname))
(begin (set! newterm
(make-closure-making-aux
(cdr newterm) '() vars (map car clvarsmapping)
vectname clvectname))
(cons clvarsmapping newterm))))
(define (make-closure-making-aux
term holes vars clvars vectname clvectname)
(cond
((not (pair? term)) term)
((eq? 'quote (car term)) term)
((or (eq? 'lambda (car term)) (eq? *liftable-lambda* (car term)))
(make-closure-making-aux-lterm
term holes vars clvars vectname clvectname))
((not (list? term)) term)
((and (eq? 'set! (car term))
(pair? (cdr term))
(pair? (cddr term))
(pair? (caddr term))
;; if it is not lambda, and is inside-term,
;; then the set! var must be in clvars.
(eq? 'lambda (caaddr term))
(not (memq (cadr term) clvars))
(inside-term? (cadr term) (caddr term)))
(make-closure-making-aux-set!
term holes vars clvars vectname clvectname))
((and (eq? 'letrec (car term))
(pair? (cdr term))
;; if some bound var is inside-nonliftable-term,
;; and some leading fun is not a (nonliftable)lambda,
;; then all the bound vars must be in clvars.
(every1 (lambda (el) (eq? 'lambda (caadr el)))
(cadr term))
(find-if (lambda (el) (not (memq (car el) clvars)))
(cadr term)))
(make-closure-making-aux-letrec
term holes vars clvars vectname clvectname))
(else
(map (lambda (x)
(make-closure-making-aux
x holes vars clvars vectname clvectname))
term))))
(define (make-closure-making-aux-set!
term holes vars clvars vectname clvectname)
(let* ((tmp '())
(newholes (cons (cadr term) holes)))
(set! *letrec-closures* '())
(set! *letrec-closure-init* '())
(set! tmp
(make-closure-making-aux
(caddr term) newholes vars clvars vectname clvectname))
(list* 'let* *letrec-closures*
(append (list (list 'set! (cadr term) tmp))
*letrec-closure-init*))))
(define (make-closure-making-aux-letrec
letterm holes vars clvars vectname clvectname)
(let* ((bindings (cadr letterm))
(body (cddr letterm))
(newbindings '())
(newholes (append (map car bindings) holes)))
(set! *letrec-closures* '())
(set! *letrec-closure-init* '())
(set! newbindings
(map (lambda (el)
(list (car el)
(make-closure-making-aux
(cadr el) newholes vars clvars vectname clvectname)))
bindings))
(list* 'let* (append *letrec-closures* newbindings)
(append
*letrec-closure-init*
(map (lambda (x)
(make-closure-making-aux
x holes vars clvars vectname clvectname))
body)))))
; make-closure-making-aux-lterm creates the correct body of the closure (inside
; non-liftable lambdaterm which is used together with the vector
; of its environment) together with the creation/instantiation code
; inserted into the surrounding fun at the place of the original lambdaterm.
;
; vars is the set of environment vars, closurevars is the set of
; set! environment vars.
; called from: try-closure-making-ldef, ..-non-ldef, ...-lterm and
; recursively from make-closure-making-aux
(define (make-closure-making-aux-lterm
lterm holes vars clvars vectname clvectname)
(let ((params (args->list (cadr lterm))))
;; filter out the subsets of vars actually occurring in lterm,
;; previously throwing away these which are bound in lambda-args.
(or (null? vars)
(set! vars
(filter-inside-term
(filter (lambda (x) (not (memq x params)))
vars)
(cddr lterm))))
(cond
((eq? *liftable-lambda* (car lterm))
(list* (car lterm) (cadr lterm)
(map (lambda (x)
(make-closure-making-aux
x holes vars clvars vectname clvectname))
(cddr lterm))))
((and (null? vars)
(not (some-inside-term? *closure-var-vectornames* (cddr lterm))))
;; trivial case: no closure has to be built, function suffices
(make-trivial-closuremaking lterm))
(else
;; nontrivial case: closure has to be built, but there are no
;; set! closurevars to be handled.
(let* ((fun-name (make-closure-name *current-fun-name*))
(definf (make-lifted-closure-fun
lterm fun-name vars clvars))
(applic (make-lifted-closure-applic definf holes)))
(set! *lifted-closure-names*
(cons fun-name *lifted-closure-names*))
(set! *lifted-closures-to-do*
(cons (caddr definf) *lifted-closures-to-do*))
applic)))))
; make-lifted-closure-fun builds a body of the lambdaterm which is
; used as a proper closure.
;
; vars is the (nonempty) list of free variables occurring in lterm
;
; make-lifted-closure-fun is called only from make-closure-making-aux.
(define (make-lifted-closure-fun lterm name vars clvars)
(let* ((args (cdr (sort-out-clargs (cadr lterm))))
(passed-clargsv-lst
(filter-inside-term *closure-var-vectornames* (cddr lterm)))
(clargstranslation
(make-wrapped-clargs-init
passed-clargsv-lst *closurefun-arg-car* 1))
(varstranslation
(make-wrapped-clargs-init
vars *closurefun-arg-car* (+ 1 (length passed-clargsv-lst))))
(argstranslation
(make-wrapped-args-init
args *closurefun-arg* 1)))
(list
vars
passed-clargsv-lst
(list 'define
name
(list 'lambda
(list *closurefun-arg*)
(cons 'let*
(cons (append
(list (list *closurefun-arg-car*
(list 'car *closurefun-arg*)))
clargstranslation
varstranslation
argstranslation)
(cddr lterm))))))))
; sort-out-clargs takes the parameters of the function to the used as
; a closure-body. It splits these into the pair of two lists,
; the car being all these parameters which are closure-var-vectornames
; and the cdr being these parameters which are not.
; called only from make-lifted-closure-fun.
(define (sort-out-clargs inargs)
(let* ((clargs '())
(args '()))
(do ((part inargs (cdr part)))
((not (pair? part))
(cons (reverse clargs)
(append (reverse args) part)))
(if (memq (car part) *closure-var-vectornames*)
(set! clargs (cons (car part) clargs))
(set! args (cons (car part) args))))))
; make-wrapped-clargs-init takes a list of vars which are
; closure-var-vectornames. It creates a let-initialization-list
; of the form (( (vector-ref 1) ... (..2) ...)
; called only from make-lifted-closure-fun.
(define (make-wrapped-clargs-init clargs varname nr)
(cond
((null? clargs) '())
(else
(cons (list (car clargs) (list 'vector-ref varname nr))
(make-wrapped-clargs-init (cdr clargs) varname (+ 1 nr))))))
; make-wrapped-args-init takes a list of vars which are _not_
; closure-var-vectornames. It creates a let-initialization-list
; of the form (( (begin (set! (cdr closurefun-arg>))
; (car ))).
;
; called only from make-lifted-closure-fun.
(define (make-wrapped-args-init args varname nr)
(cond
((null? args) '())
((not (pair? args))
(list (list args (list 'cdr varname))))
((zero? nr)
(cons (list (car args)
(list 'car varname))
(make-wrapped-args-init (cdr args) varname (+ 1 nr))))
(else
(cons (list (car args)
(list 'begin
(list 'set! varname (list 'cdr varname))
(list 'car varname)))
(make-wrapped-args-init (cdr args) varname (+ 1 nr))))))
; make-lifted-closure-applic takes a newly built closurefun body def
; and creates code for creating the closure and initializing the
; environment-vector-part of the closure.
;
; called only from make-closure-making-aux.
(define (make-lifted-closure-applic definf holes)
(let* ((vars (car definf))
(clvects (cadr definf))
(newdef (caddr definf))
(funname (cadr newdef))
(procname (make-closure-scmobj-name funname))
(lterm (caddr newdef))
(lbody (cddr lterm))
(assignments '())
(nr 0)
(closurename (string->symbol *new-closure-var*))
(letrec-assignments '()))
(if (not (null? holes))
(begin (set! *letrec-closure-nr* (+ 1 *letrec-closure-nr*))
(set! closurename
(string->symbol
(string-append
*new-closure-var*
(string-append
"_" (number->string *letrec-closure-nr*)))))))
(for-each (lambda (x)
(set! nr (+ 1 nr))
(set! assignments
(cons (list 'vector-set! closurename nr x)
assignments)))
clvects)
(for-each (lambda (x)
(set! nr (+ 1 nr))
(set! assignments
(cons (list 'vector-set! closurename nr x)
assignments)))
vars)
(cond ((null? holes) ; closure does not occur in letrec top
(if (null? assignments)
(list *make-cclo* procname (list *actual-c-int* (+ 1 nr)))
`(let* ((,closurename
(,*make-cclo*
,procname ,(list *actual-c-int* (+ 1 nr)))))
,@(reverse assignments)
,closurename)))
(else
(set! letrec-assignments
(filter (lambda (x) (member (cadddr x) holes))
assignments))
(set! assignments
(filter (lambda (x) (not (member x letrec-assignments)))
assignments))
(set! *letrec-closures*
(append *letrec-closures*
(list (list closurename
(list *make-cclo* procname
(list *actual-c-int* (+ 1 nr)))))))
; closure occurs in letrec top
(set! *letrec-closure-init*
(append *letrec-closure-init*
(reverse letrec-assignments)))
(if (null? assignments)
closurename
(cons 'begin (append assignments (list closurename))))))))
;; - - - - - - - - - proper closure-body-building ends - - - - - - - -
(define (make-closure-scmobj-name funname)
(let ((res (string->symbol
(string-append
(symbol->string funname) *closure-proc-suffix*))))
(or (memq res *special-c-vars*)
(set! *special-c-vars* (cons res *special-c-vars*)))
res))
(define (list->conses lst)
(if (null? lst)
(list 'quote '())
(let ((tmp (list->conses (cdr lst))))
(list 'cons (car lst) tmp))))
(define (cl-vectorname? symb)
(memq symb *closure-var-vectornames*))
;vars->closureaccess takes a term and two mappings of vars to closureaccess.
; a mapping has the format: ( . )
;
; it returns a pair ( . ) where is #f iff
; the term does not contain closurevars.
;
; it assumes that vars in let-s, lambda, do have been already renamed
; so that there are no varname-clashes.
;
; called only from make-closure-making and recursively.
(define (vars->closureaccess term varsmap clvarsmap vectname clvectname)
(cond
((symbol? term)
(set! clvarsmap (assq term clvarsmap))
(set! varsmap (assq term varsmap))
(cond
((and clvarsmap
(not (memq term *closure-var-vectornames*)))
(cons #t (list 'vector-ref clvectname (cdr clvarsmap))))
((and varsmap
(not (memq term *closure-var-vectornames*)))
(cons #t (list 'vector-ref vectname (cdr varsmap))))
(else
(cons #f term))))
((not (pair? term)) (cons #f term))
((eq? 'quote (car term)) (cons #f term))
((eq? *liftable-lambda* (car term))
(let* ((vars (args->list (cadr term)))
(newmap (filter (lambda (x) (not (memq (car x) vars))) varsmap))
(newclmap (filter (lambda (x) (not (memq (car x) vars))) clvarsmap))
(tmp (vars->closureaccess
(cddr term) newmap newclmap vectname clvectname)))
(cons (car tmp) (list* *liftable-lambda* (cadr term) (cdr tmp)))))
((eq? 'lambda (car term))
(let* ((vars (args->list (cadr term)))
(newmap (filter (lambda (x) (not (memq (car x) vars))) varsmap))
(newclmap (filter (lambda (x) (not (memq (car x) vars))) clvarsmap))
(tmp (vars->closureaccess
(cddr term) newmap newclmap vectname clvectname)))
(if (car tmp) ; closurevars used?
; yes, closurevars used:
(cons #t (cons 'lambda
(cons (cons clvectname (cadr term))
(cdr tmp))))
; no, no closurevars were used:
(cons #f term))))
(else
(let ((tmp (map (lambda (x) (vars->closureaccess
x varsmap clvarsmap vectname clvectname))
term)))
(if (find-if (lambda (x) (car x)) tmp)
(cons #t (map cdr tmp))
(cons #f (map cdr tmp)))))))
; closure-building-vars assumes that vars in the term are renamed
; so that no varname or varname-funname or varname-syntax
; conflicts occur.
; it returns the subset of vars in funvars occurring freely and set!
; inside lambdaterms in term, plus funvars fi occurring freely in the
; contexts:
; (1) (set! fi t), where t=/=(lambda (...)...) and fi occurs
; inside a non-liftable lambdaterm in t.
; (2) (letrec (... (fi ti) ...) ...), where ti=/=(lambda (...)...) and
; at least one of fj bound in letrec occurs inside a non-liftable
; lambdaterm in a tr body in letrec. NB! If some ti=/=(lambda (...)...),
; the latter condition is automatically guaranteed by previous lifting
; analysis.
(define *closure-building-vars* '())
(define (closure-building-vars term funvars)
(set! *local-vars* funvars)
(set! *closure-building-vars* '())
(closure-building-vars-aux! term)
(filter (lambda (x) (memq x *closure-building-vars*)) funvars))
(define (closure-building-vars-aux! term)
(cond
((not (pair? term)))
((eq? 'quote (car term)))
((eq? 'lambda (car term))
(for-each (lambda (var)
(if (and (not (memq var *closure-building-vars*))
(not (inside-term? var (cadr term)))
(inside-term-set? var (cddr term)))
(set! *closure-building-vars*
(cons var *closure-building-vars*))))
*local-vars*))
((eq? *liftable-lambda* (car term))
(for-each closure-building-vars-aux! (cddr term)))
((eq? 'set! (car term))
(if (and (pair? (caddr term))
(not (eq? 'lambda (car (caddr term))))
(inside-nonliftable-term? (cadr term) (caddr term))
(not (memq (cadr term) *closure-building-vars*)))
(set! *closure-building-vars*
(cons (cadr term) *closure-building-vars*)))
(for-each closure-building-vars-aux! (cdr term)))
((eq? 'letrec (car term))
(if (and (find-if (lambda (x)
(and (pair? (cadr x))
(not (eq? 'lambda (car (cadr x))))))
(cadr term))
(find-if (lambda (x)
(find-if (lambda (y)
(inside-nonliftable-term? (car x) (cadr y)))
(cadr term)))
(cadr term)))
(for-each (lambda (x)
(or (memq (car x) *closure-building-vars*)
(set! *closure-building-vars*
(cons (car x) *closure-building-vars*))))
(cadr term)))
(for-each closure-building-vars-aux! (cdr term)))
(else
(for-each closure-building-vars-aux! term))))
(define (inside-nonliftable-term? name term)
(cond
((not (pair? term)) #f)
((eq? 'quote (car term)) #f)
((eq? 'lambda (car term))
(inside-term? name (cddr term)))
(else
(find-if (lambda (x) (inside-nonliftable-term? name x)) term))))
(define (inside-term-set? x term)
(cond ((not (pair? term)) #f)
((eq? 'quote (car term)) #f)
((eq? 'set! (car term))
(or (and (pair? (cdr term))
(eq? x (cadr term))
(pair? (cddr term))
(null? (cdddr term)))
(inside-term-set? x (cdr term))))
(else
(or (inside-term-set? x (car term))
(inside-term-set? x (cdr term))))))
(define (collect-local-vars term)
(set! *local-vars* '())
(collect-local-vars-aux term)
*local-vars*)
(define (collect-local-vars-aux term)
(cond
((not (pair? term)))
((eq? (car term) 'quote))
((or (eq? (car term) 'let*) (eq? (car term) *op-let*)
(eq? (car term) 'let) (eq? (car term) 'letrec))
(set! *local-vars*
(union (filter-map
(lambda (el)
(if (and (pair? (cadr el))
(eq? *liftable-lambda* (caadr el)))
#f
(car el)))
(cadr term))
*local-vars*))
(for-each (lambda (x) (collect-local-vars-aux (cadr x))) (cadr term))
(for-each (lambda (x) (collect-local-vars-aux x)) (cddr term)))
((eq? (car term) 'do)
(set! *local-vars* (union (map car (cadr term)) *local-vars*))
(for-each (lambda (x)
(for-each (lambda (y) (collect-local-vars-aux y)) (cdr x)))
(cadr term))
(for-each (lambda (x) (collect-local-vars-aux x)) (caddr term))
(for-each (lambda (x) (collect-local-vars-aux x)) (cdddr term)))
((eq? (car term) 'lambda))
(else
(for-each (lambda (x) (collect-local-vars-aux x)) term))))
; beautify-closure takes a built closure-fun and corrects the
; following: (let* (... ((vector-ref foo n) bar) ...) ...) is
; replaced by (let* (...) (vector-set! foo n bar) (let* (...) ...)),
; (set! (vector-ref foo n) bar) is replaced by (vector-set! foo n bar)
(define (beautify-closure term)
(cond
((not (pair? term)) term)
((eq? 'quote (car term)) term)
((and (eq? 'set! (car term))
(pair? (cdr term))
(pair? (cadr term))
(eq? 'vector-ref (caadr term))
(pair? (cdadr term))
(pair? (cddr term))
(memq (cadadr term) *closure-var-vectornames*))
(list 'vector-set!
(cadadr term) (caddr (cadr term)) (beautify-closure (caddr term))))
((and (memq (car term) '(let* let letrec))
(not (null? (cdr term)))
(pair? (cadr term))
(find-if (lambda (x) (pair? (car x))) (cadr term)))
(beautify-closure-let (car term) (cadr term) (cddr term)))
((list? term)
(map beautify-closure term))
(else
term)))
(define (beautify-closure-let key bindings rest)
(if (null? bindings)
(cons 'begin (map beautify-closure rest))
(let* ((okpart '()))
(do ((part bindings (cdr part)))
((or (null? part)
(and (pair? (car part))
(pair? (caar part))
(eq? 'vector-ref (caaar part))
(pair? (cdaar part))
(memq (cadaar part) *closure-var-vectornames*)))
(if (null? part)
(list* key (reverse okpart) (map beautify-closure rest))
(list key
(reverse okpart)
(list 'vector-set! (cadaar part)
(caddar (car part))
(beautify-closure (cadar part)))
(beautify-closure-let key (cdr part) rest))))
(set! okpart (cons (list (caar part)
(beautify-closure (cadar part)))
okpart))))))
;====================================================================
;
; auxiliary functions - a library
;
;===================================================================
(define (filter f lst)
(cond ((null? lst) '())
((f (car lst)) (cons (car lst) (filter f (cdr lst))))
(else (filter f (cdr lst)))))
(define (filter-map f lst)
(if (pair? lst)
(let ((res (f (car lst))))
(if res
(cons res (filter-map f (cdr lst)))
(filter-map f (cdr lst))))
'()))
(define (filter-inside-term lst term)
(define *filter-inside-term-res* '())
(define (filter-inside-term-aux! lst term)
(cond ((not (pair? term))
(and (memq term lst)
(not (memq term *filter-inside-term-res*))
(set! *filter-inside-term-res*
(cons term *filter-inside-term-res*))))
((eq? 'quote (car term)))
(else (filter-inside-term-aux! lst (car term))
(filter-inside-term-aux! lst (cdr term)))))
(filter-inside-term-aux! lst term)
(filter (lambda (x) (memq x *filter-inside-term-res*)) lst))
(define (inside-term? x term)
(cond ((eq? x term) #t)
((not (pair? term)) #f)
((eq? 'quote (car term)) #f)
(else (or (inside-term? x (car term))
(inside-term? x (cdr term))))))
(define (some-inside-term? obs term)
(cond ((memq term obs) #t)
((not (pair? term)) #f)
((eq? 'quote (car term)) #f)
(else (or (some-inside-term? obs (car term))
(some-inside-term? obs (cdr term))))))
(define (subst-term-equal! what for term)
(cond ((not (pair? term)))
((equal? (car term) for)
(set-car! term what)
(subst-term-equal! what for (cdr term)))
((not (eq? 'quote (car term)))
(subst-term-equal! what for (car term))
(subst-term-equal! what for (cdr term)))))
(define (subst-term what for term)
(cond ((eq? term for) what)
((not (pair? term)) term)
((eq? 'quote (car term)) term)
(else (cons (subst-term what for (car term))
(subst-term what for (cdr term))))))
(define (in-fun-position? x term)
(cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)
((not (list? term)) #f)
((eq? x (car term)) #t)
(else (find-if (lambda (y) (in-fun-position? x y)) term))))
(define (some-in-fun-position? lst term)
(cond ((or (not (pair? term)) (eq? 'quote (car term))) #f)
((not (list? term)) #f)
((memq (car term) lst) #t)
(else (find-if (lambda (y) (some-in-fun-position? lst y)) term))))
(define (replaceq what with lst)
(cond ((null? lst) '())
((eq? what (car lst)) (cons with (replaceq what with (cdr lst))))
(else (cons (car lst) (replaceq what with (cdr lst))))))
;;; Like LAST-PAIR, but works for non-lists.
(define (my-last-pair lst)
(define (my-last-pair-aux lst)
(if (pair? (cdr lst))
(my-last-pair-aux (cdr lst))
lst))
(if (not (pair? lst))
lst
(my-last-pair-aux lst)))
;;; Like REMOVE, but removes at most one element.
(define (remove-one what from)
(cond ((null? from) from)
((eq? what (car from)) (cdr from))
(else (cons (car from) (remove-one what (cdr from))))))
;;; Like FIND-IF, but works for non-lists.
(define (pair-find-if f lst)
(if (pair? lst)
(if (f (car lst)) (car lst) (pair-find-if f (cdr lst)))
(if (f lst) lst #f)))
;;; slib/comlist.scm functions:
(define (find-if f lst)
(if (null? lst)
#f
(if (f (car lst)) (car lst) (find-if f (cdr lst)))))
(define (remove what lst)
(cond ((null? lst) '())
((eq? what (car lst)) (remove what (cdr lst)))
(else (cons (car lst) (remove what (cdr lst))))))
(define (every1 f lst)
(if (null? lst)
#t
(if (f (car lst)) (every1 f (cdr lst)) #f)))
(define (member-if f lst)
(if (null? lst)
#f
(if (f (car lst)) lst (member-if f (cdr lst)))))
(define (list* obj1 . obj2)
(define (list*1 obj)
(if (null? (cdr obj))
(car obj)
(cons (car obj) (list*1 (cdr obj)))))
(if (null? obj2)
obj1
(cons obj1 (list*1 obj2))))
(define (butlast lst n)
(letrec
((len (- (length lst) n))
(bl (lambda (lst n)
(let build-until-zero ((lst lst)
(n n)
(result '()))
(cond ((null? lst) (reverse result))
((positive? n)
(build-until-zero
(cdr lst) (- n 1) (cons (car lst) result)))
(else (reverse result)))))))
(bl lst (if (negative? n)
(slib:error "negative argument to butlast" n)
len))))
(define (union lst1 lst2)
(define ans (if (null? lst1) lst2 lst1))
(define (adjoin obj lst) (if (memv obj lst) lst (cons obj lst)))
(cond ((null? lst2) lst1)
(else (for-each (lambda (elt) (set! ans (adjoin elt ans)))
lst2)
ans)))
(define (set-difference lst1 lst2)
(if (null? lst2)
lst1
(let build-difference ((lst1 lst1)
(result '()))
(cond ((null? lst1) (reverse result))
((memv (car lst1) lst2) (build-difference (cdr lst1) result))
(else (build-difference (cdr lst1) (cons (car lst1) result)))))))
(define (intersection lst1 lst2)
(if (null? lst2)
lst2
(let build-intersection ((lst1 lst1)
(result '()))
(cond ((null? lst1) (reverse result))
((memv (car lst1) lst2)
(build-intersection (cdr lst1) (cons (car lst1) result)))
(else
(build-intersection (cdr lst1) result))))))
;=========================== END ===============================
scm/dynl.c 0000755 0000000 0000000 00000042733 12130150236 011455 0 ustar root root /* "dynl.c" dynamically link&load object files.
* Copyright (C) 1990-1999 Free Software Foundation, Inc.
*
* This program 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.
*
* This program 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 this program. If not, see
* .
*/
/* Author: Aubrey Jaffer */
#include "scm.h"
#ifndef STDC_HEADERS
int free (); /* P((char *ptr)) */
#endif
/* linkpath holds the filename which just got linked. Scheme
*loadpath* will get set to linkpath and then restored around the
initialization call */
/* static SCM linkpath; */
#ifdef DLD
# include "dld.h"
void listundefs()
{
int i;
char **undefs = dld_list_undefined_sym();
puts(" undefs:");
for (i = dld_undefined_sym_count;i--;) {
putc('"', stdout);
fputs(undefs[i], stdout);
puts("\"");
}
free(undefs);
}
static char s_link[] = "dyn:link", s_call[] = "dyn:call";
SCM l_dyn_link(fname)
SCM fname;
{
int status;
ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
DEFER_INTS;
status = dld_link(CHARS(fname));
ALLOW_INTS;
if (!status) {/* linkpath = fname; */ return fname;}
if (DLD_ENOFILE==status) return BOOL_F;
if (DLD_EBADOBJECT==status) return BOOL_F;
dld_perror("DLD");
return BOOL_F;
}
SCM l_dyn_call(symb, shl)
SCM symb, shl;
{
int i;
void (*func)() = 0;
/* SCM oloadpath = *loc_loadpath; */
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
DEFER_INTS;
if ((i = dld_function_executable_p(CHARS(symb))))
func = (void (*) ()) dld_get_func(CHARS(symb));
else dld_perror("DLDP");
ALLOW_INTS;
if (!i) listundefs();
if (!func) {
dld_perror("DLD");
return BOOL_F;
}
/* *loc_loadpath = linkpath; */
(*func) ();
/* *loc_loadpath = oloadpath; */
return BOOL_T;
}
static char s_main_call[] = "dyn:main-call";
SCM l_dyn_main_call(symb, shl, args)
SCM symb, shl, args;
{
int i;
int (*func)(int argc, const char **argv) = 0;
const char **argv;
/* SCM oloadpath = *loc_loadpath; */
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
DEFER_INTS;
argv = makargvfrmstrs(args, s_main_call);
if ((i = dld_function_executable_p(CHARS(symb))))
func = (int (*) (int argc, const char **argv)) dld_get_func(CHARS(symb));
else dld_perror("DLDP");
if (!i) listundefs();
if (!func) {
must_free_argv(argv);
ALLOW_INTS;
dld_perror("DLD");
return BOOL_F;
}
ALLOW_INTS;
/* *loc_loadpath = linkpath; */
i = (*func) ((int)ilength(args), argv);
/* *loc_loadpath = oloadpath; */
DEFER_INTS;
must_free_argv(argv);
ALLOW_INTS;
return MAKINUM(0L+i);
}
static char s_unlink[] = "dyn:unlink";
SCM l_dyn_unlink(fname)
SCM fname;
{
int status;
ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_unlink);
DEFER_INTS;
status = dld_unlink_by_file(CHARS(fname), 1);
ALLOW_INTS;
if (!status) return BOOL_T;
dld_perror("DLD");
return BOOL_F;
}
static iproc subr1s[] = {
{s_link, l_dyn_link},
{s_unlink, l_dyn_unlink},
{0, 0}};
void init_dynl()
{
/* if (!execpath) execpath = scm_find_execpath(); */
if ((!execpath) || dld_init(execpath)) {
dld_perror("DLD:");
return;
}
if (!dumped) {
init_iprocs(subr1s, tc7_subr_1);
make_subr(s_call, tc7_subr_2, l_dyn_call);
make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
add_feature("dld");
# ifdef DLD_DYNCM
add_feature("dld:dyncm");
# endif
}
}
#else
# ifdef hpux
# include "dl.h"
# define P_SHL(obj) ((shl_t*)(&CDR(obj)))
# define SHL(obj) (*P_SHL(obj))
int prinshl(exp, port, writing)
SCM exp; SCM port; int writing;
{
lputs("#', port);
return 1;
}
int tc16_shl;
static smobfuns shlsmob = {mark0, free0, prinshl};
static char s_link[] = "dyn:link", s_call[] = "dyn:call";
SCM l_dyn_link(fname)
SCM fname;
{
SCM z;
shl_t shl;
ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
shl = shl_load(CHARS(fname), BIND_DEFERRED , 0L);
if (NULL==shl) {
ALLOW_INTS;
return BOOL_F;
}
SETCHARS(z, shl);
CAR(z) = tc16_shl;
ALLOW_INTS;
/* linkpath = fname; */
return z;
}
SCM l_dyn_call(symb, shl)
SCM symb, shl;
{
void (*func)() = 0;
int i;
/* SCM oloadpath = *loc_loadpath; */
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
if ((i = shl_findsym(P_SHL(shl),
CHARS(symb),
TYPE_PROCEDURE, &func)) != 0) {
puts(" undef:"); puts(CHARS(symb));
}
ALLOW_INTS;
if (i != 0) return BOOL_F;
/* *loc_loadpath = linkpath; */
(*func) ();
/* *loc_loadpath = oloadpath; */
return BOOL_T;
}
static char s_main_call[] = "dyn:main-call";
SCM l_dyn_main_call(symb, shl, args)
SCM symb, shl, args;
{
int i;
int (*func)P((int argc, const char **argv)) = 0;
const char **argv;
/* SCM oloadpath = *loc_loadpath; */
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
if ((i = shl_findsym(P_SHL(shl),
CHARS(symb),
TYPE_PROCEDURE, &func)) != 0) {
puts(" undef:"); puts(CHARS(symb));
}
argv = makargvfrmstrs(args, s_main_call);
ALLOW_INTS;
if (i != 0) return BOOL_F;
/* *loc_loadpath = linkpath; */
i = (*func) ((int)ilength(args), argv);
/* *loc_loadpath = oloadpath; */
DEFER_INTS;
must_free_argv(argv);
ALLOW_INTS;
return MAKINUM(0L+i);
}
static char s_unlink[] = "dyn:unlink";
SCM l_dyn_unlink(shl)
SCM shl;
{
int status;
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
status = shl_unload(SHL(shl));
ALLOW_INTS;
if (!status) return BOOL_T;
return BOOL_F;
}
static iproc subr1s[] = {
{s_link, l_dyn_link},
{s_unlink, l_dyn_unlink},
{0, 0}};
void init_dynl()
{
if (!dumped) {
tc16_shl = newsmob(&shlsmob);
init_iprocs(subr1s, tc7_subr_1);
make_subr(s_call, tc7_subr_2, l_dyn_call);
make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
add_feature("shl");
}
}
# endif
#endif
#ifdef vms
/* This permits dynamic linking. For example, the procedure of 0 arguments
from a file could be the initialization procedure.
(vms:dynamic-link-call "MYDISK:[MYDIR].EXE" "foo" "INIT_FOO")
The first argument specifies the directory where the file specified
by the second argument resides. The current directory would be
"SYS$DISK:[].EXE".
The second argument cannot contain any punctuation.
The third argument probably needs to be uppercased to mimic the VMS linker.
*/
# include
# include
# include
struct dsc$descriptor *descriptorize(x, buff)
struct dsc$descriptor *x;
SCM buff;
{(*x).dsc$w_length = LENGTH(buff);
(*x).dsc$a_pointer = CHARS(buff);
(*x).dsc$b_class = DSC$K_CLASS_S;
(*x).dsc$b_dtype = DSC$K_DTYPE_T;
return(x);}
static char s_dynl[] = "vms:dynamic-link-call";
SCM dynl(dir, symbol, fname)
SCM dir, symbol, fname;
{
struct dsc$descriptor fnamed, symbold, dird;
void (*fcn)();
long retval;
ASRTER(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl);
ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl);
ASRTER(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl);
descriptorize(&fnamed, fname);
descriptorize(&symbold, symbol);
DEFER_INTS;
retval = lib$find_image_symbol(&fnamed, &symbold, &fcn,
IMP(dir) ? 0 : descriptorize(&dird, dir));
if (SS$_NORMAL != retval) {
/* wta(MAKINUM(retval), "vms error", s_dynl); */
ALLOW_INTS;
return BOOL_F;
}
ALLOW_INTS;
/* *loc_loadpath = dir; */
(*fcn)();
/* *loc_loadpath = oloadpath; */
return BOOL_T;
}
void init_dynl()
{
if (!dumped) {
make_subr(s_dynl, tc7_subr_3, dynl);
}
}
#endif
#ifdef SUN_DL
# include
# define SHL(obj) ((void*)CDR(obj))
# ifdef RTLD_GLOBAL
# define DLOPEN_MODE (RTLD_NOW | RTLD_GLOBAL)
# else
# ifdef RTLD_LAZY /* This is here out of conservatism, not
because it's known to be right. */
# define DLOPEN_MODE RTLD_LAZY
# else
# define DLOPEN_MODE 1 /* Thats what it says in the man page. */
# endif
# endif
sizet frshl(ptr)
CELLPTR ptr;
{
# if 0
/* Should freeing a shl close and possibly unmap the object file it */
/* refers to? */
if (SHL(ptr))
dlclose(SHL(ptr));
# endif
return 0;
}
int prinshl(exp, port, writing)
SCM exp; SCM port; int writing;
{
lputs("#', port);
return 1;
}
int tc16_shl;
static smobfuns shlsmob = {mark0, frshl, prinshl};
static char s_link[] = "dyn:link", s_call[] = "dyn:call";
SCM l_dyn_link(fname)
SCM fname;
{
SCM z;
void *handle;
if (FALSEP(fname)) return fname;
ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
handle = dlopen(CHARS(fname), DLOPEN_MODE);
if (NULL==handle) {
if (scm_verbose > 1) {
char *dlr = dlerror();
ALLOW_INTS;
if (dlr) {
lputs(s_link, cur_errp);
lputs(": ", cur_errp);
lputs(dlr, cur_errp);
scm_newline(cur_errp);
}}
return BOOL_F;
}
SETCHARS(z, handle);
CAR(z) = tc16_shl;
ALLOW_INTS;
/* linkpath = fname; */
return z;
}
SCM l_dyn_call(symb, shl)
SCM symb, shl;
{
void (*func)() = 0;
/* SCM oloadpath = *loc_loadpath; */
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
func = dlsym(SHL(shl), CHARS(symb));
if (!func) {
char *dlr = dlerror();
ALLOW_INTS;
if (dlr) {
lputs(s_call, cur_errp);
lputs(": ", cur_errp);
lputs(dlr, cur_errp);
scm_newline(cur_errp);
}
return BOOL_F;
}
ALLOW_INTS;
/* *loc_loadpath = linkpath; */
(*func) ();
/* *loc_loadpath = oloadpath; */
return BOOL_T;
}
static char s_main_call[] = "dyn:main-call";
SCM l_dyn_main_call(symb, shl, args)
SCM symb, shl, args;
{
int i;
int (*func)P((int argc, const char **argv)) = 0;
char **argv;
/* SCM oloadpath = *loc_loadpath; */
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
func = dlsym(SHL(shl), CHARS(symb));
if (!func) {
char *dlr = dlerror();
ALLOW_INTS;
if (dlr) {
lputs(s_main_call, cur_errp);
lputs(": ", cur_errp);
lputs(dlr, cur_errp);
scm_newline(cur_errp);
}
return BOOL_F;
}
argv = makargvfrmstrs(args, s_main_call);
ALLOW_INTS;
/* *loc_loadpath = linkpath; */
i = (*func) ((int)ilength(args), (const char**)argv);
/* *loc_loadpath = oloadpath; */
DEFER_INTS;
must_free_argv(argv);
ALLOW_INTS;
return MAKINUM(0L+i);
}
static char s_unlink[] = "dyn:unlink";
SCM l_dyn_unlink(shl)
SCM shl;
{
int status;
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
status = dlclose(SHL(shl));
SETCHARS(shl, NULL);
ALLOW_INTS;
if (!status) return BOOL_T;
return BOOL_F;
}
static iproc subr1s[] = {
{s_link, l_dyn_link},
{s_unlink, l_dyn_unlink},
{0, 0}};
void init_dynl()
{
if (!dumped) {
tc16_shl = newsmob(&shlsmob);
init_iprocs(subr1s, tc7_subr_1);
make_subr(s_call, tc7_subr_2, l_dyn_call);
make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
add_feature("sun-dl");
}
}
#endif /* SUN_DL */
#ifdef macintosh
# include
# include
# define SHL(obj) ((void*)CDR(obj))
sizet frshl(ptr)
CELLPTR ptr;
{
# if 0
/* Should freeing a shl close and possibly unmap the object file it */
/* refers to? */
if (SHL(ptr))
dlclose(SHL(ptr));
# endif
return 0;
}
int prinshl(exp, port, writing)
SCM exp; SCM port; int writing;
{
lputs("#', port);
return 1;
}
int tc16_shl;
static smobfuns shlsmob = {mark0, frshl, prinshl};
static char s_link[] = "dyn:link", s_call[] = "dyn:call";
SCM l_dyn_link(fname)
SCM fname;
{
OSErr err;
SCM z;
void *handle;
Str63 libName;
CFragConnectionID connID;
Ptr mainAddr;
Str255 errMessage;
if (FALSEP(fname)) return fname;
ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
strcpy((char *)libName, CHARS(fname));
c2pstr((char *)libName);
err = GetSharedLibrary (libName, kCompiledCFragArch, kReferenceCFrag,
&connID, &mainAddr, errMessage);
if (err!=noErr) {
ALLOW_INTS;
return BOOL_F;
}
SETCHARS(z, (void *)connID);
CAR(z) = tc16_shl;
ALLOW_INTS;
/* linkpath = fname; */
return z;
}
SCM l_dyn_call(symb, shl)
SCM symb, shl;
{
void (*func)() = 0;
OSErr err;
CFragSymbolClass symClass;
Str255 symName;
/* SCM oloadpath = *loc_loadpath; */
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
strcpy((char *)symName, CHARS(symb));
c2pstr((char *)symName);
err = FindSymbol((CFragConnectionID)SHL(shl), symName,
(Ptr *)&func, &symClass);
if (err!=noErr /* || symClass != kCodeCFragSymbol */) {
ALLOW_INTS;
if (err == cfragConnectionIDErr) puts("Invalid library connection.");
if (err == cfragNoSymbolErr) puts("Symbol not found.");
return BOOL_F;
}
ALLOW_INTS;
/* *loc_loadpath = linkpath; */
(*func) ();
/* *loc_loadpath = oloadpath; */
return BOOL_T;
}
static char s_main_call[] = "dyn:main-call";
SCM l_dyn_main_call(symb, shl, args)
SCM symb, shl, args;
{
int i;
int (*func)P((int argc, const char **argv)) = 0;
const char **argv;
OSErr err;
CFragSymbolClass symClass;
Str255 symName;
/* SCM oloadpath = *loc_loadpath; */
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
strcpy((char *)symName, CHARS(symb));
c2pstr((char *)symName);
err = FindSymbol((CFragConnectionID)SHL(shl), symName,
(Ptr *)&func, &symClass);
if (err!=noErr || symClass != kCodeCFragSymbol) {
ALLOW_INTS;
if (err == cfragConnectionIDErr) puts("Invalid library connection.");
if (err == cfragNoSymbolErr) puts("Symbol not found.");
return BOOL_F;
}
argv = makargvfrmstrs(args, s_main_call);
ALLOW_INTS;
/* *loc_loadpath = linkpath; */
i = (*func) ((int)ilength(args), argv);
/* *loc_loadpath = oloadpath; */
DEFER_INTS;
must_free_argv(argv);
ALLOW_INTS;
return MAKINUM(0L+i);
}
static char s_unlink[] = "dyn:unlink";
SCM l_dyn_unlink(shl)
SCM shl;
{
OSErr status;
CFragConnectionID connID;
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
connID = (CFragConnectionID)SHL(shl);
status = CloseConnection(&connID);
SETCHARS(shl, NULL);
ALLOW_INTS;
if (status!=noErr) return BOOL_T;
return BOOL_F;
}
static iproc subr1s[] = {
{s_link, l_dyn_link},
{s_unlink, l_dyn_unlink},
{0, 0}};
void init_dynl()
{
if (!dumped) {
tc16_shl = newsmob(&shlsmob);
init_iprocs(subr1s, tc7_subr_1);
make_subr(s_call, tc7_subr_2, l_dyn_call);
make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
add_feature("mac-dl");
}
}
#endif /* MACOS */
#ifdef _WIN32
# include
# define SHL(obj) ((HINSTANCE)(CDR(obj)))
int prinshl(exp, port, writing)
SCM exp; SCM port; int writing;
{
lputs("#', port);
return 1;
}
int tc16_shl;
static smobfuns shlsmob = {mark0, free0, prinshl};
static char s_link[] = "dyn:link";
SCM scm_dyn_link(fname)
SCM fname;
{
SCM z, shl = BOOL_F;
HINSTANCE hshl;
ASRTER(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
NEWCELL(z);
DEFER_INTS;
hshl = LoadLibrary(CHARS(fname));
if (hshl) {
SETCHARS(z, hshl);
CAR(z) = tc16_shl;
shl = z;
}
ALLOW_INTS;
return shl;
}
static char s_unlink[] = "dyn:unlink";
SCM scm_dyn_unlink(shl)
SCM shl;
{
BOOL status;
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
DEFER_INTS;
status = FreeLibrary(SHL(shl));
ALLOW_INTS;
return status ? BOOL_T : BOOL_F;
}
static char s_call[] = "dyn:call";
SCM scm_dyn_call(symb, shl)
SCM symb, shl;
{
FARPROC func;
int i;
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
DEFER_INTS;
func = GetProcAddress(SHL(shl), CHARS(symb));
ALLOW_INTS;
if (!func) return BOOL_F;
(*func) ();
return BOOL_T;
}
static char s_main_call[] = "dyn:main-call";
SCM scm_dyn_main_call(symb, shl, args)
SCM symb, shl, args;
{
int i;
FARPROC func;
const char **argv;
ASRTER(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
ASRTER(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
DEFER_INTS;
func = GetProcAddress(SHL(shl), CHARS(symb));
if (!func) {
ALLOW_INTS;
return BOOL_F;
}
argv = makargvfrmstrs(args, s_main_call);
ALLOW_INTS;
i = (*func) ((int)ilength(args), argv);
DEFER_INTS;
must_free_argv(argv);
ALLOW_INTS;
return MAKINUM(0L+i);
}
static iproc subr1s[] = {
{s_link, scm_dyn_link},
{s_unlink, scm_dyn_unlink},
{0, 0}};
void init_dynl()
{
if (!dumped) {
tc16_shl = newsmob(&shlsmob);
init_iprocs(subr1s, tc7_subr_1);
make_subr(s_call, tc7_subr_2, scm_dyn_call);
make_subr(s_main_call, tc7_lsubr_2, scm_dyn_main_call);
add_feature("win32-dl");
}
}
#endif
scm/Link.scm 0000755 0000000 0000000 00000007270 11675010371 011751 0 ustar root root ;;;; "Link.scm", Dynamic linking/loading code for SCM.
;; Copyright (C) 1993, 1994, 1995, 1997, 1998, 2002 Free Software Foundation, Inc.
;;
;; This program 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.
;;
;; This program 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 this program. If not, see
;; .
;;; Author: Aubrey Jaffer.
(cond
((defined? dyn:link)
(define link:able-suffix
(cond ((provided? 'shl) ".sl")
((provided? 'sun-dl) ".so")
((provided? 'mac-dl) ".shlb")
((provided? 'win32-dl) ".dll")
(else ".o")))
(define (file->init_name name)
(string-append
"init_"
(list->string
(map (lambda (chr) (if (eqv? #\- chr) #\_ chr))
(map char-downcase (string->list name))))))
(define link:link
(lambda (file . libs)
(let* ((sl (string-length file))
(lasl (string-length link:able-suffix))
(fname (let loop ((i (- sl 1)))
(cond ((negative? i) file)
((vicinity:suffix? (string-ref file i))
(substring file (+ i 1) sl))
(else (loop (- i 1))))))
(nsl (string-length fname))
(name (cond ((< nsl lasl) fname)
((string-ci=? (substring fname (- nsl lasl) nsl)
link:able-suffix)
(substring fname 0 (- nsl lasl)))
(else fname)))
(linkobj #f))
(if (and (provided? 'sun-dl)
(< 3 sl)
(not (eqv? (string-ref file 0) '#\/)))
(set! file (string-append "./" file)))
(with-load-pathname file
(lambda ()
(load:pre 'link file)
(set! linkobj (or (provided? 'sun-dl) (dyn:link file)))
(and linkobj
(for-each (lambda (lib)
(or (dyn:link lib)
(slib:error "couldn't link: " lib)))
libs))
(if (provided? 'sun-dl) (set! linkobj (dyn:link file)))
(cond ((not linkobj) #f)
((dyn:call (file->init_name name) linkobj)
(load:post 'link file)
#t)
(else (dyn:unlink linkobj) #f))))))))
((defined? vms:dynamic-link-call)
(define link:able-suffix #f)
(define (link:link file)
(define dir "")
(define fil "")
(let loop ((i (- (string-length file) 1)))
(cond ((negative? i) (set! dir file))
((vicinity:suffix? (string-ref file i))
(set! dir (substring file 0 (+ i 1)))
(set! fil (substring file (+ i 1) (string-length file))))
(else (loop (- i 1)))))
(with-load-pathname file
(lambda ()
(load:pre 'link file)
(vms:dynamic-link-call dir fil (file->init_name fil))
(load:post 'link file))))))
(cond
((provided? 'sun-dl)
;; These libraries are (deferred) linked in conversion to ".so"
(define (usr:lib lib) #f)
(define (x:lib lib) #f))
((provided? 'shl)
(define (usr:lib lib)
(if (member lib '("c" "m"))
(string-append "/lib/lib" lib link:able-suffix)
(string-append "/usr/lib/lib" lib link:able-suffix)))
(define (x:lib lib) (string-append "/usr/X11R5/lib/lib"
lib link:able-suffix)))
((provided? 'dld:dyncm)
(define (usr:lib lib)
(or (and (member lib '("c" "m"))
(let ((sa (string-append "/usr/lib/lib" lib ".sa")))
(and (file-exists? sa) sa)))
(string-append "/usr/lib/lib" lib ".a")))
(define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa")))
((provided? 'dld)
(define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a"))
(define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))))
scm/setjump.h 0000755 0000000 0000000 00000010074 10750240550 012201 0 ustar root root /* "setjump.h" memory and stack parameters.
* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
*
* This program 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.
*
* This program 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 this program. If not, see
* .
*/
/* Author: Aubrey Jaffer */
/* CELL_UP and CELL_DN are used by init_heap_seg to find cell aligned inner
bounds for allocated storage */
#ifdef PROT386
/*in 386 protected mode we must only adjust the offset */
# define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
# define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
#else
# ifdef _UNICOS
# define CELL_UP(p) (CELLPTR)(~1L & ((long)(p)+1L))
# define CELL_DN(p) (CELLPTR)(~1L & (long)(p))
# else
# define CELL_UP(p) (CELLPTR)(~(sizeof(cell)-1L) & ((long)(p)+sizeof(cell)-1L))
# define CELL_DN(p) (CELLPTR)(~(sizeof(cell)-1L) & (long)(p))
# endif /* UNICOS */
#endif /* PROT386 */
/* These are parameters for controlling memory allocation. The heap
is the area out of which cons and object headers is allocated.
Each heap object is 8 bytes on a 32 bit machine and 16 bytes on a
64 bit machine. The units of the _SIZE parameters are bytes.
INIT_HEAP_SIZE is the initial size of heap. If this much heap is
allocated initially the heap will grow by half its current size
each subsequent time more heap is needed.
If INIT_HEAP_SIZE heap cannot be allocated initially, HEAP_SEG_SIZE
will be used, and the heap will grow by HEAP_SEG_SIZE when more
heap is needed. HEAP_SEG_SIZE must fit into type sizet. This code
is in init_storage() and alloc_some_heap() in sys.c
If INIT_HEAP_SIZE can be allocated initially, the heap will grow by
EXPHEAP(heap_cells) when more heap is needed.
MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
is needed.
INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
trigger a GC. */
#define INIT_HEAP_SIZE (25000L*sizeof(cell))
#define MIN_HEAP_SEG_SIZE (2000L*sizeof(cell))
#ifdef _QC
# define HEAP_SEG_SIZE 32400L
#else
# ifdef sequent
# define HEAP_SEG_SIZE (7000L*sizeof(cell))
# else
# define HEAP_SEG_SIZE (8100L*sizeof(cell))
# endif
#endif
#define EXPHEAP(heap_cells) (heap_cells*2)
#define INIT_MALLOC_LIMIT 100000
/* ECACHE_SIZE is the number of cells in the copy-collected environment
cache used for environment frames */
#define ECACHE_SIZE 2000
/* If fewer than MIN_GC_YIELD cells are recovered during a
cell-requested garbage collection (GC), then another heap segment
is allocated. */
#define MIN_GC_YIELD (heap_cells / 4)
/* If fewer than MIN_MALLOC_YIELD cells are free after a
malloc-requested garbage collection (GC), then the mtrigger limit
is raised. */
#define MIN_MALLOC_YIELD (mtrigger / 8)
/* NUM_HASH_BUCKETS is the number of symbol hash table buckets. */
#define NUM_HASH_BUCKETS 137
#ifdef IN_CONTINUE_C
# include "scm.h"
# define malloc(size) must_malloc((long)(size), s_cont)
# define free(obj) must_free((char *)(obj), 0)
#endif
/* other.dynenv and other.parent get GCed just by being there. */
struct scm_other {SCM dynenv;
SCM parent;
#ifdef RECKLESS
SCM stkframe[2];
#else
SCM stkframe[4];
#endif
SCM estk;
SCM *estk_ptr;
};
#define CONTINUATION_OTHER struct scm_other
#define CONT(x) ((CONTINUATION *)CDR(x))
#define SETCONT SETCDR
void dowinds P((SCM to));
#include "continue.h"
typedef struct safeport {
SCM port;
jmp_buf jmpbuf; /* The usual C jmp_buf, not SCM's jump_buf */
int ccnt;
} safeport;
#define SAFEP_JMPBUF(sfp) (((safeport *)STREAM(sfp))->jmpbuf)
scm/time.c 0000755 0000000 0000000 00000021635 12275546777 011500 0 ustar root root /* "time.c" functions dealing with time.
* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 2006 Free Software Foundation, Inc.
*
* This program 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.
*
* This program 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 this program. If not, see
* .
*/
/* Author: Aubrey Jaffer */
#include "scm.h"
#ifdef STDC_HEADERS
# include
# ifdef M_SYSV
# include
# include
# endif
# ifdef sun
# include
# include
# endif
# ifdef ultrix
# include
# include
# endif
# ifdef nosve
# include
# include
# endif
# ifdef _UNICOS
# include
# include
# endif
# ifdef __IBMC__
# include
# endif
#else
# ifdef SVR2
# include
# else
# ifndef ARM_ULIB
# include
# else
# include
# endif
# endif
# include
# ifndef ARM_ULIB
# include
# else
# include
# endif
#endif
/* Define this if your system lacks ftime(). */
/* #define LACK_FTIME */
/* Define this if your system has gettimeofday()
(LACK_FTIME should not be defined). */
/* #define USE_GETTIMEOFDAY */
/* Define this if your system lacks times(). */
/* #define LACK_TIMES */
#ifdef linux
# include
# include
# include
# include
# include
# define CLKTCK (sysconf(_SC_CLK_TCK))
# define USE_GETTIMEOFDAY
#endif
#ifdef __MACH__
# define unix
# include
# include
# include
# include
# define USE_GETTIMEOFDAY
#endif
#ifdef __FreeBSD__
# include
# include
# include
# define USE_GETTIMEOFDAY
#endif
#ifdef __NetBSD__
# include
# include
# define USE_GETTIMEOFDAY
#endif
#ifdef __OpenBSD__
# include
# include
# define USE_GETTIMEOFDAY
#endif
#ifdef __TURBOC__
# define LACK_TIMES
#endif
#if (__TURBOC__==1) /* Needed for TURBOC V1.0 */
# define LACK_FTIME
# undef MSDOS
#endif
#ifdef __HIGHC__
# define LACK_TIMES
#endif
#ifdef macintosh
# define LACK_FTIME
# define LACK_TIMES
# define CLK_TCK 60
#endif
#ifdef SVR2
# define LACK_FTIME
#endif
#ifdef SVR4
# define LACK_FTIME
#endif
#ifdef __SVR4
# define LACK_FTIME
#endif
#ifdef PLAN9
# define LACK_FTIME
# define LACK_TIMES
#endif
#ifdef nosve
# define LACK_FTIME
#endif
#ifdef GO32
# define LACK_FTIME
# define LACK_TIMES
#endif
#ifdef atarist
# define LACK_FTIME
# define LACK_TIMES
#endif
#ifdef ARM_ULIB
# define LACK_FTIME
# define LACK_TIMES
#endif
#ifdef _DCC
# define LACK_FTIME
#endif
#ifdef MSDOS
# ifndef GO32
# include
# include
# endif
#endif
#ifdef _UNICOS
# define LACK_FTIME
#endif
#ifdef __amigaos__
# include
# include
# include
# define USE_GETTIMEOFDAY
#endif
#ifndef LACK_FTIME
# ifdef HAVE_UNIX
# ifndef GO32
# include
# endif
# endif
#endif
#ifdef __EMX__
# define LACK_TIMES
# include
# include
#endif
#ifdef MWC
# include
# include
#endif
#ifdef ARM_ULIB
# include
# include
#endif
#ifdef vms
# define LACK_TIMES
# define LACK_FTIME
#endif
#ifndef CLKTCK
# ifdef CLK_TCK
# define CLKTCK CLK_TCK
# ifdef CLOCKS_PER_SEC
# ifdef HAVE_UNIX
# ifndef ARM_ULIB
# include
# endif
# define LACK_CLOCK
/* This is because clock() might be POSIX rather than ANSI.
This occurs on HP-UX machines */
# endif
# endif
# else
# ifdef CLOCKS_PER_SEC
# define CLKTCK CLOCKS_PER_SEC
# else
# define LACK_CLOCK
# ifdef AMIGA
# include
# define LACK_TIMES
# define LACK_FTIME
# define CLKTCK 1000
# else
# define CLKTCK 60
# endif
# endif
# endif
#endif
#ifdef __STDC__
# define timet time_t
#else
# define timet long
#endif
#ifdef LACK_TIMES
# ifdef LACK_CLOCK
# ifdef AMIGA
/* From: "Fred Bayer" */
# ifdef AZTEC_C /* AZTEC_C */
# include
static long mytime()
{
long sec, mic, mili = 0;
struct timerequest *timermsg;
struct MsgPort *timerport;
if (!(timerport = (struct MsgPort *)CreatePort(0, 0))){
lputs("No mem for port.\n", cur_errp);
return mili;
}
if (!(timermsg = (struct timerequest *)
CreateExtIO(timerport, sizeof(struct timerequest)))){
lputs("No mem for timerequest.\n", cur_errp);
DeletePort(timermsg->tr_node.io_Message.mn_ReplyPort);
return mili;
}
if (!(OpenDevice(TIMERNAME, UNIT_MICROHZ, timermsg, 0))){
timermsg->tr_node.io_Command = TR_GETSYSTIME;
timermsg->tr_node.io_Flags = 0;
DoIO(timermsg);
sec = timermsg->tr_time.tv_secs;
mic = timermsg->tr_time.tv_micro;
mili = sec*1000+mic/1000;
CloseDevice(timermsg);
}
else lputs("No Timer available.\n", cur_errp);
DeletePort(timermsg->tr_node.io_Message.mn_ReplyPort);
DeleteExtIO(timermsg);
return mili ;
}
# else /* this is for SAS/C */
static long mytime()
{
unsigned int cl[2];
timer(cl);
return(cl[0]*1000+cl[1]/1000);
}
# endif /* AZTEC_C */
# else /* AMIGA */
# define mytime() ((time((timet*)0) - your_base) * CLKTCK)
# endif /* AMIGA */
# else /* LACK_CLOCK */
# define mytime clock
# endif /* LACK_CLOCK */
#else /* LACK_TIMES */
static long mytime()
{
struct tms time_buffer;
times(&time_buffer);
return time_buffer.tms_utime + time_buffer.tms_stime;
}
#endif /* LACK_TIMES */
#ifdef LACK_FTIME
# ifdef AMIGA
SCM your_time()
{
return MAKINUM(mytime());
}
# else
timet your_base = 0;
SCM your_time()
{
return MAKINUM((time((timet*)0) - your_base) * (int)CLKTCK);
}
# endif /* AMIGA */
#else /* LACK_FTIME */
# ifdef USE_GETTIMEOFDAY
int scm_ftime(time_buffer)
struct timeval *time_buffer;
{
struct timezone t_z;
if (gettimeofday(time_buffer, &t_z) < 0) return -1;
return 0;}
struct timeval your_base = {0, 0};
# define TIMETRIES 10
SCM your_time()
{
long tmp;
struct timeval time_buffer1;
struct timeval time_buffer2;
int cnt = 0;
tryagain:
cnt++;
scm_ftime(&time_buffer1);
scm_ftime(&time_buffer2);
if (time_buffer1.tv_sec==time_buffer2.tv_sec) {
if (time_buffer1.tv_usec > time_buffer2.tv_usec)
time_buffer2.tv_sec = time_buffer2.tv_sec + 1;
}
else if ((1 + time_buffer1.tv_sec)==time_buffer2.tv_sec) ;
else if (cnt < TIMETRIES) goto tryagain;
else { /* could not read two ftime()s within one second in 10 tries */
scm_warn("ftime()s too fast", "", MAKINUM(TIMETRIES));
return MAKINUM(-1);
}
tmp = CLKTCK*(time_buffer2.tv_usec - your_base.tv_usec);
tmp = CLKTCK*(time_buffer2.tv_sec - your_base.tv_sec) + tmp/1000000;
return MAKINUM(tmp);
}
# else /* USE_GETTIMEOFDAY */
# define scm_ftime ftime
struct timeb your_base = {0};
# define TIMETRIES 10
SCM your_time()
{
long tmp;
struct timeb time_buffer1;
struct timeb time_buffer2;
int cnt = 0;
tryagain:
cnt++;
scm_ftime(&time_buffer1);
scm_ftime(&time_buffer2);
if (time_buffer1.time==time_buffer2.time) {
if (time_buffer1.millitm > time_buffer2.millitm)
time_buffer2.time = time_buffer2.time + 1;
}
else if ((1 + time_buffer1.time)==time_buffer2.time) ;
else if (cnt < TIMETRIES) goto tryagain;
else { /* could not read two ftime()s within one second in 10 tries */
scm_warn("ftime()s too fast", "", MAKINUM(TIMETRIES));
return MAKINUM(-1);
}
tmp = CLKTCK*(time_buffer2.millitm - your_base.millitm);
tmp = CLKTCK*(time_buffer2.time - your_base.time) + tmp/1000;
return MAKINUM(tmp);
}
# endif /* USE_GETTIMEOFDAY */
#endif /* LACK_FTIME */
long my_base = 0;
SCM my_time()
{
return MAKINUM(mytime()-my_base);
}
SCM curtime()
{
timet timv = time((timet*)0);
SCM ans;
#ifndef _DCC
# ifdef STDC_HEADERS
# if (__TURBOC__ > 0x201)
timv = mktime(gmtime(&timv));
# endif
# endif
#endif
ans = ulong2num(timv);
return BOOL_F==ans ? MAKINUM(timv) : ans;
}
long time_in_msec(x)
long x;
{
if (CLKTCK==60) return (x*50)/3;
else
return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK);
}
static iproc subr0s[] = {
{"get-internal-run-time", my_time},
{"get-internal-real-time", your_time},
{"current-time", curtime},
{0, 0}};
void reset_time()
{
#ifdef LACK_FTIME
# ifndef AMIGA
time(&your_base);
# endif
#else
scm_ftime(&your_base);
#endif
my_base = 0;
my_base = mytime();
}
void init_time()
{
sysintern("internal-time-units-per-second",
MAKINUM((long)CLKTCK));
reset_time();
init_iprocs(subr0s, tc7_subr_0);
}
scm/r4rstest.scm 0000755 0000000 0000000 00000113763 12327344112 012651 0 ustar root root ;;;;"r4rstest.scm": Test R4RS correctness of scheme implementations.
;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program 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
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public
;; License along with this program. If not, see
;; .
;;;;"r4rstest.scm": Test R4RS correctness of scheme implementations.
;;; Author: Aubrey Jaffer
;;; Home-page: http://swiss.csail.mit.edu/~jaffer/Scheme
;;; Current version: http://swiss.csail.mit.edu/ftpdir/scm/r4rstest.scm
;;; CVS Head:
;;; http://savannah.gnu.org/cgi-bin/viewcvs/scm/scm/r4rstest.scm?rev=HEAD&only_with_tag=HEAD&content-type=text/vnd.viewcvs-markup
;;; This includes examples from
;;; William Clinger and Jonathan Rees, editors.
;;; Revised^4 Report on the Algorithmic Language Scheme
;;; and the IEEE specification.
;;; The input tests read this file expecting it to be named "r4rstest.scm".
;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
;;; these tests. You may need to delete them in order to run
;;; "r4rstest.scm" more than once.
;;; There are three optional tests:
;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
;;;
;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
;;;
;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
;;; either standard.
;;; If you are testing a R3RS version which does not have `list?' do:
;;; (define list? #f)
;;; send corrections or additions to agj @ alum.mit.edu
(define cur-section '())(define errs '())
(define SECTION (lambda args
(display "SECTION") (write args) (newline)
(set! cur-section args) #t))
(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
(define test
(lambda (expect fun . args)
(write (cons fun args))
(display " ==> ")
((lambda (res)
(write res)
(newline)
(cond ((not (equal? expect res))
(record-error (list res expect (cons fun args)))
(display " BUT EXPECTED ")
(write expect)
(newline)
#f)
(else #t)))
(if (procedure? fun) (apply fun args) (car args)))))
(define (report-errs)
(newline)
(if (null? errs) (display "Passed all tests")
(begin
(display "errors were:")
(newline)
(display "(SECTION (got expected (call)))")
(newline)
(for-each (lambda (l) (write l) (newline))
errs)))
(newline))
(SECTION 2 1);; test that all symbol characters are supported.
'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
(SECTION 3 4)
(define disjoint-type-functions
(list boolean? char? null? number? pair? procedure? string? symbol? vector?))
(define type-examples
(list
#t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
(define i 1)
(for-each (lambda (x) (display (make-string i #\space))
(set! i (+ 3 i))
(write x)
(newline))
disjoint-type-functions)
(define type-matrix
(map (lambda (x)
(let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
(write t)
(write x)
(newline)
t))
type-examples))
(set! i 0)
(define j 0)
(for-each (lambda (x y)
(set! j (+ 1 j))
(set! i 0)
(for-each (lambda (f)
(set! i (+ 1 i))
(cond ((and (= i j))
(cond ((not (f x)) (test #t f x))))
((f x) (test #f f x)))
(cond ((and (= i j))
(cond ((not (f y)) (test #t f y))))
((f y) (test #f f y))))
disjoint-type-functions))
(list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c))
(list #f #\newline '() -3252 '(t . t) car "" 'nil '#()))
(SECTION 4 1 2)
(test '(quote a) 'quote (quote 'a))
(test '(quote a) 'quote ''a)
(SECTION 4 1 3)
(test 12 (if #f + *) 3 4)
(SECTION 4 1 4)
(test 8 (lambda (x) (+ x x)) 4)
(define reverse-subtract
(lambda (x y) (- y x)))
(test 3 reverse-subtract 7 10)
(define add4
(let ((x 4))
(lambda (y) (+ x y))))
(test 10 add4 6)
(test '(3 4 5 6) (lambda x x) 3 4 5 6)
(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
(SECTION 4 1 5)
(test 'yes 'if (if (> 3 2) 'yes 'no))
(test 'no 'if (if (> 2 3) 'yes 'no))
(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
(SECTION 4 1 6)
(define x 2)
(test 3 'define (+ x 1))
(set! x 4)
(test 5 'set! (+ x 1))
(SECTION 4 2 1)
(test 'greater 'cond (cond ((> 3 2) 'greater)
((< 3 2) 'less)))
(test 'equal 'cond (cond ((> 3 3) 'greater)
((< 3 3) 'less)
(else 'equal)))
(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
(else #f)))
(test 'composite 'case (case (* 2 3)
((2 3 5 7) 'prime)
((1 4 6 8 9) 'composite)))
(test 'consonant 'case (case (car '(c d))
((a e i o u) 'vowel)
((w y) 'semivowel)
(else 'consonant)))
(test #t 'and (and (= 2 2) (> 2 1)))
(test #f 'and (and (= 2 2) (< 2 1)))
(test '(f g) 'and (and 1 2 'c '(f g)))
(test #t 'and (and))
(test #t 'or (or (= 2 2) (> 2 1)))
(test #t 'or (or (= 2 2) (< 2 1)))
(test #f 'or (or #f #f #f))
(test #f 'or (or))
(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
(SECTION 4 2 2)
(test 6 'let (let ((x 2) (y 3)) (* x y)))
(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
(test #t 'letrec (letrec ((even?
(lambda (n) (if (zero? n) #t (odd? (- n 1)))))
(odd?
(lambda (n) (if (zero? n) #f (even? (- n 1))))))
(even? 88)))
(define x 34)
(test 5 'let (let ((x 3)) (define x 5) x))
(test 34 'let x)
(test 6 'let (let () (define x 6) x))
(test 34 'let x)
(test 34 'let (let ((x x)) x))
(test 7 'let* (let* ((x 3)) (define x 7) x))
(test 34 'let* x)
(test 8 'let* (let* () (define x 8) x))
(test 34 'let* x)
(test 9 'letrec (letrec () (define x 9) x))
(test 34 'letrec x)
(test 10 'letrec (letrec ((x 3)) (define x 10) x))
(test 34 'letrec x)
(define (s x) (if x (let () (set! s x) (set! x s))))
(SECTION 4 2 3)
(define x 0)
(test 6 'begin (begin (set! x (begin (begin 5)))
(begin ((begin +) (begin x) (begin (begin 1))))))
(SECTION 4 2 4)
(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
(i 0 (+ i 1)))
((= i 5) vec)
(vector-set! vec i i)))
(test 25 'do (let ((x '(1 3 5 7 9)))
(do ((x x (cdr x))
(sum 0 (+ sum (car x))))
((null? x) sum))))
(test 25 'do (let ((x '(1 3 5 7 9))
(sum 0))
(do ((x x (cdr x)))
((null? x))
(set! sum (+ sum (car x))))
sum))
(test 1 'let (let foo () 1))
(test '((6 1 3) (-5 -2)) 'let
(let loop ((numbers '(3 -2 1 6 -5))
(nonneg '())
(neg '()))
(cond ((null? numbers) (list nonneg neg))
((negative? (car numbers))
(loop (cdr numbers)
nonneg
(cons (car numbers) neg)))
(else
(loop (cdr numbers)
(cons (car numbers) nonneg)
neg)))))
;;From: Allegro Petrofsky
(test -1 'let (let ((f -)) (let f ((n (f 1))) n)))
(SECTION 4 2 6)
(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
(test '((foo 7) . cons)
'quasiquote
`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
;;; sqt is defined here because not all implementations are required to
;;; support it.
(define (sqt x)
(do ((i 0 (+ i 1)))
((> (* i i) x) (- i 1))))
(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
(test 5 'quasiquote `,(+ 2 3))
(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
(test '(a `(b ,x ,'y d) e) 'quasiquote
(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
(SECTION 5 2 1)
(define (tprint x) #t)
(test #t 'tprint (tprint 56))
(define add3 (lambda (x) (+ x 3)))
(test 6 'define (add3 3))
(define first car)
(test 1 'define (first '(1 2)))
(define foo (lambda () 9))
(test 9 'define (foo))
(define foo foo)
(test 9 'define (foo))
(define foo (let ((foo foo)) (lambda () (+ 1 (foo)))))
(test 10 'define (foo))
(define old-+ +)
(begin (begin (begin)
(begin (begin (begin) (define + (lambda (x y) (list y x)))
(begin)))
(begin))
(begin)
(begin (begin (begin) (test '(3 6) add3 6)
(begin))))
(set! + old-+)
(test 9 add3 6)
(begin)
(begin (begin))
(begin (begin (begin (begin))))
(SECTION 5 2 2)
(test 45 'define
(let ((x 5))
(begin (begin (begin)
(begin (begin (begin) (define foo (lambda (y) (bar x y)))
(begin)))
(begin))
(begin)
(begin)
(begin (define bar (lambda (a b) (+ (* a b) a))))
(begin))
(begin)
(begin (foo (+ x 3)))))
(define x 34)
(define (foo) (define x 5) x)
(test 5 foo)
(test 34 'define x)
(define foo (lambda () (define x 5) x))
(test 5 foo)
(test 34 'define x)
(define (foo x) ((lambda () (define x 5) x)) x)
(test 88 foo 88)
(test 4 foo 4)
(test 34 'define x)
(test 99 'internal-define (letrec ((foo (lambda (arg)
(or arg (and (procedure? foo)
(foo 99))))))
(define bar (foo #f))
(foo #f)))
(test 77 'internal-define (letrec ((foo 77)
(bar #f)
(retfoo (lambda () foo)))
(define baz (retfoo))
(retfoo)))
(SECTION 6 1)
(test #f not #t)
(test #f not 3)
(test #f not (list 3))
(test #t not #f)
(test #f not '())
(test #f not (list))
(test #f not 'nil)
;(test #t boolean? #f)
;(test #f boolean? 0)
;(test #f boolean? '())
(SECTION 6 2)
(test #t eqv? 'a 'a)
(test #f eqv? 'a 'b)
(test #t eqv? 2 2)
(test #t eqv? '() '())
(test #t eqv? '10000 '10000)
(test #f eqv? (cons 1 2)(cons 1 2))
(test #f eqv? (lambda () 1) (lambda () 2))
(test #f eqv? #f 'nil)
(let ((p (lambda (x) x)))
(test #t eqv? p p))
(define gen-counter
(lambda ()
(let ((n 0))
(lambda () (set! n (+ n 1)) n))))
(let ((g (gen-counter))) (test #t eqv? g g))
(test #f eqv? (gen-counter) (gen-counter))
(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
(g (lambda () (if (eqv? f g) 'g 'both))))
(test #f eqv? f g))
(test #t eq? 'a 'a)
(test #f eq? (list 'a) (list 'a))
(test #t eq? '() '())
(test #t eq? car car)
(let ((x '(a))) (test #t eq? x x))
(let ((x '#())) (test #t eq? x x))
(let ((x (lambda (x) x))) (test #t eq? x x))
(define test-eq?-eqv?-agreement
(lambda (obj1 obj2)
(cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2)))
(else
(record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2)))
(display "eqv? and eq? disagree about ")
(write obj1)
(display #\space)
(write obj2)
(newline)))))
(test-eq?-eqv?-agreement '#f '#f)
(test-eq?-eqv?-agreement '#t '#t)
(test-eq?-eqv?-agreement '#t '#f)
(test-eq?-eqv?-agreement '(a) '(a))
(test-eq?-eqv?-agreement '(a) '(b))
(test-eq?-eqv?-agreement car car)
(test-eq?-eqv?-agreement car cdr)
(test-eq?-eqv?-agreement (list 'a) (list 'a))
(test-eq?-eqv?-agreement (list 'a) (list 'b))
(test-eq?-eqv?-agreement '#(a) '#(a))
(test-eq?-eqv?-agreement '#(a) '#(b))
(test-eq?-eqv?-agreement "abc" "abc")
(test-eq?-eqv?-agreement "abc" "abz")
(test #t equal? 'a 'a)
(test #t equal? '(a) '(a))
(test #t equal? '(a (b) c) '(a (b) c))
(test #t equal? "abc" "abc")
(test #t equal? 2 2)
(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
(SECTION 6 3)
(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
(define x (list 'a 'b 'c))
(define y x)
(and list? (test #t list? y))
(set-cdr! x 4)
(test '(a . 4) 'set-cdr! x)
(test #t eqv? x y)
(test '(a b c . d) 'dot '(a . (b . (c . d))))
(and list? (test #f list? y))
(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
;(test #t pair? '(a . b))
;(test #t pair? '(a . 1))
;(test #t pair? '(a b c))
;(test #f pair? '())
;(test #f pair? '#(a b))
(test '(a) cons 'a '())
(test '((a) b c d) cons '(a) '(b c d))
(test '("a" b c) cons "a" '(b c))
(test '(a . 3) cons 'a 3)
(test '((a b) . c) cons '(a b) 'c)
(test 'a car '(a b c))
(test '(a) car '((a) b c d))
(test 1 car '(1 . 2))
(test '(b c d) cdr '((a) b c d))
(test 2 cdr '(1 . 2))
(test '(a 7 c) list 'a (+ 3 4) 'c)
(test '() list)
(test 3 length '(a b c))
(test 3 length '(a (b) (c d e)))
(test 0 length '())
(test '(x y) append '(x) '(y))
(test '(a b c d) append '(a) '(b c d))
(test '(a (b) (c)) append '(a (b)) '((c)))
(test '() append)
(test '(a b c . d) append '(a b) '(c . d))
(test 'a append '() 'a)
(test '(c b a) reverse '(a b c))
(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
(test 'c list-ref '(a b c d) 2)
(test '(a b c) memq 'a '(a b c))
(test '(b c) memq 'b '(a b c))
(test '#f memq 'a '(b c d))
(test '#f memq (list 'a) '(b (a) c))
(test '((a) c) member (list 'a) '(b (a) c))
(test '(101 102) memv 101 '(100 101 102))
(define e '((a 1) (b 2) (c 3)))
(test '(a 1) assq 'a e)
(test '(b 2) assq 'b e)
(test #f assq 'd e)
(test #f assq (list 'a) '(((a)) ((b)) ((c))))
(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
(SECTION 6 4)
;(test #t symbol? 'foo)
(test #t symbol? (car '(a b)))
;(test #f symbol? "bar")
;(test #t symbol? 'nil)
;(test #f symbol? '())
;(test #f symbol? #f)
;;; But first, what case are symbols in? Determine the standard case:
(define char-standard-case char-upcase)
(if (string=? (symbol->string 'A) "a")
(set! char-standard-case char-downcase))
(test #t 'standard-case
(string=? (symbol->string 'a) (symbol->string 'A)))
(test #t 'standard-case
(or (string=? (symbol->string 'a) "A")
(string=? (symbol->string 'A) "a")))
(define (str-copy s)
(let ((v (make-string (string-length s))))
(do ((i (- (string-length v) 1) (- i 1)))
((< i 0) v)
(string-set! v i (string-ref s i)))))
(define (string-standard-case s)
(set! s (str-copy s))
(do ((i 0 (+ 1 i))
(sl (string-length s)))
((>= i sl) s)
(string-set! s i (char-standard-case (string-ref s i)))))
(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
(test (string-standard-case "martin") symbol->string 'Martin)
(test "Malvina" symbol->string (string->symbol "Malvina"))
(test #t 'standard-case (eq? 'a 'A))
(define x (string #\a #\b))
(define y (string->symbol x))
(string-set! x 0 #\c)
(test "cb" 'string-set! x)
(test "ab" symbol->string y)
(test y string->symbol "ab")
(test #t eq? 'mISSISSIppi 'mississippi)
(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
(test 'JollyWog string->symbol (symbol->string 'JollyWog))
(SECTION 6 5 5)
(test #t number? 3)
(test #t complex? 3)
(test #t real? 3)
(test #t rational? 3)
(test #t integer? 3)
(test #t exact? 3)
(test #f inexact? 3)
(test 1 expt 0 0)
(test 0 expt 0 1)
(test 0 expt 0 256)
;;(test 0 expt 0 -255)
(test 1 expt -1 256)
(test -1 expt -1 255)
(test 1 expt -1 -256)
(test -1 expt -1 -255)
(test 1 expt 256 0)
(test 1 expt -256 0)
(test 256 expt 256 1)
(test -256 expt -256 1)
(test 8 expt 2 3)
(test -8 expt -2 3)
(test 9 expt 3 2)
(test 9 expt -3 2)
(test #t = 22 22 22)
(test #t = 22 22)
(test #f = 34 34 35)
(test #f = 34 35)
(test #t > 3 -6246)
(test #f > 9 9 -2424)
(test #t >= 3 -4 -6246)
(test #t >= 9 9)
(test #f >= 8 9)
(test #t < -1 2 3 4 5 6 7 8)
(test #f < -1 2 3 4 4 5 6 7)
(test #t <= -1 2 3 4 5 6 7 8)
(test #t <= -1 2 3 4 4 5 6 7)
(test #f < 1 3 2)
(test #f >= 1 3 2)
(test #t zero? 0)
(test #f zero? 1)
(test #f zero? -1)
(test #f zero? -100)
(test #t positive? 4)
(test #f positive? -4)
(test #f positive? 0)
(test #f negative? 4)
(test #t negative? -4)
(test #f negative? 0)
(test #t odd? 3)
(test #f odd? 2)
(test #f odd? -4)
(test #t odd? -1)
(test #f even? 3)
(test #t even? 2)
(test #t even? -4)
(test #f even? -1)
(test 38 max 34 5 7 38 6)
(test -24 min 3 5 5 330 4 -24)
(test 7 + 3 4)
(test '3 + 3)
(test 0 +)
(test 4 * 4)
(test 1 *)
(test 1 / 1)
(test -1 / -1)
(test 2 / 6 3)
(test -3 / 6 -2)
(test -3 / -6 2)
(test 3 / -6 -2)
(test -1 - 3 4)
(test -3 - 3)
(test 7 abs -7)
(test 7 abs 7)
(test 0 abs 0)
(test 5 quotient 35 7)
(test -5 quotient -35 7)
(test -5 quotient 35 -7)
(test 5 quotient -35 -7)
(test 1 modulo 13 4)
(test 1 remainder 13 4)
(test 3 modulo -13 4)
(test -1 remainder -13 4)
(test -3 modulo 13 -4)
(test 1 remainder 13 -4)
(test -1 modulo -13 -4)
(test -1 remainder -13 -4)
(test 0 modulo 0 86400)
(test 0 modulo 0 -86400)
(define (divtest n1 n2)
(= n1 (+ (* n2 (quotient n1 n2))
(remainder n1 n2))))
(test #t divtest 238 9)
(test #t divtest -238 9)
(test #t divtest 238 -9)
(test #t divtest -238 -9)
(test 4 gcd 0 4)
(test 4 gcd -4 0)
(test 4 gcd 32 -36)
(test 0 gcd)
(test 288 lcm 32 -36)
(test 1 lcm)
(SECTION 6 5 5)
;;; Implementations which don't allow division by 0 can have fragile
;;; string->number.
(define (test-string->number str)
(define ans (string->number str))
(cond ((not ans) #t) ((number? ans) #t) (else ans)))
(for-each (lambda (str) (test #t test-string->number str))
'("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0"
"+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"
"#i" "#e" "#" "#i0/0"))
(cond ((number? (string->number "1+1i")) ;More kawa bait
(test #t number? (string->number "#i-i"))
(test #t number? (string->number "#i+i"))
(test #t number? (string->number "#i2+i"))))
;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
;;; Modified by jaffer.
(define (test-inexact)
(define f3.9 (string->number "3.9"))
(define f4.0 (string->number "4.0"))
(define f-3.25 (string->number "-3.25"))
(define f.25 (string->number ".25"))
(define f4.5 (string->number "4.5"))
(define f3.5 (string->number "3.5"))
(define f0.0 (string->number "0.0"))
(define f0.8 (string->number "0.8"))
(define f1.0 (string->number "1.0"))
(define f1e300 (and (string->number "1+3i") (string->number "1e300")))
(define f1e-300 (and (string->number "1+3i") (string->number "1e-300")))
(define wto write-test-obj)
(define lto load-test-obj)
(newline)
(display ";testing inexact numbers; ")
(newline)
(SECTION 6 2)
(test #f eqv? 1 f1.0)
(test #f eqv? 0 f0.0)
(test #t eqv? f0.0 f0.0)
(cond ((= f0.0 (- f0.0))
(test #t eqv? f0.0 (- f0.0))
(test #t equal? f0.0 (- f0.0))))
(cond ((= f0.0 (* -5 f0.0))
(test #t eqv? f0.0 (* -5 f0.0))
(test #t equal? f0.0 (* -5 f0.0))))
(SECTION 6 5 5)
(and f1e300
(let ((f1e300+1e300i (make-rectangular f1e300 f1e300)))
(test f1.0 'magnitude (/ (magnitude f1e300+1e300i)
(* f1e300 (sqrt 2))))
(test f.25 / f1e300+1e300i (* 4 f1e300+1e300i))))
(and f1e-300
(let ((f1e-300+1e-300i (make-rectangular f1e-300 f1e-300)))
(test f1.0 'magnitude (round (/ (magnitude f1e-300+1e-300i)
(* f1e-300 (sqrt 2)))))
(test f.25 / f1e-300+1e-300i (* 4 f1e-300+1e-300i))))
(test #t = f0.0 f0.0)
(test #t = f0.0 (- f0.0))
(test #t = f0.0 (* -5 f0.0))
(test #t inexact? f3.9)
(test #t 'max (inexact? (max f3.9 4)))
(test f4.0 max f3.9 4)
(test f4.0 exact->inexact 4)
(test f4.0 exact->inexact f4.0)
(test 4 inexact->exact 4)
(test 4 inexact->exact f4.0)
(test (- f4.0) round (- f4.5))
(test (- f4.0) round (- f3.5))
(test (- f4.0) round (- f3.9))
(test f0.0 round f0.0)
(test f0.0 round f.25)
(test f1.0 round f0.8)
(test f4.0 round f3.5)
(test f4.0 round f4.5)
;;(test f1.0 expt f0.0 f0.0)
;;(test f1.0 expt f0.0 0)
;;(test f1.0 expt 0 f0.0)
(test f0.0 expt f0.0 f1.0)
(test f0.0 expt f0.0 1)
(test f0.0 expt 0 f1.0)
(test f1.0 expt -25 f0.0)
(test f1.0 expt f-3.25 f0.0)
(test f1.0 expt f-3.25 0)
;;(test f0.0 expt f0.0 f-3.25)
(test (atan 1) atan 1 1)
(set! write-test-obj (list f.25 f-3.25)) ;.25 inexact errors less likely.
(set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
(test #t call-with-output-file
"tmp3"
(lambda (test-file)
(write-char #\; test-file)
(display #\; test-file)
(display ";" test-file)
(write write-test-obj test-file)
(newline test-file)
(write load-test-obj test-file)
(output-port? test-file)))
(check-test-file "tmp3")
(set! write-test-obj wto)
(set! load-test-obj lto)
(let ((x (string->number "4195835.0"))
(y (string->number "3145727.0")))
(test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
(report-errs))
(define (test-inexact-printing)
(let ((f0.0 (string->number "0.0"))
(f0.5 (string->number "0.5"))
(f1.0 (string->number "1.0"))
(f2.0 (string->number "2.0")))
(define log2
(let ((l2 (log 2)))
(lambda (x) (/ (log x) l2))))
(define (slow-frexp x)
(if (zero? x)
(list f0.0 0)
(let* ((l2 (log2 x))
(e (floor (log2 x)))
(e (if (= l2 e)
(inexact->exact e)
(+ (inexact->exact e) 1)))
(f (/ x (expt 2 e))))
(list f e))))
(define float-precision
(let ((mantissa-bits
(do ((i 0 (+ i 1))
(eps f1.0 (* f0.5 eps)))
((= f1.0 (+ f1.0 eps))
i)))
(minval
(do ((x f1.0 (* f0.5 x)))
((zero? (* f0.5 x)) x))))
(lambda (x)
(apply (lambda (f e)
(let ((eps
(cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits))))
((zero? f) minval)
(else (expt f2.0 (- e mantissa-bits))))))
(if (zero? eps) ;Happens if gradual underflow.
minval
eps)))
(slow-frexp x)))))
(define (float-print-test x)
(define (testit number)
(eqv? number (string->number (number->string number))))
(let ((eps (float-precision x))
(all-ok? #t))
(do ((j -100 (+ j 1)))
((or (not all-ok?) (> j 100)) all-ok?)
(let* ((xx (+ x (* j eps)))
(ok? (testit xx)))
(cond ((not ok?)
(display "Number readback failure for ")
(display `(+ ,x (* ,j ,eps))) (newline)
(display xx) (newline)
(display (string->number (number->string xx))) (newline)
(set! all-ok? #f))
;; (else (display xx) (newline))
)))))
(define (mult-float-print-test x)
(let ((res #t))
(for-each
(lambda (mult)
(or (float-print-test (* mult x)) (set! res #f)))
(map string->number
'("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100"
"0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100")))
res))
(define (float-rw-range-test)
(define success #t)
(do ((cnt -323 (+ 1 cnt)))
((> cnt 308) success)
(let* ((estr (string-append "1.e" (number->string cnt)))
(num (string->number estr))
(str (number->string num)))
(cond ((or (>= (string-length str) 10)
(not (equal? (string->number str) num)))
(set! success #f)
(for-each write (list estr num str (string->number str))))))))
(SECTION 6 5 6)
(test #t 'float-print-test (float-print-test f0.0))
(test #t 'mult-float-print-test (mult-float-print-test f1.0))
(test #t 'mult-float-print-test (mult-float-print-test
(string->number "3.0")))
(test #t 'mult-float-print-test (mult-float-print-test
(string->number "7.0")))
(test #t 'mult-float-print-test (mult-float-print-test
(string->number "3.1415926535897931")))
(test #t 'mult-float-print-test (mult-float-print-test
(string->number "2.7182818284590451")))
(test #t float-rw-range-test)))
(define (test-bignum)
(define tb
(lambda (n1 n2)
(= n1 (+ (* n2 (quotient n1 n2))
(remainder n1 n2)))))
(define b3-3 (string->number "33333333333333333333"))
(define b3-2 (string->number "33333333333333333332"))
(define b3-0 (string->number "33333333333333333330"))
(define b1-1 (string->number "11111111111111111111"))
(define b2-0 (string->number "2177452800"))
(newline)
(display ";testing bignums; ")
(newline)
(SECTION 6 5 7)
(test 0 modulo b3-3 3)
(test 0 modulo b3-3 -3)
(test 0 remainder b3-3 3)
(test 0 remainder b3-3 -3)
(test 2 modulo b3-2 3)
(test -1 modulo b3-2 -3)
(test 2 remainder b3-2 3)
(test 2 remainder b3-2 -3)
(test 1 modulo (- b3-2) 3)
(test -2 modulo (- b3-2) -3)
(test -2 remainder (- b3-2) 3)
(test -2 remainder (- b3-2) -3)
(test 3 modulo 3 b3-3)
(test b3-0 modulo -3 b3-3)
(test 3 remainder 3 b3-3)
(test -3 remainder -3 b3-3)
(test (- b3-0) modulo 3 (- b3-3))
(test -3 modulo -3 (- b3-3))
(test 3 remainder 3 (- b3-3))
(test -3 remainder -3 (- b3-3))
(test 0 modulo (- b2-0) 86400)
(test 0 modulo b2-0 -86400)
(test 0 modulo b2-0 86400)
(test 0 modulo (- b2-0) -86400)
(test 0 modulo 0 (- b2-0))
(test #t 'remainder (tb (string->number "281474976710655325431") 65535))
(test #t 'remainder (tb (string->number "281474976710655325430") 65535))
(test b1-1 gcd b3-3 b1-1)
(test 1 gcd b3-2 b1-1)
(test 1 gcd b3-0 b1-1)
(test 3 gcd b3-3 b3-0)
(test b3-3 lcm b3-3 b1-1)
(test b3-3 lcm -3 b1-1)
(let ((n (string->number
"30414093201713378043612608166064768844377641568960512")))
(and n (exact? n)
(do ((pow3 1 (* 3 pow3))
(cnt 21 (+ -1 cnt)))
((negative? cnt)
(zero? (modulo n pow3))))))
(SECTION 6 5 8)
(test "281474976710655325431" number->string
(string->number "281474976710655325431"))
(report-errs))
(define (test-numeric-predicates)
(let* ((big-ex (expt 2 150))
(big-inex (exact->inexact big-ex)))
(newline)
(display ";testing bignum-inexact comparisons;")
(newline)
(SECTION 6 5 5)
(test #f = (+ big-ex 1) big-inex (- big-ex 1))
(test #f = big-inex (+ big-ex 1) (- big-ex 1))
(test #t < (- (inexact->exact big-inex) 1)
big-inex
(+ (inexact->exact big-inex) 1))))
(SECTION 6 5 9)
(test "0" number->string 0)
(test "100" number->string 100)
(test "100" number->string 256 16)
(test 100 string->number "100")
(test 256 string->number "100" 16)
(test #f string->number "")
(test #f string->number ".")
(test #f string->number "d")
(test #f string->number "D")
(test #f string->number "i")
(test #f string->number "I")
(test #f string->number "3i")
(test #f string->number "3I")
(test #f string->number "33i")
(test #f string->number "33I")
(test #f string->number "3.3i")
(test #f string->number "3.3I")
(test #f string->number "-")
(test #f string->number "+")
(test #t 'string->number (or (not (string->number "80000000" 16))
(positive? (string->number "80000000" 16))))
(test #t 'string->number (or (not (string->number "-80000000" 16))
(negative? (string->number "-80000000" 16))))
(SECTION 6 6)
(test #t eqv? '#\ #\Space)
(test #t eqv? #\space '#\Space)
(test #t char? #\a)
(test #t char? #\()
(test #t char? #\space)
(test #t char? '#\newline)
(test #f char=? #\A #\B)
(test #f char=? #\a #\b)
(test #f char=? #\9 #\0)
(test #t char=? #\A #\A)
(test #t char? #\A #\B)
(test #f char>? #\a #\b)
(test #t char>? #\9 #\0)
(test #f char>? #\A #\A)
(test #t char<=? #\A #\B)
(test #t char<=? #\a #\b)
(test #f char<=? #\9 #\0)
(test #t char<=? #\A #\A)
(test #f char>=? #\A #\B)
(test #f char>=? #\a #\b)
(test #t char>=? #\9 #\0)
(test #t char>=? #\A #\A)
(test #f char-ci=? #\A #\B)
(test #f char-ci=? #\a #\B)
(test #f char-ci=? #\A #\b)
(test #f char-ci=? #\a #\b)
(test #f char-ci=? #\9 #\0)
(test #t char-ci=? #\A #\A)
(test #t char-ci=? #\A #\a)
(test #t char-ci? #\A #\B)
(test #f char-ci>? #\a #\B)
(test #f char-ci>? #\A #\b)
(test #f char-ci>? #\a #\b)
(test #t char-ci>? #\9 #\0)
(test #f char-ci>? #\A #\A)
(test #f char-ci>? #\A #\a)
(test #t char-ci<=? #\A #\B)
(test #t char-ci<=? #\a #\B)
(test #t char-ci<=? #\A #\b)
(test #t char-ci<=? #\a #\b)
(test #f char-ci<=? #\9 #\0)
(test #t char-ci<=? #\A #\A)
(test #t char-ci<=? #\A #\a)
(test #f char-ci>=? #\A #\B)
(test #f char-ci>=? #\a #\B)
(test #f char-ci>=? #\A #\b)
(test #f char-ci>=? #\a #\b)
(test #t char-ci>=? #\9 #\0)
(test #t char-ci>=? #\A #\A)
(test #t char-ci>=? #\A #\a)
(test #t char-alphabetic? #\a)
(test #t char-alphabetic? #\A)
(test #t char-alphabetic? #\z)
(test #t char-alphabetic? #\Z)
(test #f char-alphabetic? #\0)
(test #f char-alphabetic? #\9)
(test #f char-alphabetic? #\space)
(test #f char-alphabetic? #\;)
(test #f char-numeric? #\a)
(test #f char-numeric? #\A)
(test #f char-numeric? #\z)
(test #f char-numeric? #\Z)
(test #t char-numeric? #\0)
(test #t char-numeric? #\9)
(test #f char-numeric? #\space)
(test #f char-numeric? #\;)
(test #f char-whitespace? #\a)
(test #f char-whitespace? #\A)
(test #f char-whitespace? #\z)
(test #f char-whitespace? #\Z)
(test #f char-whitespace? #\0)
(test #f char-whitespace? #\9)
(test #t char-whitespace? #\space)
(test #f char-whitespace? #\;)
(test #f char-upper-case? #\0)
(test #f char-upper-case? #\9)
(test #f char-upper-case? #\space)
(test #f char-upper-case? #\;)
(test #f char-lower-case? #\0)
(test #f char-lower-case? #\9)
(test #f char-lower-case? #\space)
(test #f char-lower-case? #\;)
(test #\. integer->char (char->integer #\.))
(test #\A integer->char (char->integer #\A))
(test #\a integer->char (char->integer #\a))
(test #\A char-upcase #\A)
(test #\A char-upcase #\a)
(test #\a char-downcase #\A)
(test #\a char-downcase #\a)
(SECTION 6 7)
(test #t string? "The word \"recursion\\\" has many meanings.")
;(test #t string? "")
(define f (make-string 3 #\*))
(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
(test "abc" string #\a #\b #\c)
(test "" string)
(test 3 string-length "abc")
(test #\a string-ref "abc" 0)
(test #\c string-ref "abc" 2)
(test 0 string-length "")
(test "" substring "ab" 0 0)
(test "" substring "ab" 1 1)
(test "" substring "ab" 2 2)
(test "a" substring "ab" 0 1)
(test "b" substring "ab" 1 2)
(test "ab" substring "ab" 0 2)
(test "foobar" string-append "foo" "bar")
(test "foo" string-append "foo")
(test "foo" string-append "foo" "")
(test "foo" string-append "" "foo")
(test "" string-append)
(test "" make-string 0)
(test #t string=? "" "")
(test #f string? "" "")
(test #t string<=? "" "")
(test #t string>=? "" "")
(test #t string-ci=? "" "")
(test #f string-ci? "" "")
(test #t string-ci<=? "" "")
(test #t string-ci>=? "" "")
(test #f string=? "A" "B")
(test #f string=? "a" "b")
(test #f string=? "9" "0")
(test #t string=? "A" "A")
(test #t string? "A" "B")
(test #f string>? "a" "b")
(test #t string>? "9" "0")
(test #f string>? "A" "A")
(test #t string<=? "A" "B")
(test #t string<=? "a" "b")
(test #f string<=? "9" "0")
(test #t string<=? "A" "A")
(test #f string>=? "A" "B")
(test #f string>=? "a" "b")
(test #t string>=? "9" "0")
(test #t string>=? "A" "A")
(test #f string-ci=? "A" "B")
(test #f string-ci=? "a" "B")
(test #f string-ci=? "A" "b")
(test #f string-ci=? "a" "b")
(test #f string-ci=? "9" "0")
(test #t string-ci=? "A" "A")
(test #t string-ci=? "A" "a")
(test #t string-ci? "A" "B")
(test #f string-ci>? "a" "B")
(test #f string-ci>? "A" "b")
(test #f string-ci>? "a" "b")
(test #t string-ci>? "9" "0")
(test #f string-ci>? "A" "A")
(test #f string-ci>? "A" "a")
(test #t string-ci<=? "A" "B")
(test #t string-ci<=? "a" "B")
(test #t string-ci<=? "A" "b")
(test #t string-ci<=? "a" "b")
(test #f string-ci<=? "9" "0")
(test #t string-ci<=? "A" "A")
(test #t string-ci<=? "A" "a")
(test #f string-ci>=? "A" "B")
(test #f string-ci>=? "a" "B")
(test #f string-ci>=? "A" "b")
(test #f string-ci>=? "a" "b")
(test #t string-ci>=? "9" "0")
(test #t string-ci>=? "A" "A")
(test #t string-ci>=? "A" "a")
(SECTION 6 8)
(test #t vector? '#(0 (2 2 2 2) "Anna"))
;(test #t vector? '#())
(test '#(a b c) vector 'a 'b 'c)
(test '#() vector)
(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
(test 0 vector-length '#())
(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
(let ((vec (vector 0 '(2 2 2 2) "Anna")))
(vector-set! vec 1 '("Sue" "Sue"))
vec))
(test '#(hi hi) make-vector 2 'hi)
(test '#() make-vector 0)
(test '#() make-vector 0 'a)
(SECTION 6 9)
(test #t procedure? car)
(test #f procedure? 'car)
(test #t procedure? (lambda (x) (* x x)))
(test #f procedure? '(lambda (x) (* x x)))
(test #t call-with-current-continuation procedure?)
(test #t procedure? /)
(test 7 apply + (list 3 4))
(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
(test 17 apply + 10 (list 3 4))
(test '() apply list '())
(define compose (lambda (f g) (lambda args (f (apply g args)))))
(test 30 (compose sqt *) 12 75)
(test '(b e h) map cadr '((a b) (d e) (g h)))
(test '(5 7 9) map + '(1 2 3) '(4 5 6))
(test '(1 2 3) map + '(1 2 3))
(test '(1 2 3) map * '(1 2 3))
(test '(-1 -2 -3) map - '(1 2 3))
(test '#(0 1 4 9 16) 'for-each
(let ((v (make-vector 5)))
(for-each (lambda (i) (vector-set! v i (* i i)))
'(0 1 2 3 4))
v))
(test -3 call-with-current-continuation
(lambda (exit)
(for-each (lambda (x) (if (negative? x) (exit x)))
'(54 0 37 -3 245 19))
#t))
(define list-length
(lambda (obj)
(call-with-current-continuation
(lambda (return)
(letrec ((r (lambda (obj) (cond ((null? obj) 0)
((pair? obj) (+ (r (cdr obj)) 1))
(else (return #f))))))
(r obj))))))
(test 4 list-length '(1 2 3 4))
(test #f list-length '(a b . c))
(test '() map cadr '())
;;; This tests full conformance of call-with-current-continuation. It
;;; is a separate test because some schemes do not support call/cc
;;; other than escape procedures. I am indebted to
;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
;;; trees constructed of conses.
(define (next-leaf-generator obj eot)
(letrec ((return #f)
(cont (lambda (x)
(recur obj)
(set! cont (lambda (x) (return eot)))
(cont #f)))
(recur (lambda (obj)
(if (pair? obj)
(for-each recur obj)
(call-with-current-continuation
(lambda (c)
(set! cont c)
(return obj)))))))
(lambda () (call-with-current-continuation
(lambda (ret) (set! return ret) (cont #f))))))
(define (leaf-eq? x y)
(let* ((eot (list 'eot))
(xf (next-leaf-generator x eot))
(yf (next-leaf-generator y eot)))
(letrec ((loop (lambda (x y)
(cond ((not (eq? x y)) #f)
((eq? eot x) #t)
(else (loop (xf) (yf)))))))
(loop (xf) (yf)))))
(define (test-cont)
(newline)
(display ";testing continuations; ")
(newline)
(SECTION 6 9)
(test #t leaf-eq? '(a (b (c))) '((a) b c))
(test #f leaf-eq? '(a (b (c))) '((a) b c d))
(report-errs))
;;; Test Optional R4RS DELAY syntax and FORCE procedure
(define (test-delay)
(newline)
(display ";testing DELAY and FORCE; ")
(newline)
(SECTION 6 9)
(test 3 'delay (force (delay (+ 1 2))))
(test '(3 3) 'delay (let ((p (delay (+ 1 2))))
(list (force p) (force p))))
(test 2 'delay (letrec ((a-stream
(letrec ((next (lambda (n)
(cons n (delay (next (+ n 1)))))))
(next 0)))
(head car)
(tail (lambda (stream) (force (cdr stream)))))
(head (tail (tail a-stream)))))
(letrec ((count 0)
(p (delay (begin (set! count (+ count 1))
(if (> count x)
count
(force p)))))
(x 5))
(test 6 force p)
(set! x 10)
(test 6 force p))
(test 3 'force
(letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
(c #f))
(force p)))
(report-errs))
(SECTION 6 10 1)
(test #t input-port? (current-input-port))
(test #t output-port? (current-output-port))
(test #t call-with-input-file "r4rstest.scm" input-port?)
(define this-file (open-input-file "r4rstest.scm"))
(test #t input-port? this-file)
(SECTION 6 10 2)
(test #\; peek-char this-file)
(test #\; read-char this-file)
(test '(define cur-section '()) read this-file)
(test #\( peek-char this-file)
(test '(define errs '()) read this-file)
(close-input-port this-file)
(close-input-port this-file)
(define (check-test-file name)
(define test-file (open-input-file name))
(test #t 'input-port?
(call-with-input-file
name
(lambda (test-file)
(test load-test-obj read test-file)
(test #t eof-object? (peek-char test-file))
(test #t eof-object? (read-char test-file))
(input-port? test-file))))
(test #\; read-char test-file)
(test #\; read-char test-file)
(test #\; read-char test-file)
(test write-test-obj read test-file)
(test load-test-obj read test-file)
(close-input-port test-file))
(SECTION 6 10 3)
(define write-test-obj
'(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
(define load-test-obj
(list 'define 'foo (list 'quote write-test-obj)))
(test #t call-with-output-file
"tmp1"
(lambda (test-file)
(write-char #\; test-file)
(display #\; test-file)
(display ";" test-file)
(write write-test-obj test-file)
(newline test-file)
(write load-test-obj test-file)
(output-port? test-file)))
(check-test-file "tmp1")
(define test-file (open-output-file "tmp2"))
(write-char #\; test-file)
(display #\; test-file)
(display ";" test-file)
(write write-test-obj test-file)
(newline test-file)
(write load-test-obj test-file)
(test #t output-port? test-file)
(close-output-port test-file)
(check-test-file "tmp2")
(define (test-sc4)
(newline)
(display ";testing scheme 4 functions; ")
(newline)
(SECTION 6 7)
(test '(#\P #\space #\l) string->list "P l")
(test '() string->list "")
(test "1\\\"" list->string '(#\1 #\\ #\"))
(test "" list->string '())
(SECTION 6 8)
(test '(dah dah didah) vector->list '#(dah dah didah))
(test '() vector->list '#())
(test '#(dididit dah) list->vector '(dididit dah))
(test '#() list->vector '())
(SECTION 6 10 4)
(load "tmp1")
(test write-test-obj 'load foo)
(report-errs))
(report-errs)
(let ((have-inexacts?
(and (string->number "0.0") (inexact? (string->number "0.0"))))
(have-bignums?
(let ((n (string->number
"1427247692705959881058285969449495136382746625")))
(and n (exact? n)))))
(cond (have-inexacts?
(test-inexact)
(test-inexact-printing)))
(if have-bignums? (test-bignum))
(if (and have-inexacts? have-bignums?)
(test-numeric-predicates)))
(newline)
(display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
(newline)
(display "(test-cont) (test-sc4) (test-delay)")
(newline)
"last item in file"
scm/macosx-config.h 0000755 0000000 0000000 00000102544 10750242003 013246 0 ustar root root /* src/config.h. Generated from config.in by configure. */
/* src/config.in. Generated from configure.in by autoheader. */
/* GNU Emacs site configuration template file.
Copyright (C) 1988, 1993, 1994, 1999, 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.
GNU Emacs 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
General Public License for more details.
You should have received a copy of the GNU General Public
License along with GNU Emacs. If not, see
. */
/* No code in Emacs #includes config.h twice, but some bits of code
intended to work with other packages as well (like gmalloc.c)
think they can include it as many times as they like. */
#ifndef EMACS_CONFIG_H
#define EMACS_CONFIG_H
/* Define to 1 if the mktime function is broken. */
/* #undef BROKEN_MKTIME */
/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP
systems. This function is required for `alloca.c' support on those systems.
*/
/* #undef CRAY_STACKSEG_END */
/* Define to 1 if using `alloca.c'. */
/* #undef C_ALLOCA */
/* Define to 1 if using `getloadavg.c'. */
/* #undef C_GETLOADAVG */
/* Define C_SWITCH_X_SITE to contain any special flags your compiler may need
to deal with X Windows. For instance, if you've defined HAVE_X_WINDOWS
above and your X include files aren't in a place that your compiler can
find on its own, you might want to add "-I/..." or something similar. */
#define C_SWITCH_X_SITE
/* Define to 1 for DGUX with . */
/* #undef DGUX */
/* Define to 1 if you are using the GNU C Library. */
/* #undef DOUG_LEA_MALLOC */
/* Define to the canonical Emacs configuration name. */
#define EMACS_CONFIGURATION "powerpc-apple-darwin8.11.0"
/* Define to the options passed to configure. */
#define EMACS_CONFIG_OPTIONS " 'CFLAGS=-I/opt/local/include -L/opt/local/lib' 'LDFLAGS=-L/opt/local/lib' 'CPPFLAGS=-I/opt/local/include -L/opt/local/lib'"
/* Define to 1 if the `getloadavg' function needs to be run setuid or setgid.
*/
/* #undef GETLOADAVG_PRIVILEGED */
/* Define to 1 if the `getpgrp' function requires zero arguments. */
#define GETPGRP_VOID 1
/* Define to 1 if gettimeofday accepts only one argument. */
/* #undef GETTIMEOFDAY_ONE_ARGUMENT */
/* Define to 1 if you want to use the GNU memory allocator. */
/* #undef GNU_MALLOC */
/* Define to 1 if the file /usr/lpp/X11/bin/smt.exp exists. */
/* #undef HAVE_AIX_SMT_EXP */
/* Define to 1 if you have the `alarm' function. */
#define HAVE_ALARM 1
/* Define to 1 if you have `alloca', as a function or macro. */
#define HAVE_ALLOCA 1
/* Define to 1 if you have and it should be used (not on Ultrix).
*/
#define HAVE_ALLOCA_H 1
/* Define to 1 if ALSA is available. */
/* #undef HAVE_ALSA */
/* Define to 1 if you have the `bcmp' function. */
#define HAVE_BCMP 1
/* Define to 1 if you have the `bcopy' function. */
#define HAVE_BCOPY 1
/* Define to 1 if you have the `bzero' function. */
#define HAVE_BZERO 1
/* Define to 1 if you are using the Carbon API on Mac OS X. */
#define HAVE_CARBON 1
/* Define to 1 if you have the `cbrt' function. */
#define HAVE_CBRT 1
/* Define to 1 if you have the `closedir' function. */
#define HAVE_CLOSEDIR 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_COFF_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_COM_ERR_H */
/* Define to 1 if you have /usr/lib/crti.o. */
/* #undef HAVE_CRTIN */
/* Define to 1 if you have the declaration of `sys_siglist', and to 0 if you
don't. */
#define HAVE_DECL_SYS_SIGLIST 1
/* Define to 1 if you have the declaration of `tzname', and to 0 if you don't.
*/
/* #undef HAVE_DECL_TZNAME */
/* Define to 1 if you have the declaration of `__sys_siglist', and to 0 if you
don't. */
/* #undef HAVE_DECL___SYS_SIGLIST */
/* Define to 1 if you have the header file. */
/* #undef HAVE_DES_H */
/* Define to 1 if dynamic ptys are supported. */
/* #undef HAVE_DEV_PTMX */
/* Define to 1 if you have the `difftime' function. */
#define HAVE_DIFFTIME 1
/* Define to 1 if you have the `dup2' function. */
#define HAVE_DUP2 1
/* Define to 1 if you have the `euidaccess' function. */
/* #undef HAVE_EUIDACCESS */
/* Define to 1 if you have the header file. */
#define HAVE_FCNTL_H 1
/* Define to 1 if you have the `fmod' function. */
#define HAVE_FMOD 1
/* Define to 1 if you have the `fork' function. */
#define HAVE_FORK 1
/* Define to 1 if you have the `fpathconf' function. */
#define HAVE_FPATHCONF 1
/* Define to 1 if you have the `frexp' function. */
#define HAVE_FREXP 1
/* Define to 1 if fseeko (and presumably ftello) exists and is declared. */
#define HAVE_FSEEKO 1
/* Define to 1 if you have the `fsync' function. */
#define HAVE_FSYNC 1
/* Define to 1 if you have the `ftime' function. */
#define HAVE_FTIME 1
/* Define to 1 if you have the `gai_strerror' function. */
#define HAVE_GAI_STRERROR 1
/* Define to 1 if you have the `gdk_display_open' function. */
/* #undef HAVE_GDK_DISPLAY_OPEN */
/* Define to 1 if you have the `getaddrinfo' function. */
#define HAVE_GETADDRINFO 1
/* Define to 1 if you have the `getcwd' function. */
#define HAVE_GETCWD 1
/* Define to 1 if you have the `getdelim' function. */
/* #undef HAVE_GETDELIM */
/* Define to 1 if you have the `getdomainname' function. */
#define HAVE_GETDOMAINNAME 1
/* Define to 1 if you have the `gethostname' function. */
#define HAVE_GETHOSTNAME 1
/* Define to 1 if you have the `getline' function. */
/* #undef HAVE_GETLINE */
/* Define to 1 if you have the `getloadavg' function. */
#define HAVE_GETLOADAVG 1
/* Define to 1 if you have the header file. */
#define HAVE_GETOPT_H 1
/* Define to 1 if you have the `getopt_long_only' function. */
#define HAVE_GETOPT_LONG_ONLY 1
/* Define to 1 if you have the `getpagesize' function. */
#define HAVE_GETPAGESIZE 1
/* Define to 1 if you have the `getpeername' function. */
#define HAVE_GETPEERNAME 1
/* Define to 1 if you have the `getpt' function. */
/* #undef HAVE_GETPT */
/* Define to 1 if you have the `getrusage' function. */
#define HAVE_GETRUSAGE 1
/* Define to 1 if you have the `getsockname' function. */
#define HAVE_GETSOCKNAME 1
/* Define to 1 if you have the `getsockopt' function. */
#define HAVE_GETSOCKOPT 1
/* Define to 1 if you have the `gettimeofday' function. */
#define HAVE_GETTIMEOFDAY 1
/* Define to 1 if you have the `getwd' function. */
#define HAVE_GETWD 1
/* Define to 1 if you have the `get_current_dir_name' function. */
/* #undef HAVE_GET_CURRENT_DIR_NAME */
/* Define to 1 if you have the ungif library (-lungif). */
/* #undef HAVE_GIF */
/* Define to 1 if you have the `grantpt' function. */
#define HAVE_GRANTPT 1
/* Define to 1 if using GTK. */
/* #undef HAVE_GTK */
/* Define to 1 if you have GTK and pthread (-lpthread). */
/* #undef HAVE_GTK_AND_PTHREAD */
/* Define to 1 if GTK has both file selection and chooser dialog. */
/* #undef HAVE_GTK_FILE_BOTH */
/* Define to 1 if you have the `gtk_file_chooser_dialog_new' function. */
/* #undef HAVE_GTK_FILE_CHOOSER_DIALOG_NEW */
/* Define to 1 if you have the `gtk_file_selection_new' function. */
/* #undef HAVE_GTK_FILE_SELECTION_NEW */
/* Define to 1 if you have the `gtk_main' function. */
/* #undef HAVE_GTK_MAIN */
/* Define to 1 if GTK can handle more than one display. */
/* #undef HAVE_GTK_MULTIDISPLAY */
/* Define to 1 if netdb.h declares h_errno. */
#define HAVE_H_ERRNO 1
/* Define to 1 if you have the `index' function. */
#define HAVE_INDEX 1
/* Define to 1 if you have inet sockets. */
#define HAVE_INET_SOCKETS 1
/* Define to 1 if you have the header file. */
#define HAVE_INTTYPES_H 1
/* Define to 1 if you have the jpeg library (-ljpeg). */
/* #undef HAVE_JPEG */
/* Define to 1 if you have the header file. */
/* #undef HAVE_KERBEROSIV_DES_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_KERBEROSIV_KRB_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_KERBEROS_DES_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_KERBEROS_KRB_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_KRB5_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_KRB_H */
/* Define if you have and nl_langinfo(CODESET). */
#define HAVE_LANGINFO_CODESET 1
/* Define to 1 if you have the `com_err' library (-lcom_err). */
/* #undef HAVE_LIBCOM_ERR */
/* Define to 1 if you have the `crypto' library (-lcrypto). */
/* #undef HAVE_LIBCRYPTO */
/* Define to 1 if you have the `des' library (-ldes). */
/* #undef HAVE_LIBDES */
/* Define to 1 if you have the `des425' library (-ldes425). */
/* #undef HAVE_LIBDES425 */
/* Define to 1 if you have the `dgc' library (-ldgc). */
/* #undef HAVE_LIBDGC */
/* Define to 1 if you have the `dnet' library (-ldnet). */
/* #undef HAVE_LIBDNET */
/* Define to 1 if you have the hesiod library (-lhesiod). */
/* #undef HAVE_LIBHESIOD */
/* Define to 1 if you have the `intl' library (-lintl). */
/* #undef HAVE_LIBINTL */
/* Define to 1 if you have the `k5crypto' library (-lk5crypto). */
/* #undef HAVE_LIBK5CRYPTO */
/* Define to 1 if you have the `krb' library (-lkrb). */
/* #undef HAVE_LIBKRB */
/* Define to 1 if you have the `krb4' library (-lkrb4). */
/* #undef HAVE_LIBKRB4 */
/* Define to 1 if you have the `krb5' library (-lkrb5). */
/* #undef HAVE_LIBKRB5 */
/* Define to 1 if you have the `kstat' library (-lkstat). */
/* #undef HAVE_LIBKSTAT */
/* Define to 1 if you have the `lockfile' library (-llockfile). */
/* #undef HAVE_LIBLOCKFILE */
/* Define to 1 if you have the `m' library (-lm). */
#define HAVE_LIBM 1
/* Define to 1 if you have the `mail' library (-lmail). */
/* #undef HAVE_LIBMAIL */
/* Define to 1 if you have the `ncurses' library (-lncurses). */
#define HAVE_LIBNCURSES 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_LIBPNG_PNG_H */
/* Define to 1 if you have the `pthreads' library (-lpthreads). */
/* #undef HAVE_LIBPTHREADS */
/* Define to 1 if you have the resolv library (-lresolv). */
/* #undef HAVE_LIBRESOLV */
/* Define to 1 if you have the `Xext' library (-lXext). */
/* #undef HAVE_LIBXEXT */
/* Define to 1 if you have the `Xmu' library (-lXmu). */
/* #undef HAVE_LIBXMU */
/* Define to 1 if you have the Xp library (-lXp). */
/* #undef HAVE_LIBXP */
/* Define to 1 if you have the header file. */
#define HAVE_LIMITS_H 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_LINUX_VERSION_H */
/* Define to 1 if you have the header file. */
#define HAVE_LOCALE_H 1
/* Define to 1 if you have the `logb' function. */
#define HAVE_LOGB 1
/* Define to 1 if you support file names longer than 14 characters. */
#define HAVE_LONG_FILE_NAMES 1
/* Define to 1 if you have the `lrand48' function. */
#define HAVE_LRAND48 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_MACHINE_SOUNDCARD_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_MACH_MACH_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_MAILLOCK_H */
/* Define to 1 if you have the header file. */
#define HAVE_MALLOC_MALLOC_H 1
/* Define to 1 if you have the `mblen' function. */
#define HAVE_MBLEN 1
/* Define to 1 if you have the `mbrlen' function. */
#define HAVE_MBRLEN 1
/* Define to 1 if you have the `mbsinit' function. */
#define HAVE_MBSINIT 1
/* Define to 1 if declares mbstate_t. */
#define HAVE_MBSTATE_T 1
/* Define to 1 if you have the `memcmp' function. */
#define HAVE_MEMCMP 1
/* Define to 1 if you have the `memcpy' function. */
#define HAVE_MEMCPY 1
/* Define to 1 if you have the `memmove' function. */
#define HAVE_MEMMOVE 1
/* Define to 1 if you have the header file. */
#define HAVE_MEMORY_H 1
/* Define to 1 if you have the `mempcpy' function. */
/* #undef HAVE_MEMPCPY */
/* Define to 1 if you have the `memset' function. */
#define HAVE_MEMSET 1
/* Define to 1 if you have mouse menus. (This is automatic if you use X, but
the option to specify it remains.) It is also defined with other window
systems that support xmenu.c. */
#define HAVE_MENUS 1
/* Define to 1 if you have the `mkdir' function. */
#define HAVE_MKDIR 1
/* Define to 1 if you have the `mkstemp' function. */
#define HAVE_MKSTEMP 1
/* Define to 1 if you have the `mktime' function. */
#define HAVE_MKTIME 1
/* Define to 1 if you have a working `mmap' system call. */
#define HAVE_MMAP 1
/* Define to 1 if you have Motif 2.1 or newer. */
/* #undef HAVE_MOTIF_2_1 */
/* Define to 1 if you have the `mremap' function. */
/* #undef HAVE_MREMAP */
/* Define to 1 if you have the header file. */
#define HAVE_NET_IF_H 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_NLIST_H */
/* Define to 1 if personality LINUX32 can be set. */
/* #undef HAVE_PERSONALITY_LINUX32 */
/* Define to 1 if you have the png library (-lpng). */
/* #undef HAVE_PNG */
/* Define to 1 if you have the header file. */
/* #undef HAVE_PNG_H */
/* Define to 1 if you have the `posix_memalign' function. */
/* #undef HAVE_POSIX_MEMALIGN */
/* Define to 1 if you have the `pstat_getdynamic' function. */
/* #undef HAVE_PSTAT_GETDYNAMIC */
/* Define to 1 if you have the header file. */
/* #undef HAVE_PTHREAD_H */
/* Define to 1 if you have the header file. */
/* #undef HAVE_PTY_H */
/* Define to 1 if you have the header file. */
#define HAVE_PWD_H 1
/* Define to 1 if you have the `random' function. */
#define HAVE_RANDOM 1
/* Define to 1 if you have the `recvfrom' function. */
#define HAVE_RECVFROM 1
/* Define to 1 if you have the `rename' function. */
#define HAVE_RENAME 1
/* Define to 1 if you have the `res_init' function. */
#define HAVE_RES_INIT 1
/* Define to 1 if you have the `rindex' function. */
#define HAVE_RINDEX 1
/* Define to 1 if you have the `rint' function. */
#define HAVE_RINT 1
/* Define to 1 if you have the `rmdir' function. */
#define HAVE_RMDIR 1
/* Define to 1 if you have the `select' function. */
#define HAVE_SELECT 1
/* Define to 1 if you have the `sendto' function. */
#define HAVE_SENDTO 1
/* Define to 1 if you have the `setitimer' function. */
#define HAVE_SETITIMER 1
/* Define to 1 if you have the `setlocale' function. */
#define HAVE_SETLOCALE 1
/* Define to 1 if you have the `setpgid' function. */
#define HAVE_SETPGID 1
/* Define to 1 if you have the `setrlimit' function. */
#define HAVE_SETRLIMIT 1
/* Define to 1 if you have the `setsid' function. */
#define HAVE_SETSID 1
/* Define to 1 if you have the `setsockopt' function. */
#define HAVE_SETSOCKOPT 1
/* Define to 1 if you have the `shutdown' function. */
#define HAVE_SHUTDOWN 1
/* Define to 1 if the system has the type `size_t'. */
#define HAVE_SIZE_T 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_SOUNDCARD_H */
/* Define to 1 if `speed_t' is declared by . */
#define HAVE_SPEED_T 1
/* Define to 1 if you have the header file. */
#define HAVE_STDINT_H 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_STDIO_EXT_H */
/* Define to 1 if you have the header file. */
#define HAVE_STDLIB_H 1
/* Define to 1 if you have the `strerror' function. */
#define HAVE_STRERROR 1
/* Define to 1 if you have the `strftime' function. */
#define HAVE_STRFTIME 1
/* Define to 1 if you have the header file. */
#define HAVE_STRINGS_H 1
/* Define to 1 if you have the header file. */
#define HAVE_STRING_H 1
/* Define to 1 if you have the `strsignal' function. */
#define HAVE_STRSIGNAL 1
/* Define to 1 if `ifr_addr' is member of `struct ifreq'. */
#define HAVE_STRUCT_IFREQ_IFR_ADDR 1
/* Define to 1 if `ifr_broadaddr' is member of `struct ifreq'. */
#define HAVE_STRUCT_IFREQ_IFR_BROADADDR 1
/* Define to 1 if `ifr_flags' is member of `struct ifreq'. */
#define HAVE_STRUCT_IFREQ_IFR_FLAGS 1
/* Define to 1 if `ifr_hwaddr' is member of `struct ifreq'. */
/* #undef HAVE_STRUCT_IFREQ_IFR_HWADDR */
/* Define to 1 if `ifr_netmask' is member of `struct ifreq'. */
/* #undef HAVE_STRUCT_IFREQ_IFR_NETMASK */
/* Define to 1 if `n_un.n_name' is member of `struct nlist'. */
/* #undef HAVE_STRUCT_NLIST_N_UN_N_NAME */
/* Define to 1 if `tm_zone' is member of `struct tm'. */
#define HAVE_STRUCT_TM_TM_ZONE 1
/* Define to 1 if `struct utimbuf' is declared by . */
#define HAVE_STRUCT_UTIMBUF 1
/* Define to 1 if you have the `sync' function. */
#define HAVE_SYNC 1
/* Define to 1 if you have the `sysinfo' function. */
/* #undef HAVE_SYSINFO */
/* Define to 1 if you have the header file. */
#define HAVE_SYS_IOCTL_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_MMAN_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_PARAM_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_RESOURCE_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_SELECT_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_SOCKET_H 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_SYS_SOUNDCARD_H */
/* Define to 1 if you have the header file. */
#define HAVE_SYS_STAT_H 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_SYS_SYSTEMINFO_H */
/* Define to 1 if you have the header file. */
#define HAVE_SYS_TIMEB_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_TIME_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_TYPES_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_UN_H 1
/* Define to 1 if you have the header file. */
#define HAVE_SYS_UTSNAME_H 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_SYS_VLIMIT_H */
/* Define to 1 if you have that is POSIX.1 compatible. */
#define HAVE_SYS_WAIT_H 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_SYS__MBSTATE_T_H */
/* Define to 1 if you have the header file. */
#define HAVE_TERMCAP_H 1
/* Define to 1 if you have the header file. */
#define HAVE_TERMIOS_H 1
/* Define to 1 if you have the header file. */
#define HAVE_TERM_H 1
/* Define to 1 if you have the tiff library (-ltiff). */
/* #undef HAVE_TIFF */
/* Define to 1 if `struct timeval' is declared by . */
#define HAVE_TIMEVAL 1
/* Define to 1 if `tm_gmtoff' is member of `struct tm'. */
#define HAVE_TM_GMTOFF 1
/* Define to 1 if your `struct tm' has `tm_zone'. Deprecated, use
`HAVE_STRUCT_TM_TM_ZONE' instead. */
#define HAVE_TM_ZONE 1
/* Define to 1 if you have the `touchlock' function. */
/* #undef HAVE_TOUCHLOCK */
/* Define to 1 if you don't have `tm_zone' but do have the external array
`tzname'. */
/* #undef HAVE_TZNAME */
/* Define to 1 if you have the `tzset' function. */
#define HAVE_TZSET 1
/* Define to 1 if you have the `ualarm' function. */
#define HAVE_UALARM 1
/* Define to 1 if you have the header file. */
#define HAVE_UNISTD_H 1
/* Define to 1 if you have the `utimes' function. */
#define HAVE_UTIMES 1
/* Define to 1 if you have the header file. */
#define HAVE_UTIME_H 1
/* Define to 1 if you have the `vfork' function. */
#define HAVE_VFORK 1
/* Define to 1 if you have the header file. */
/* #undef HAVE_VFORK_H */
/* Define to 1 if `fork' works. */
#define HAVE_WORKING_FORK 1
/* Define to 1 if `vfork' works. */
#define HAVE_WORKING_VFORK 1
/* Define to 1 if you want to use version 11 of X windows. Otherwise, Emacs
expects to use version 10. */
/* #undef HAVE_X11 */
/* Define to 1 if you have the X11R5 or newer version of Xlib. */
/* #undef HAVE_X11R5 */
/* Define to 1 if you have the X11R6 or newer version of Xlib. */
/* #undef HAVE_X11R6 */
/* Define to 1 if you have the X11R6 or newer version of Xt. */
/* #undef HAVE_X11XTR6 */
/* Define to 1 if the file /usr/lib64 exists. */
/* #undef HAVE_X86_64_LIB64_DIR */
/* Define to 1 if you have the Xaw3d library (-lXaw3d). */
/* #undef HAVE_XAW3D */
/* Define to 1 if you're using XFree386. */
/* #undef HAVE_XFREE386 */
/* Define to 1 if you have the Xft library. */
/* #undef HAVE_XFT */
/* Define to 1 if XIM is available */
/* #undef HAVE_XIM */
/* Define to 1 if you have the XkbGetKeyboard function. */
/* #undef HAVE_XKBGETKEYBOARD */
/* Define to 1 if you have the Xpm libary (-lXpm). */
/* #undef HAVE_XPM */
/* Define to 1 if you have the `XrmSetDatabase' function. */
/* #undef HAVE_XRMSETDATABASE */
/* Define to 1 if you have the `XScreenNumberOfScreen' function. */
/* #undef HAVE_XSCREENNUMBEROFSCREEN */
/* Define to 1 if you have the `XScreenResourceString' function. */
/* #undef HAVE_XSCREENRESOURCESTRING */
/* Define to 1 if you have the `XSetWMProtocols' function. */
/* #undef HAVE_XSETWMPROTOCOLS */
/* Define to 1 if you have the SM library (-lSM). */
/* #undef HAVE_X_SM */
/* Define to 1 if you want to use the X window system. */
/* #undef HAVE_X_WINDOWS */
/* Define to 1 if you have the `__fpending' function. */
/* #undef HAVE___FPENDING */
/* Define to support using a Hesiod database to find the POP server. */
/* #undef HESIOD */
/* Define to support Kerberos-authenticated POP mail retrieval. */
/* #undef KERBEROS */
/* Define to use Kerberos 5 instead of Kerberos 4. */
/* #undef KERBEROS5 */
/* Define LD_SWITCH_X_SITE to contain any special flags your loader may need
to deal with X Windows. For instance, if you've defined HAVE_X_WINDOWS
above and your X libraries aren't in a place that your loader can find on
its own, you might want to add "-L/..." or something similar. */
#define LD_SWITCH_X_SITE
/* Define LD_SWITCH_X_SITE_AUX with an -R option in case it's needed (for
Solaris, for example). */
#define LD_SWITCH_X_SITE_AUX
/* Define to 1 if localtime caches TZ. */
/* #undef LOCALTIME_CACHE */
/* Define to support POP mail retrieval. */
#define MAIL_USE_POP 1
/* Define to 1 if your `struct nlist' has an `n_un' member. Obsolete, depend
on `HAVE_STRUCT_NLIST_N_UN_N_NAME */
/* #undef NLIST_NAME_UNION */
/* Define to 1 if you don't have struct exception in math.h. */
/* #undef NO_MATHERR */
/* Define to the address where bug reports for this package should be sent. */
#define PACKAGE_BUGREPORT ""
/* Define to the full name of this package. */
#define PACKAGE_NAME ""
/* Define to the full name and version of this package. */
#define PACKAGE_STRING ""
/* Define to the one symbol short name of this package. */
#define PACKAGE_TARNAME ""
/* Define to the version of this package. */
#define PACKAGE_VERSION ""
/* Define as `void' if your compiler accepts `void *'; otherwise define as
`char'. */
#define POINTER_TYPE void
/* Define to 1 if the C compiler supports function prototypes. */
#define PROTOTYPES 1
/* Define REL_ALLOC if you want to use the relocating allocator for buffer
space. */
/* #undef REL_ALLOC */
/* Define as the return type of signal handlers (`int' or `void'). */
#define RETSIGTYPE void
/* If using the C implementation of alloca, define if you know the
direction of stack growth for your system; otherwise it will be
automatically deduced at runtime.
STACK_DIRECTION > 0 => grows toward higher addresses
STACK_DIRECTION < 0 => grows toward lower addresses
STACK_DIRECTION = 0 => direction of growth unknown */
/* #undef STACK_DIRECTION */
/* Define to 1 if you have the ANSI C header files. */
#define STDC_HEADERS 1
/* Define to 1 on System V Release 4. */
/* #undef SVR4 */
/* Define to 1 if you can safely include both and . */
#define TIME_WITH_SYS_TIME 1
/* Define to 1 if your declares `struct tm'. */
/* #undef TM_IN_SYS_TIME */
/* Define to 1 for Encore UMAX. */
/* #undef UMAX */
/* Define to 1 for Encore UMAX 4.3 that has instead of
. */
/* #undef UMAX4_3 */
/* Define to the unexec source file name. */
#define UNEXEC_SRC unexmacosx.c
/* Define to 1 if we should use toolkit scroll bars. */
#define USE_TOOLKIT_SCROLL_BARS 1
/* Define to 1 if we should use XIM, if it is available. */
#define USE_XIM 1
/* Define to 1 if using an X toolkit. */
/* #undef USE_X_TOOLKIT */
/* Define to the type of the 6th arg of XRegisterIMInstantiateCallback, either
XPointer or XPointer*. */
/* #undef XRegisterIMInstantiateCallback_arg6 */
/* Define to 1 if on AIX 3.
System headers sometimes define this.
We just want to avoid a redefinition error message. */
#ifndef _ALL_SOURCE
/* # undef _ALL_SOURCE */
#endif
/* Number of bits in a file offset, on hosts where this is settable. */
/* #undef _FILE_OFFSET_BITS */
/* Enable GNU extensions on systems that have them. */
#ifndef _GNU_SOURCE
# define _GNU_SOURCE 1
#endif
/* Define to 1 to make fseeko visible on some hosts (e.g. glibc 2.2). */
/* #undef _LARGEFILE_SOURCE */
/* Define for large files, on AIX-style hosts. */
/* #undef _LARGE_FILES */
/* Define to rpl_ if the getopt replacement functions and variables should be
used. */
#define __GETOPT_PREFIX rpl_
/* Define like PROTOTYPES; this can be used by system headers. */
#define __PROTOTYPES 1
/* Define to compiler's equivalent of C99 restrict keyword. Don't define if
equivalent is `__restrict'. */
/* #undef __restrict */
/* Define to compiler's equivalent of C99 restrict keyword in array
declarations. Define as empty for no equivalent. */
#define __restrict_arr __restrict
/* Define to the used machine dependent file. */
#define config_machfile "m/powermac.h"
/* Define to the used os dependent file. */
#define config_opsysfile "s/darwin.h"
/* Define to empty if `const' does not conform to ANSI C. */
/* #undef const */
/* Define to a type if does not define. */
/* #undef mbstate_t */
/* Define to `int' if does not define. */
/* #undef pid_t */
/* Define to any substitute for sys_siglist. */
/* #undef sys_siglist */
/* Define as `fork' if `vfork' does not work. */
/* #undef vfork */
/* Define to empty if the keyword `volatile' does not work. Warning: valid
code using `volatile' can become incorrect without. Disable with care. */
/* #undef volatile */
/* If we're using any sort of window system, define some consequences. */
#ifdef HAVE_X_WINDOWS
#define HAVE_WINDOW_SYSTEM
#define MULTI_KBOARD
#define HAVE_MOUSE
#endif
/* If we're using the Carbon API on Mac OS X, define a few more
variables as well. */
#ifdef HAVE_CARBON
#define HAVE_WINDOW_SYSTEM
#define HAVE_MOUSE
#endif
/* Define USER_FULL_NAME to return a string
that is the user's full name.
It can assume that the variable `pw'
points to the password file entry for this user.
At some sites, the pw_gecos field contains
the user's full name. If neither this nor any other
field contains the right thing, use pw_name,
giving the user's login name, since that is better than nothing. */
#define USER_FULL_NAME pw->pw_gecos
/* Define AMPERSAND_FULL_NAME if you use the convention
that & in the full name stands for the login id. */
/* Turned on June 1996 supposing nobody will mind it. */
#define AMPERSAND_FULL_NAME
/* We have blockinput.h. */
#define DO_BLOCK_INPUT
/* Define HAVE_SOUND if we have sound support. We know it works
and compiles only on the specified platforms. For others,
it probably doesn't make sense to try. */
#if defined __FreeBSD__ || defined __NetBSD__ || defined __linux__
#ifdef HAVE_MACHINE_SOUNDCARD_H
#define HAVE_SOUND 1
#endif
#ifdef HAVE_SYS_SOUNDCARD_H
#define HAVE_SOUND 1
#endif
#ifdef HAVE_SOUNDCARD_H
#define HAVE_SOUND 1
#endif
#ifdef HAVE_ALSA
#define HAVE_SOUND 1
#endif
#endif /* __FreeBSD__ || __NetBSD__ || __linux__ */
/* If using GNU, then support inline function declarations. */
/* Don't try to switch on inline handling as detected by AC_C_INLINE
generally, because even if non-gcc compilers accept `inline', they
may reject `extern inline'. */
#if defined (__GNUC__) && defined (OPTIMIZE)
#define INLINE __inline__
#else
#define INLINE
#endif
/* Include the os and machine dependent files.
#include config_opsysfile
#include config_machfile
*/
/* Load in the conversion definitions if this system
needs them and the source file being compiled has not
said to inhibit this. There should be no need for you
to alter these lines. */
#ifdef SHORTNAMES
#ifndef NO_SHORTNAMES
#include "../shortnames/remap.h"
#endif /* not NO_SHORTNAMES */
#endif /* SHORTNAMES */
/* If no remapping takes place, static variables cannot be dumped as
pure, so don't worry about the `static' keyword. */
#ifdef NO_REMAP
/* #undef static */
#endif
/* Define `subprocesses' should be defined if you want to
have code for asynchronous subprocesses
(as used in M-x compile and M-x shell).
These do not work for some USG systems yet;
for the ones where they work, the s/SYSTEM.h file defines this flag. */
#ifndef VMS
#ifndef USG
/* #define subprocesses */
#endif
#endif
/* SIGTYPE is the macro we actually use. */
#ifndef SIGTYPE
#define SIGTYPE RETSIGTYPE
#endif
#ifdef emacs /* Don't do this for lib-src. */
/* Tell regex.c to use a type compatible with Emacs. */
#define RE_TRANSLATE_TYPE Lisp_Object
#define RE_TRANSLATE(TBL, C) CHAR_TABLE_TRANSLATE (TBL, C)
#ifdef make_number
/* If make_number is a macro, use it. */
#define RE_TRANSLATE_P(TBL) (!EQ (TBL, make_number (0)))
#else
/* If make_number is a function, avoid it. */
#define RE_TRANSLATE_P(TBL) (!(INTEGERP (TBL) && XINT (TBL) == 0))
#endif
#endif
/* Avoid link-time collision with system mktime if we will use our own. */
#if ! HAVE_MKTIME || BROKEN_MKTIME
#define mktime emacs_mktime
#endif
#define my_strftime nstrftime /* for strftime.c */
/* The rest of the code currently tests the CPP symbol BSTRING.
Override any claims made by the system-description files.
Note that on some SCO version it is possible to have bcopy and not bcmp. */
/* #undef BSTRING */
#if defined (HAVE_BCOPY) && defined (HAVE_BCMP)
#define BSTRING
#endif
/* Some of the files of Emacs which are intended for use with other
programs assume that if you have a config.h file, you must declare
the type of getenv.
This declaration shouldn't appear when alloca.s or Makefile.in
includes config.h. */
#ifndef NOT_C_CODE
extern char *getenv ();
#endif
/* These default definitions are good for almost all machines.
The exceptions override them in m/MACHINE.h. */
#ifndef BITS_PER_CHAR
#define BITS_PER_CHAR 8
#endif
#ifndef BITS_PER_SHORT
#define BITS_PER_SHORT 16
#endif
/* Note that lisp.h uses this in a preprocessor conditional, so it
would not work to use sizeof. That being so, we do all of them
without sizeof, for uniformity's sake. */
#ifndef BITS_PER_INT
#define BITS_PER_INT 32
#endif
#ifndef BITS_PER_LONG
#ifdef _LP64
#define BITS_PER_LONG 64
#else
#define BITS_PER_LONG 32
#endif
#endif
/* Define if the compiler supports function prototypes. It may do so
but not define __STDC__ (e.g. DEC C by default) or may define it as
zero. */
#define PROTOTYPES 1
/* For mktime.c: */
#ifndef __P
# if defined PROTOTYPES
# define __P(args) args
# else
# define __P(args) ()
# endif /* GCC. */
#endif /* __P */
/* Don't include "string.h" or in non-C code. */
#ifndef NOT_C_CODE
#ifdef HAVE_STRING_H
#include "string.h"
#endif
#ifdef HAVE_STRINGS_H
#include "strings.h" /* May be needed for bcopy & al. */
#endif
#ifdef HAVE_STDLIB_H
#include
#endif
#ifndef __GNUC__
# ifdef HAVE_ALLOCA_H
# include
# else /* AIX files deal with #pragma. */
# ifndef alloca /* predefined by HP cc +Olibcalls */
char *alloca ();
# endif
# endif /* HAVE_ALLOCA_H */
#endif /* __GNUC__ */
#ifndef HAVE_SIZE_T
typedef unsigned size_t;
#endif
#endif /* NOT_C_CODE */
/* Define HAVE_X_I18N if we have usable i18n support. */
#ifdef HAVE_X11R6
#define HAVE_X_I18N
#elif defined HAVE_X11R5 && !defined X11R5_INHIBIT_I18N
#define HAVE_X_I18N
#endif
/* Define HAVE_X11R6_XIM if we have usable X11R6-style XIM support. */
#if defined HAVE_X11R6 && !defined INHIBIT_X11R6_XIM
#define HAVE_X11R6_XIM
#endif
/* Should we enable expensive run-time checking of data types? */
/* #undef ENABLE_CHECKING */
#if defined __GNUC__ && (__GNUC__ > 2 \
|| (__GNUC__ == 2 && __GNUC_MINOR__ >= 5))
#define NO_RETURN __attribute__ ((__noreturn__))
#else
#define NO_RETURN /* nothing */
#endif
/* These won't be used automatically yet. We also need to know, at least,
that the stack is continuous. */
#ifdef __GNUC__
# ifndef GC_SETJMP_WORKS
/* GC_SETJMP_WORKS is nearly always appropriate for GCC --
see NON_SAVING_SETJMP in the target descriptions. */
/* Exceptions (see NON_SAVING_SETJMP in target description) are ns32k,
SCO5 non-ELF (but Emacs specifies ELF) and SVR3 on x86.
Fixme: Deal with ns32k, SVR3. */
# define GC_SETJMP_WORKS 1
# endif
# ifndef GC_LISP_OBJECT_ALIGNMENT
# define GC_LISP_OBJECT_ALIGNMENT (__alignof__ (Lisp_Object))
# endif
#endif
#ifndef HAVE_BCOPY
#define bcopy(a,b,s) memcpy (b,a,s)
#endif
#ifndef HAVE_BZERO
#define bzero(a,s) memset (a,0,s)
#endif
#ifndef HAVE_BCMP
#define BCMP memcmp
#endif
#endif /* EMACS_CONFIG_H */
/*
Local Variables:
mode: c
End:
*/
scm/README 0000755 0000000 0000000 00000125346 12455622552 011244 0 ustar root root This directory contains the distribution of scm5f2. SCM conforms to
Revised^5 Report on the Algorithmic Language Scheme and the IEEE P1178
specification. SCM runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2,
NOS/VE, Unicos, VMS, Unix and similar systems. SCM supports the SLIB
Scheme library; both SCM and SLIB are GNU packages.
`http://people.csail.mit.edu/jaffer/SCM'
0.1 Manifest
============
`.gdbinit' provides commands for debugging SCM with GDB
`COPYING' GNU GENERAL PUBLIC LICENSE
`COPYING.LESSER' GNU LESSER GENERAL PUBLIC LICENSE
`ChangeLog' changes to SCM.
`Idiffer.scm' Linear-space O(PN) sequence comparison.
`Iedline.scm' Gnu readline input editing.
`Init.scm' Scheme initialization.
`Link.scm' Dynamic link/loading.
`Macro.scm' Supports Syntax-Rules Macros.
`Makefile' builds SCMLIT using the `make' program.
`QUICKREF' Quick Reference card for R4RS and IEEE Scheme.
`README' contains a MANIFEST, INSTALLATION INSTRUCTIONS, hints
for EDITING SCHEME CODE, and a TROUBLE SHOOTING GUIDE.
`Transcen.scm' inexact builtin procedures.
`bench.scm' computes and records performance statistics of pi.scm.
`build.bat' invokes build.scm for MS-DOS
`build.scm' database for compiling and linking new SCM programs.
`byte.c' strings as bytes.
`bytenumb.c' Byte-number conversions.
`compile.scm' Hobbit compilation to C.
`continue-ia64.S'replaces make_root_continuation(), make_continuation(),
and dynthrow() in continue.c
`continue.c' continuations.
`continue.h' continuations.
`crs.c' interactive terminal control.
`debug.c' debugging, printing code.
`differ.c' Linear-space O(PN) sequence comparison.
`dynl.c' dynamically load object files.
`ecrt0.c' discover the start of initialized data space
dynamically at runtime.
`edline.c' Gnu readline input editing (get
ftp.sys.toronto.edu:/pub/rc/editline.shar).
`eval.c' evaluator, apply, map, and foreach.
`example.scm' example from R4RS which uses inexact numbers.
`fdl.texi' GNU Free Documentation License.
`findexec.c' find the executable file function.
`get-contoffset-ia64.c'makes contoffset-ia64.S for inclusion by continue-ia64.S
`gmalloc.c' Gnu malloc(); used for unexec.
`gsubr.c' make_gsubr for arbitrary (< 11) arguments to C
functions.
`ioext.c' system calls in common between PC compilers and unix.
`lastfile.c' find the point in data space between data and libraries.
`macosx-config.h'Included by unexmacosx.c and lastfile.c.
`mkimpcat.scm' build SCM-specific catalog for SLIB.
`patchlvl.h' patchlevel of this release.
`pi.c' computes digits of pi [cc -o pi pi.c;time pi 100 5].
`pi.scm' computes digits of pi [type (pi 100 5)]. Test
performance against pi.c.
`posix.c' posix library interface.
`pre-crt0.c' loaded before crt0.o on machines which do not remap
part of the data space into text space in unexec.
`r4rstest.scm' tests conformance with Scheme specifications.
`ramap.c' array mapping
`record.c' proposed `Record' user definable datatypes.
`repl.c' error, read-eval-print loop, read, write and load.
`rgx.c' string regular expression match.
`rope.c' C interface functions.
`sc2.c' procedures from R2RS and R3RS not in R4RS.
`scl.c' inexact arithmetic
`scm.1' unix style man page.
`scm.c' initialization, interrupts, and non-IEEE utility
functions.
`scm.doc' man page generated from scm.1.
`scm.h' data type and external definitions of SCM.
`scm.texi' SCM installation and use.
`scmfig.h' contains system dependent definitions.
`scmmain.c' initialization, interrupts, and non-IEEE utility
functions.
`script.c' utilities for running as `#!' script.
`setjump.h' continuations, stacks, and memory allocation.
`setjump.mar' provides setjump and longjump which do not use $unwind
utility on VMS.
`setjump.s' provides setjump and longjump for the Cray YMP.
`socket.c' BSD socket interface.
`split.scm' example use of crs.c. Input, output, and diagnostic
output directed to separate windows.
`subr.c' the rest of IEEE functions.
`sys.c' call-with-current-continuation, opening and closing
files, storage allocation and garbage collection.
`time.c' functions dealing with time.
`ugsetjump.s' provides setjump and longjump which work on Ultrix VAX.
`unexalpha.c' Convert a running program into an Alpha executable file.
`unexec.c' Convert a running program into an executable file.
`unexelf.c' Convert a running ELF program into an executable file.
`unexhp9k800.c' Convert a running HP-UX program into an executable file.
`unexmacosx.c' Convert a running program into an executable file under
MacOS X.
`unexsgi.c' Convert a running program into an IRIX executable file.
`unexsunos4.c' Convert a running program into an executable file.
`unif.c' uniform vectors.
`unix.c' non-posix system calls on unix systems.
File: scm-5f2.info, Node: Distributions, Next: GNU configure and make, Prev: Installing SCM, Up: Installing SCM
2.1 Distributions
=================
The SCM homepage contains links to precompiled binaries and source
distributions.
Downloads and instructions for installing the precompiled binaries are
at `http://people.csail.mit.edu/jaffer/SCM#QuickStart'.
If there is no precompiled binary for your platform, you may be able to
build from the source distribution. The rest of these instructions
deal with building and installing SCM and SLIB from sources.
Download (both SCM and SLIB of) either the last release or current
development snapshot from
`http://people.csail.mit.edu/jaffer/SCM#BuildFromSource'.
Unzip both the SCM and SLIB zips. For example, if you are working in
`/usr/local/src/', this will create directories `/usr/local/src/scm/'
and `/usr/local/src/slib/'.
File: scm-5f2.info, Node: GNU configure and make, Next: Building SCM, Prev: Distributions, Up: Installing SCM
2.2 GNU configure and make
==========================
`scm/configure' and `slib/configure' are Shell scripts which create the
files `scm/config.status' and `slib/config.status' on Unix and MinGW
systems.
The `config.status' files are used (included) by the Makefile to
control where the packages will be installed by `make install'. With
GNU shell (bash) and utilities, the following commands should build and
install SCM and SLIB:
bash$ (cd slib; ./configure --prefix=/usr/local/)
bash$ (cd scm
> ./configure --prefix=/usr/local/
> make scmlit
> sudo make all
> sudo make install)
bash$ (cd slib; sudo make install)
If the install commands worked, skip to *note Testing::.
If `configure' doesn't work on your system, make `scm/config.status'
and `slib/config.status' be empty files.
For additional help on using the `configure' script, run
`./configure --help'.
`make all' will attempt to create a dumped executable (*note Saving
Executable Images::), which has very small startup latency. If that
fails, it will try to compile an ordinary `scm' executable.
Note that the compilation output may contain error messages; be
concerned only if the `make install' transcripts contain errors.
`sudo' runs the command after it as user "root". On recent GNU/Linux
systems, dumping requires that `make all' be run as user root; hence
the use of `sudo'.
`make install' requires root privileges if you are installing to
standard Unix locations as specified to (or defaulted by)
`./configure'. Note that this is independent of whether you did
`sudo make all' or `make all'.
* Menu:
* Making scmlit::
* Makefile targets::
File: scm-5f2.info, Node: Making scmlit, Next: Makefile targets, Prev: GNU configure and make, Up: GNU configure and make
2.2.1 Making scmlit
-------------------
The SCM distribution `Makefile' contains rules for making "scmlit", a
"bare-bones" version of SCM sufficient for running `build'. `build' is
a Scheme program used to compile (or create scripts to compile) full
featured versions of SCM (*note Building SCM::). To create scmlit, run
`make scmlit' in the `scm/' directory.
Makefiles are not portable to the majority of platforms. If you need
to compile SCM without `scmlit', there are several ways to proceed:
* Use the build (http://people.csail.mit.edu/jaffer/buildscm.html)
web page to create custom batch scripts for compiling SCM.
* Use SCM on a different platform to run `build' to create a script
to build SCM;
* Use another implementation of Scheme to run `build' to create a
script to build SCM;
* Create your own script or `Makefile'.
Finding SLIB
------------
If you didn't create scmlit using `make scmlit', then you must create a
file named `scm/require.scm'. For most installations,
`scm/require.scm' can just be copied from `scm/requires.scm', which is
part of the SCM distribution.
If, when executing `scmlit' or `scm', you get a message like:
ERROR: "LOAD couldn't find file " "/usr/local/src/scm/require"
then create a file `require.scm' in the SCM "implementation-vicinity"
(this is the same directory as where the file `Init5f1.scm' is).
`require.scm' should have the contents:
(define (library-vicinity) "/usr/local/lib/slib/")
where the pathname string `/usr/local/lib/slib/' is to be replaced by
the pathname into which you unzipped (or installed) SLIB.
Alternatively, you can set the (shell) environment variable
`SCHEME_LIBRARY_PATH' to the pathname of the SLIB directory (*note
SCHEME_LIBRARY_PATH: SCM Variables.). If set, this environment
variable overrides `scm/require.scm'.
Absolute pathnames are recommended here; if you use a relative
pathname, SLIB can get confused when the working directory is changed
(*note chmod: I/O-Extensions.). The way to specify a relative pathname
is to append it to the implementation-vicinity, which is absolute:
(define library-vicinity
(let ((lv (string-append (implementation-vicinity) "../slib/")))
(lambda () lv)))
File: scm-5f2.info, Node: Makefile targets, Prev: Making scmlit, Up: GNU configure and make
2.2.2 Makefile targets
----------------------
Each of the following four `make' targets creates an executable named
`scm'. Each target takes its build options from a file with an `.opt'
suffix. If that options file doesn't exist, making that target will
create the file with the `-F' features: cautious, bignums, arrays,
inexact, engineering-notation, and dynamic-linking. Once that `.opt'
file exists, you can edit it to your taste and it will be preserved.
`make scm4'
Produces a R4RS executable named `scm' lacking hygienic macros
(but with defmacro). The build options are taken from `scm4.opt'.
If build or the executable fails, try removing `dynamic-linking'
from `scm4.opt'.
`make scm5'
R5RS; like `make scm4' but with `-F macro'. The build options are
taken from `scm5.opt'. If build or the executable fails, try
removing `dynamic-linking' from `scm5.opt'.
`make dscm4'
Produces a R4RS executable named `udscm4', which it starts and
dumps to a low startup latency executable named `scm'. The build
options are taken from `udscm4.opt'.
If the build fails, then `build scm4' instead. If the dumped
executable fails to run, then send me a bug report (and use
`build scm4' until the problem with dump is corrected).
`make dscm5'
Like `make dscm4' but with `-F macro'. The build options are
taken from `udscm5.opt'.
If the build fails, then `build scm5' instead. If the dumped
executable fails to run, then send me a bug report (and use
`build scm5' until the problem with dump is corrected).
If the above builds fail because of `-F dynamic-linking', then (because
they can't be dynamically linked) you will likely want to add some
other features to the build's `.opt' file. See the `-F' build option
in *note Build Options::.
If dynamic-linking is working, then you will likely want to compile
most of the modules as "DLL"s. The build options for compiling DLLs
are in `dlls.opt'.
`make x.so'
The `Xlib' module; *note SCM Language X Interface: (Xlibscm)Top.
`make myturtle'
Creates a DLL named `turtlegr.so' which is a simple graphics API.
`make wbscm.so'
The `wb' module; *note B-tree database implementation: (wb)Top.
Compiling this requires that wb source be in a peer directory to
scm.
`make dlls'
Compiles all the distributed library modules, but not `wbscm.so'.
Many of the module compiles are recursively invoked in such a way
that failure of one (which could be due to a system library not
being installed) doesn't cause the top-level `make dlls' to fail.
If `make dlls' fails as a whole, it is time to submit a bug report
(*note Reporting Problems::).
File: scm-5f2.info, Node: Building SCM, Next: Saving Executable Images, Prev: GNU configure and make, Up: Installing SCM
2.3 Building SCM
================
The file "build" loads the file "build.scm", which constructs a
relational database of how to compile and link SCM executables.
`build.scm' has information for the platforms which SCM has been ported
to (of which I have been notified). Some of this information is old,
incorrect, or incomplete. Send corrections and additions to
agj@alum.mit.edu.
* Menu:
* Invoking Build::
* Build Options:: build --help
* Compiling and Linking Custom Files::
File: scm-5f2.info, Node: Invoking Build, Next: Build Options, Prev: Building SCM, Up: Building SCM
2.3.1 Invoking Build
--------------------
This section teaches how to use `build', a Scheme program for creating
compilation scripts to produce SCM executables and library modules.
The options accepted by `build' are documented in *note Build Options::.
Use the _any_ method if you encounter problems with the other two
methods (MS-DOS, Unix).
MS-DOS
From the SCM source directory, type `build' followed by up to 9
command line arguments.
Unix
From the SCM source directory, type `./build' followed by command
line arguments.
_any_
From the SCM source directory, start `scm' or `scmlit' and type
`(load "build")'. Alternatively, start `scm' or `scmlit' with the
command line argument `-ilbuild'. This method will also work for
MS-DOS and Unix.
After loading various SLIB modules, the program will print:
type (b "build ") to build
type (b*) to enter build command loop
The `b*' procedure enters into a "build shell" where you can enter
commands (with or without the `build'). Blank lines are ignored.
To create a build script with all defaults type `build'.
If the build-shell encouters an error, you can reenter the
build-shell by typing `(b*)'. To exit scm type `(quit)'.
Here is a transcript of an interactive (b*) build-shell.
bash$ scmlit
SCM version 5e7, Copyright (C) 1990-2006 Free Software Foundation.
SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `(terms)' for details.
> (load "build")
;loading build
; loading /home/jaffer/slib/getparam
; loading /home/jaffer/slib/coerce
...
; done loading build.scm
type (b "build ") to build
type (b*) to enter build command loop
;done loading build
#
> (b*)
;loading /home/jaffer/slib/comparse
;done loading /home/jaffer/slib/comparse.scm
build> -t exe
#! /bin/sh
# unix (linux) script created by SLIB/batch Wed Oct 26 17:14:23 2011
# [-p linux]
# ================ Write file with C defines
rm -f scmflags.h
echo '#define IMPLINIT "Init5e7.scm"'>>scmflags.h
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
# ================ Compile C source files
gcc -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
# ================ Link C object files
gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc
"scm"
build> -t exe -w myscript.sh
"scm"
build> (quit)
No compilation was done. The `-t exe' command shows the compile
script. The `-t exe -w myscript.sh' line creates a file `myscript.sh'
containing the compile script. To actually compile and link it, type
`./myscript.sh'.
Invoking build without the `-F' option will build or create a shell
script with the `arrays', `inexact', and `bignums' options as defaults.
Invoking `build' with `-F lit -o scmlit' will make a script for
compiling `scmlit'.
bash$ ./build
-|
#! /bin/sh
# unix (linux) script created by SLIB/batch
# ================ Write file with C defines
rm -f scmflags.h
echo '#define IMPLINIT "Init5f1.scm"'>>scmflags.h
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
# ================ Compile C source files
gcc -O2 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
# ================ Link C object files
gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc
To cross compile for another platform, invoke build with the `-p' or
`--platform=' option. This will create a script for the platform named
in the `-p' or `--platform=' option.
bash$ ./build -o scmlit -p darwin -F lit
-|
#! /bin/sh
# unix (darwin) script created by SLIB/batch
# ================ Write file with C defines
rm -f scmflags.h
echo '#define IMPLINIT "Init5f1.scm"'>>scmflags.h
# ================ Compile C source files
cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
# ================ Link C object files
mv -f scmlit scmlit~
cc -o scmlit continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o
File: scm-5f2.info, Node: Build Options, Next: Compiling and Linking Custom Files, Prev: Invoking Build, Up: Building SCM
2.3.2 Build Options
-------------------
The options to "build" specify what, where, and how to build a SCM
program or dynamically linked module. These options are unrelated to
the SCM command line options.
-- Build Option: -p PLATFORM-NAME
-- Build Option: --platform=PLATFORM-NAME
specifies that the compilation should be for a
computer/operating-system combination called PLATFORM-NAME.
_Note_ The case of PLATFORM-NAME is distinguised. The current
PLATFORM-NAMEs are all lower-case.
The platforms defined by table "platform" in `build.scm' are:
Table: platform
name processor operating-system compiler
#f processor-family operating-system #f
symbol processor-family operating-system symbol
symbol symbol symbol symbol
================= ================= ================= =================
*unknown* *unknown* unix cc
acorn-unixlib acorn *unknown* cc
aix powerpc aix cc
alpha-elf alpha unix cc
alpha-linux alpha linux gcc
amiga-aztec m68000 amiga cc
amiga-dice-c m68000 amiga dcc
amiga-gcc m68000 amiga gcc
amiga-sas m68000 amiga lc
atari-st-gcc m68000 atari-st gcc
atari-st-turbo-c m68000 atari-st tcc
borland-c i8086 ms-dos bcc
darwin powerpc unix cc
djgpp i386 ms-dos gcc
freebsd *unknown* unix cc
gcc *unknown* unix gcc
gnu-win32 i386 unix gcc
highc i386 ms-dos hc386
hp-ux hp-risc hp-ux cc
irix mips irix gcc
linux *unknown* linux gcc
linux-aout i386 linux gcc
linux-ia64 ia64 linux gcc
microsoft-c i8086 ms-dos cl
microsoft-c-nt i386 ms-dos cl
microsoft-quick-c i8086 ms-dos qcl
ms-dos i8086 ms-dos cc
netbsd *unknown* unix gcc
openbsd *unknown* unix gcc
os/2-cset i386 os/2 icc
os/2-emx i386 os/2 gcc
osf1 alpha unix cc
plan9-8 i386 plan9 8c
sunos sparc sunos cc
svr4 *unknown* unix cc
svr4-gcc-sun-ld sparc sunos gcc
turbo-c i8086 ms-dos tcc
unicos cray unicos cc
unix *unknown* unix cc
vms vax vms cc
vms-gcc vax vms gcc
watcom-9.0 i386 ms-dos wcc386p
-- Build Option: -f PATHNAME
specifies that the build options contained in PATHNAME be spliced
into the argument list at this point. The use of option files can
separate functional features from platform-specific ones.
The `Makefile' calls out builds with the options in `.opt' files:
`dlls.opt'
Options for Makefile targets dlls, myturtle, and x.so.
`gdb.opt'
Options for udgdbscm and gdbscm.
`libscm.opt'
Options for libscm.a.
`pg.opt'
Options for pgscm, which instruments C functions.
`udscm4.opt'
Options for targets udscm4 and dscm4 (scm).
`udscm5.opt'
Options for targets udscm5 and dscm5 (scm).
The Makefile creates options files it depends on only if they do
not already exist.
-- Build Option: -o FILENAME
-- Build Option: --outname=FILENAME
specifies that the compilation should produce an executable or
object name of FILENAME. The default is `scm'. Executable
suffixes will be added if neccessary, e.g. `scm' => `scm.exe'.
-- Build Option: -l LIBNAME ...
-- Build Option: --libraries=LIBNAME
specifies that the LIBNAME should be linked with the executable
produced. If compile flags or include directories (`-I') are
needed, they are automatically supplied for compilations. The `c'
library is always included. SCM "features" specify any libraries
they need; so you shouldn't need this option often.
-- Build Option: -D DEFINITION ...
-- Build Option: --defines=DEFINITION
specifies that the DEFINITION should be made in any C source
compilations. If compile flags or include directories (`-I') are
needed, they are automatically supplied for compilations. SCM
"features" specify any flags they need; so you shouldn't need this
option often.
-- Build Option: --compiler-options=FLAG
specifies that that FLAG will be put on compiler command-lines.
-- Build Option: --linker-options=FLAG
specifies that that FLAG will be put on linker command-lines.
-- Build Option: -s PATHNAME
-- Build Option: --scheme-initial=PATHNAME
specifies that PATHNAME should be the default location of the SCM
initialization file `Init5f1.scm'. SCM tries several likely
locations before resorting to PATHNAME (*note File-System
Habitat::). If not specified, the current directory (where build
is building) is used.
-- Build Option: -c PATHNAME ...
-- Build Option: --c-source-files=PATHNAME
specifies that the C source files PATHNAME ... are to be compiled.
-- Build Option: -j PATHNAME ...
-- Build Option: --object-files=PATHNAME
specifies that the object files PATHNAME ... are to be linked.
-- Build Option: -i CALL ...
-- Build Option: --initialization=CALL
specifies that the C functions CALL ... are to be invoked during
initialization.
-- Build Option: -t BUILD-WHAT
-- Build Option: --type=BUILD-WHAT
specifies in general terms what sort of thing to build. The
choices are:
`exe'
executable program.
`lib'
library module.
`dlls'
archived dynamically linked library object files.
`dll'
dynamically linked library object file.
The default is to build an executable.
-- Build Option: -h BATCH-SYNTAX
-- Build Option: -batch-dialect=BATCH-SYNTAX
specifies how to build. The default is to create a batch file for
the host system. The SLIB file `batch.scm' knows how to create
batch files for:
* unix
* dos
* vms
* amigaos (was amigados)
* system
This option executes the compilation and linking commands
through the use of the `system' procedure.
* *unknown*
This option outputs Scheme code.
-- Build Option: -w BATCH-FILENAME
-- Build Option: -script-name=BATCH-FILENAME
specifies where to write the build script. The default is to
display it on `(current-output-port)'.
-- Build Option: -F FEATURE ...
-- Build Option: --features=FEATURE
specifies to build the given features into the executable. The
defined features are:
"array"
Alias for ARRAYS
"array-for-each"
array-map! and array-for-each (arrays must also be featured).
"arrays"
Use if you want arrays, uniform-arrays and uniform-vectors.
"bignums"
Large precision integers.
"byte"
Treating strings as byte-vectors.
"byte-number"
Byte/number conversions
"careful-interrupt-masking"
Define this for extra checking of interrupt masking and some
simple checks for proper use of malloc and free. This is for
debugging C code in `sys.c', `eval.c', `repl.c' and makes the
interpreter several times slower than usual.
"cautious"
Normally, the number of arguments arguments to interpreted
closures (from LAMBDA) are checked if the function part of a
form is not a symbol or only the first time the form is
executed if the function part is a symbol. defining
`reckless' disables any checking. If you want to have SCM
always check the number of arguments to interpreted closures
define feature `cautious'.
"cheap-continuations"
If you only need straight stack continuations, executables
compile with this feature will run faster and use less
storage than not having it. Machines with unusual stacks
_need_ this. Also, if you incorporate new C code into scm
which uses VMS system services or library routines (which
need to unwind the stack in an ordrly manner) you may need to
use this feature.
"compiled-closure"
Use if you want to use compiled closures.
"curses"
For the "curses" screen management package.
"debug"
Turns on the features `cautious' and
`careful-interrupt-masking'; uses `-g' flags for debugging
SCM source code.
"differ"
Sequence comparison
"dont-memoize-locals"
SCM normally converts references to local variables to ILOCs,
which make programs run faster. If SCM is badly broken, try
using this option to disable the MEMOIZE_LOCALS feature.
"dump"
Convert a running scheme program into an executable file.
"dynamic-linking"
Be able to load compiled files while running.
"edit-line"
interface to the editline or GNU readline library.
"engineering-notation"
Use if you want floats to display in engineering notation
(exponents always multiples of 3) instead of scientific
notation.
"generalized-c-arguments"
`make_gsubr' for arbitrary (< 11) arguments to C functions.
"i/o-extensions"
Commonly available I/O extensions: "exec", line I/O, file
positioning, file delete and rename, and directory functions.
"inexact"
Use if you want floating point numbers.
"lit"
Lightweight - no features
"macro"
C level support for hygienic and referentially transparent
macros (syntax-rules macros).
"mysql"
Client connections to the mysql databases.
"no-heap-shrink"
Use if you want segments of unused heap to not be freed up
after garbage collection. This may increase time in GC for
*very* large working sets.
"none"
No features
"posix"
Posix functions available on all "Unix-like" systems. fork
and process functions, user and group IDs, file permissions,
and "link".
"reckless"
If your scheme code runs without any errors you can disable
almost all error checking by compiling all files with
`reckless'.
"record"
The Record package provides a facility for user to define
their own record data types. See SLIB for documentation.
"regex"
String regular expression matching.
"rev2-procedures"
These procedures were specified in the `Revised^2 Report on
Scheme' but not in `R4RS'.
"sicp"
Use if you want to run code from:
Harold Abelson and Gerald Jay Sussman with Julie Sussman.
`Structure and Interpretation of Computer Programs.' The MIT
Press, Cambridge, Massachusetts, USA, 1985.
Differences from R5RS are:
* (eq? '() '#f)
* (define a 25) returns the symbol a.
* (set! a 36) returns 36.
"single-precision-only"
Use if you want all inexact real numbers to be single
precision. This only has an effect if SINGLES is also
defined (which is the default). This does not affect complex
numbers.
"socket"
BSD "socket" interface. Socket addr functions require
inexacts or bignums for 32-bit precision.
"tick-interrupts"
Use if you want the ticks and ticks-interrupt functions.
"turtlegr"
"Turtle" graphics calls for both Borland-C and X11 from
sjm@ee.tut.fi.
"unix"
Those unix features which have not made it into the Posix
specs: nice, acct, lstat, readlink, symlink, mknod and sync.
"wb"
WB database with relational wrapper.
"wb-no-threads"
no-comment
"windows"
Microsoft Windows executable.
"x"
Alias for Xlib feature.
"xlib"
Interface to Xlib graphics routines.
File: scm-5f2.info, Node: Saving Executable Images, Next: Installation, Prev: Building SCM, Up: Installing SCM
2.4 Saving Executable Images
============================
In SCM, the ability to save running program images is called "dump"
(*note Dump::). In order to make `dump' available to SCM, build with
feature `dump'. `dump'ed executables are compatible with dynamic
linking.
Most of the code for "dump" is taken from `emacs-19.34/src/unex*.c'.
No modifications to the emacs source code were required to use
`unexelf.c'. Dump has not been ported to all platforms. If `unexec.c'
or `unexelf.c' don't work for you, try using the appropriate `unex*.c'
file from emacs.
The `dscm4' and `dscm5' targets in the SCM `Makefile' save images from
`udscm4' and `udscm5' executables respectively.
"Address space layout randomization" interferes with `dump'. Here are
the fixes for various operating-systems:
Fedora-Core-1
Remove the `#' from the line `#SETARCH = setarch i386' in the
`Makefile'.
Fedora-Core-3
`http://jamesthornton.com/writing/emacs-compile.html' [For FC3]
combreloc has become the default for recent GNU ld, which breaks
the unexec/undump on all versions of both Emacs and XEmacs...
Override by adding the following to `udscm5.opt':
`--linker-options="-z nocombreloc"'
Linux Kernels later than 2.6.11
`http://www.opensubscriber.com/message/emacs-devel@gnu.org/1007118.html'
mentions the "exec-shield" feature. Kernels later than 2.6.11
must do (as root):
echo 0 > /proc/sys/kernel/randomize_va_space
before dumping. `Makefile' has this `randomize_va_space' stuffing
scripted for targets `dscm4' and `dscm5'. You must either set
`randomize_va_space' to 0 or run as root to dump.
OS-X 10.6
`http://developer.apple.com/library/mac/#documentation/Darwin/Reference/Manpages/man1/dyld.1.html'
The dynamic linker uses the following environment variables. They
affect any program that uses the dynamic linker.
DYLD_NO_PIE
Causes dyld to not randomize the load addresses of images in a
process where the main executable was built position independent.
This can be helpful when trying to reproduce and debug a problem
in a PIE.
File: scm-5f2.info, Node: Installation, Next: Troubleshooting and Testing, Prev: Saving Executable Images, Up: Installing SCM
2.5 Installation
================
Once `scmlit', `scm', and `dlls' have been built, these commands will
install them to the locations specified when you ran `./configure':
bash$ (cd scm; make install)
bash$ (cd slib; make install)
Note that installation to system directories (like `/usr/bin/') will
require that those commands be run as root:
bash$ (cd scm; sudo make install)
bash$ (cd slib; sudo make install)
File: scm-5f2.info, Node: Problems Compiling, Next: Problems Linking, Prev: Troubleshooting and Testing, Up: Troubleshooting and Testing
2.6.1 Problems Compiling
------------------------
FILE PROBLEM / MESSAGE HOW TO FIX
*.c include file not found. Correct the status of
STDC_HEADERS in scmfig.h.
fix #include statement or add
#define for system type to
scmfig.h.
*.c Function should return a value. Ignore.
Parameter is never used.
Condition is always false.
Unreachable code in function.
scm.c assignment between incompatible Change SIGRETTYPE in scm.c.
types.
time.c CLK_TCK redefined. incompatablility between
and .
Remove STDC_HEADERS in scmfig.h.
Edit to remove
incompatability.
subr.c Possibly incorrect assignment Ignore.
in function lgcd.
sys.c statement not reached. Ignore.
constant in conditional
expression.
sys.c undeclared, outside of #undef STDC_HEADERS in scmfig.h.
functions.
scl.c syntax error. #define SYSTNAME to your system
type in scl.c (softtype).
File: scm-5f2.info, Node: Problems Linking, Next: Testing, Prev: Problems Compiling, Up: Troubleshooting and Testing
2.6.2 Problems Linking
----------------------
PROBLEM HOW TO FIX
_sin etc. missing. Uncomment LIBS in makefile.
File: scm-5f2.info, Node: Problems Starting, Next: Problems Running, Prev: Testing, Up: Troubleshooting and Testing
2.6.4 Problems Starting
-----------------------
PROBLEM HOW TO FIX
/bin/bash: scm: program not found Is `scm' in a `$PATH' directory?
/bin/bash: /usr/local/bin/scm: `chmod +x /usr/local/bin/scm'
Permission denied
Opening message and then machine Change memory model option to C
crashes. compiler (or makefile).
Make sure sizet definition is
correct in scmfig.h.
Reduce the size of HEAP_SEG_SIZE in
setjump.h.
Input hangs. #define NOSETBUF
ERROR: heap: need larger initial. Increase initial heap allocation
using -a or INIT_HEAP_SIZE.
ERROR: Could not allocate. Check sizet definition.
Use 32 bit compiler mode.
Don't try to run as subproccess.
remove in scmfig.h and Do so and recompile files.
recompile scm.
add in scmfig.h and
recompile scm.
ERROR: Init5f1.scm not found. Assign correct IMPLINIT in makefile
or scmfig.h.
Define environment variable
SCM_INIT_PATH to be the full
pathname of Init5f1.scm.
WARNING: require.scm not found. Define environment variable
SCHEME_LIBRARY_PATH to be the full
pathname of the scheme library
[SLIB].
Change library-vicinity in
Init5f1.scm to point to library or
remove.
Make sure the value of
(library-vicinity) has a trailing
file separator (like / or \).
File: scm-5f2.info, Node: Problems Running, Next: Reporting Problems, Prev: Problems Starting, Up: Troubleshooting and Testing
2.6.5 Problems Running
----------------------
PROBLEM HOW TO FIX
Runs some and then machine crashes. See above under machine crashes.
Runs some and then ERROR: ... Remove optimization option to C
(after a GC has happened). compiler and recompile.
#define SHORT_ALIGN in `scmfig.h'.
Some symbol names print incorrectly. Change memory model option to C
compiler (or makefile).
Check that HEAP_SEG_SIZE fits
within sizet.
Increase size of HEAP_SEG_SIZE (or
INIT_HEAP_SIZE if it is smaller
than HEAP_SEG_SIZE).
ERROR: Rogue pointer in Heap. See above under machine crashes.
Newlines don't appear correctly in Check file mode (define OPEN_... in
output files. `Init5f1.scm').
Spaces or control characters appear Check character defines in
in symbol names. `scmfig.h'.
Negative numbers turn positive. Check SRS in `scmfig.h'.
;ERROR: bignum: numerical overflow Increase NUMDIGS_MAX in `scmfig.h'
and recompile.
VMS: Couldn't unwind stack. #define CHEAP_CONTINUATIONS in
`scmfig.h'.
VAX: botched longjmp.
File: scm-5f2.info, Node: Reporting Problems, Prev: Problems Running, Up: Troubleshooting and Testing
2.6.6 Reporting Problems
------------------------
Reported problems and solutions are grouped under Compiling, Linking,
Running, and Testing. If you don't find your problem listed there, you
can send a bug report to `agj@alum.mit.edu' or `scm-discuss@gnu.org'.
The bug report should include:
1. The version of SCM (printed when SCM is invoked with no arguments).
2. The type of computer you are using.
3. The name and version of your computer's operating system.
4. The values of the environment variables `SCM_INIT_PATH' and
`SCHEME_LIBRARY_PATH'.
5. The name and version of your C compiler.
6. If you are using an executable from a distribution, the name,
vendor, and date of that distribution. In this case,
corresponding with the vendor is recommended.
File: scm-5f2.info, Node: Editing Scheme Code, Next: Debugging Scheme Code, Prev: SCM Session, Up: Operational Features
3.7 Editing Scheme Code
=======================
-- Function: ed arg1 ...
The value of the environment variable `EDITOR' (or just `ed' if it
isn't defined) is invoked as a command with arguments ARG1 ....
-- Function: ed filename
If SCM is compiled under VMS `ed' will invoke the editor with a
single the single argument FILENAME.
Gnu Emacs:
Editing of Scheme code is supported by emacs. Buffers holding
files ending in .scm are automatically put into scheme-mode.
If your Emacs can run a process in a buffer you can use the Emacs
command `M-x run-scheme' with SCM. Otherwise, use the emacs
command `M-x suspend-emacs'; or see "other systems" below.
Epsilon (MS-DOS):
There is lisp (and scheme) mode available by use of the package
`LISP.E'. It offers several different indentation formats. With
this package, buffers holding files ending in `.L', `.LSP', `.S',
and `.SCM' (my modification) are automatically put into lisp-mode.
It is possible to run a process in a buffer under Epsilon. With
Epsilon 5.0 the command line options `-e512 -m0' are neccessary to
manage RAM properly. It has been reported that when compiling SCM
with Turbo C, you need to `#define NOSETBUF' for proper operation
in a process buffer with Epsilon 5.0.
One can also call out to an editor from SCM if RAM is at a
premium; See "under other systems" below.
other systems:
Define the environment variable `EDITOR' to be the name of the
editing program you use. The SCM procedure `(ed arg1 ...)' will
invoke your editor and return to SCM when you exit the editor. The
following definition is convenient:
(define (e) (ed "work.scm") (load "work.scm"))
Typing `(e)' will invoke the editor with the file of interest.
After editing, the modified file will be loaded.
scm/findexec.c 0000755 0000000 0000000 00000013145 12064235712 012300 0 ustar root root /* "findexec.c" was part of DLD, a dynamic link/unlink editor for C.
* Copyright (C) 1990 Free Software Foundation
* Author: W. Wilson Ho.
*
* GNU Emacs is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as
* published by the Free Software Foundation, either version 3 of the
* License, or (at your option) any later version.
*
* GNU Emacs 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
* General Public License for more details.
*
* You should have received a copy of the GNU General Public
* License along with GNU Emacs. If not, see
* .
*/
/* The author can be reached electronically by how@cs.ucdavis.edu or
through physical mail at:
W. Wilson Ho
Division of Computer Science
University of California at Davis
Davis, CA 95616
Fri Sep 14 22:16:14 1990 Edgar Roeder (edgar at megamaster)
* added a separate DLDPATH environment variable in
dld_find_executable so that users may specify a special path
for object modules.
Thu Feb 3 01:46:16 1994 Aubrey Jaffer
* find_exec.c (dld_find_executable): added stat check for
linux so that it doesn't think directories with the same name
as the program are executable.
Wed Feb 21 23:06:35 1996 Aubrey Jaffer
* find_exec.c: extracted for general use. Generalized to
MS-DOS. */
/* Given a filename, dld_find_executable searches the directories
listed in the environment variable PATH for a file with that
filename. A new copy of the complete path name of that file is
returned. This new string may be disposed by free() later on. */
#ifndef __MINGW32__
# ifndef PLAN9
# include
# include
# endif
# ifdef linux
# include
# include
# include
# include /* for X_OK define */
# endif
# ifdef __SVR4
# include
# include
# include
# include /* for X_OK define */
# else
# ifdef __sgi__
# include
# include
# include
# include /* for X_OK define */
# else
# ifdef PLAN9
# include
# include
# define getcwd getwd
# define MAXPATHLEN 256 /* arbitrary? */
# define X_OK AEXEC
# else
# include
# endif
# endif
# endif
# ifdef __amigaos__
# include
# include
# include
# endif
# ifndef __STDC__
# define const /**/
# endif
# ifdef __FreeBSD__
/* This might be same for 44bsd derived system. */
# include
# include
# include
# include
# endif
# ifdef __DragonflyBSD__
/* This might be same for 44bsd derived system. */
# include
# include
# include
# include
# endif
# ifdef __NetBSD__
# include
# include
# include
# include
# endif
# ifdef __OpenBSD__
/* This might be same for 44bsd derived system. */
# include
# include
# include
/* # include */
# include
# endif
# ifdef __alpha
# include
# include
# include
# include
# endif
# ifdef GO32
# include
# endif
# ifndef DEFAULT_PATH
# define DEFAULT_PATH ".:~/bin::/usr/local/bin:/usr/new:/usr/ucb:/usr/bin:/bin:/usr/hosts"
# endif
static char *copy_of(s)
register const char *s;
{
register char *p = (char *) malloc(strlen(s)+1);
if (!p) return 0;
*p = 0;
strcpy(p, s);
return p;
}
/* ABSOLUTE_FILENAME_P(fname): True if fname is an absolute filename */
# ifdef atarist
# define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '/') || \
(fname[0] && (fname[1] == ':')))
# else
# define ABSOLUTE_FILENAME_P(fname) (fname[0] == '/')
# endif /* atarist */
/* Return 0 if getcwd() returns 0. */
char *dld_find_executable(name)
const char *name;
{
char *search;
register char *p;
char tbuf[MAXPATHLEN];
if (ABSOLUTE_FILENAME_P(name))
return access(name, X_OK) ? 0 : copy_of(name);
if (strchr(name, '/')) {
strcpy (tbuf, "."); /* in case getcwd doesn't work */
if (!getcwd(tbuf, MAXPATHLEN)) return (char *)0L;
if ((name[0] == '.') && (name[1] == '/')) {
strcat(tbuf, name + 1);
} else {
if ('/' != tbuf[strlen(tbuf) - 1]) strcat(tbuf, "/");
strcat(tbuf, name);
}
return copy_of(tbuf);
}
if (((search = (char *) getenv("DLDPATH")) == 0) &&
((search = (char *) getenv("PATH")) == 0))
search = DEFAULT_PATH;
p = search;
while (*p) {
register char *next = tbuf;
if (p[0]=='~' && p[1]=='/' && getenv("HOME")) {
strcpy(tbuf, (char *)getenv("HOME"));
next = tbuf + strlen(tbuf);
p++;
}
/* Copy directory name into [tbuf] */
while (*p && *p != ':') *next++ = *p++;
*next = 0;
if (*p) p++;
if (tbuf[0] == '.' && tbuf[1] == 0) {
if (!getcwd(tbuf, MAXPATHLEN)) return (char *)0L;
}
else if (tbuf[0]=='~' && tbuf[1]==0 && getenv("HOME"))
strcpy(tbuf, (char *)getenv("HOME"));
strcat(tbuf, "/");
strcat(tbuf, name);
if (access(tbuf, X_OK) == 0) {
# ifndef hpux
# ifndef ultrix
# ifndef __MACH__
# ifndef PLAN9
struct stat stat_temp;
if (stat(tbuf, &stat_temp)) continue;
if (S_IFREG != (S_IFMT & stat_temp.st_mode)) continue;
# endif /* PLAN9 */
# endif /* __MACH__ */
# endif/* ultrix */
# endif /* hpux */
return copy_of(tbuf);
}
}
return 0;
}
#endif /* ndef MSDOS */
scm/unix.c 0000755 0000000 0000000 00000007477 10750240571 011510 0 ustar root root /* "unix.c" functions only in Unix (unix).
* Copyright (C) 1994, 1995 Free Software Foundation, Inc.
*
* This program 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.
*
* This program 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 this program. If not, see
* .
*/
/* Author: Aubrey Jaffer */
#include "scm.h"
#include
#include
/* #include */
#include
extern SCM stat2scm P((struct stat *stat_temp));
SCM scm_mknod P((SCM path, SCM mode, SCM dev));
SCM scm_acct P((SCM path));
SCM scm_nice P((SCM incr));
SCM scm_sync P((void));
SCM scm_symlink P((SCM oldpath, SCM newpath));
SCM scm_readlink P((SCM path));
SCM scm_lstat P((SCM str));
#ifndef STDC_HEADERS
void sync P((void));
int symlink P((const char *oldpath, const char *newpath));
int readlink P((const char *path, char *buf, sizet bufsiz));
int acct P((const char *filename));
int nice P((int inc));
#else /* added by Denys Duchier: for acct, etc... */
# ifdef SVR4
# include
# endif
# ifdef __NetBSD__
# include
# endif
# ifdef __OpenBSD__
# include
# endif
#endif /* STDC_HEADERS */
/* Only the superuser can successfully execute mknod and acct */
/* int mknod P((const char *path, mode_t mode, dev_t dev));
should be in stat.h */
static char s_mknod[] = "mknod";
SCM scm_mknod(path, mode, dev)
SCM path, mode, dev;
{
int val;
ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_mknod);
ASRTER(INUMP(mode), mode, ARG2, s_mknod);
ASRTER(INUMP(dev), dev, ARG3, s_mknod);
SYSCALL(val = mknod(CHARS(path), INUM(mode), INUM(dev)););
return val ? BOOL_F : BOOL_T;
}
static char s_acct[] = "acct";
SCM scm_acct(path)
SCM path;
{
int val;
if (FALSEP(path)) {
SYSCALL(val = acct(0););
return val ? BOOL_F : BOOL_T;
}
ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_acct);
SYSCALL(val = acct(CHARS(path)););
return val ? BOOL_F : BOOL_T;
}
static char s_nice[] = "nice";
SCM scm_nice(incr)
SCM incr;
{
ASRTER(INUMP(incr), incr, ARG1, s_nice);
return nice(INUM(incr)) ? BOOL_F : BOOL_T;
}
SCM scm_sync()
{
sync();
return UNSPECIFIED;
}
static char s_symlink[] = "symlink";
SCM scm_symlink(oldpath, newpath)
SCM oldpath, newpath;
{
int val;
ASRTER(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_symlink);
ASRTER(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_symlink);
SYSCALL(val = symlink(CHARS(oldpath), CHARS(newpath)););
return val ? BOOL_F : BOOL_T;
}
static char s_readlink[] = "readlink";
SCM scm_readlink(path)
SCM path;
{
int i;
char buf[1024];
ASRTER(NIMP(path) && STRINGP(path), path, ARG1, s_readlink);
SYSCALL(i = readlink(CHARS(path), buf, (sizet)sizeof(buf)););
if (-1==i) return BOOL_F;
return makfromstr(buf, (sizet)i);
}
static char s_lstat[] = "lstat";
SCM scm_lstat(str)
SCM str;
{
int i;
struct stat stat_temp;
ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_lstat);
SYSCALL(i = lstat(CHARS(str), &stat_temp););
if (i) return BOOL_F;
return stat2scm(&stat_temp);
}
static iproc subr1s[] = {
{s_nice, scm_nice},
{s_acct, scm_acct},
{s_lstat, scm_lstat},
{s_readlink, scm_readlink},
{0, 0}};
void init_unix()
{
make_subr("sync", tc7_subr_0, scm_sync);
init_iprocs(subr1s, tc7_subr_1);
make_subr(s_symlink, tc7_subr_2, scm_symlink);
make_subr(s_mknod, tc7_subr_3, scm_mknod);
add_feature("unix");
}
scm/scm.info 0000755 0000000 0000000 00001526144 12455622551 012024 0 ustar root root This is scm-5f2.info, produced by makeinfo version 4.13 from scm.texi. |
This manual is for SCM (version 5f1, May 2013), an implementation of |
the algorithmic language Scheme.
Copyright (C) 1990-2007 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
Version 1.3 or any later version published by the Free Software
Foundation; with no Invariant Sections, no Front-Cover Texts, and
no Back-Cover Texts. A copy of the license is included in the
section entitled "GNU Free Documentation License."
INFO-DIR-SECTION The Algorithmic Language Scheme
START-INFO-DIR-ENTRY
* SCM: (scm). A Scheme interpreter.
END-INFO-DIR-ENTRY
File: scm-5f2.info, Node: Top, Next: Overview, Prev: (dir), Up: (dir)
|
SCM
***
This manual is for SCM (version 5f1, May 2013), an implementation of |
the algorithmic language Scheme.
Copyright (C) 1990-2007 Free Software Foundation, Inc.
Permission is granted to copy, distribute and/or modify this
document under the terms of the GNU Free Documentation License,
Version 1.3 or any later version published by the Free Software
Foundation; with no Invariant Sections, no Front-Cover Texts, and
no Back-Cover Texts. A copy of the license is included in the
section entitled "GNU Free Documentation License."
* Menu:
* Overview::
* Installing SCM:: How to
* Operational Features::
* The Language:: Reference.
* Packages:: Optional Capabilities.
* The Implementation:: How it works.
* Index::
File: scm-5f2.info, Node: Overview, Next: Installing SCM, Prev: Top, Up: Top
|
1 Overview
**********
SCM is a portable Scheme implementation written in C. SCM provides a
machine independent platform for [JACAL], a symbolic algebra system.
SCM supports and requires the SLIB Scheme library. SCM, SLIB, and
JACAL are GNU projects.
* Menu:
* SCM Features::
* SCM Authors::
* Copying::
* Bibliography::
File: scm-5f2.info, Node: SCM Features, Next: SCM Authors, Prev: Overview, Up: Overview
|
1.1 Features
============
* Conforms to Revised^5 Report on the Algorithmic Language Scheme
[R5RS] and the [IEEE] P1178 specification.
* Support for [SICP], [R2RS], [R3RS], and [R5RS] scheme code.
* Runs under Amiga, Atari-ST, MacOS, MS-DOS, OS/2, NOS/VE, Unicos,
VMS, Unix and similar systems. Supports ASCII and EBCDIC
character sets.
* Is fully documented in TeXinfo form, allowing documentation to be
generated in info, TeX, html, nroff, and troff formats.
* Supports inexact real and complex numbers, 30 bit immediate
integers and large precision integers.
* Many Common Lisp functions: `logand', `logor', `logxor', `lognot',
`ash', `logcount', `integer-length', `bit-extract', `defmacro',
`macroexpand', `macroexpand1', `gentemp', `defvar', `force-output',
`software-type', `get-decoded-time', `get-internal-run-time',
`get-internal-real-time', `delete-file', `rename-file',
`copy-tree', `acons', and `eval'.
* `Char-code-limit', `most-positive-fixnum', `most-negative-fixnum',
`and internal-time-units-per-second' constants. `slib:features'
and `*load-pathname*' variables.
* Arrays and bit-vectors. String ports and software emulation ports.
I/O extensions providing ANSI C and POSIX.1 facilities.
* Interfaces to standard libraries including REGEX string regular
expression matching and the CURSES screen management package.
* Available add-on packages including an interactive debugger,
database, X-window graphics, BGI graphics, Motif, and Open-Windows
packages.
* The Hobbit compiler and dynamic linking of compiled modules.
* User definable responses to interrupts and errors,
Process-syncronization primitives. Setable levels of monitoring
and timing information printed interactively (the `verbose'
function). `Restart', `quit', and `exec'.
File: scm-5f2.info, Node: SCM Authors, Next: Copying, Prev: SCM Features, Up: Overview
|
1.2 Authors
===========
Aubrey Jaffer (agj@alum.mit.edu)
Most of SCM.
Radey Shouman
Arrays, `gsubr's, compiled closures, records, Ecache, syntax-rules
macros, and "safeport"s.
Jerry D. Hedden
Real and Complex functions. Fast mixed type arithmetics.
Hugh Secker-Walker
Syntax checking and memoization of special forms by evaluator.
Storage allocation strategy and parameters.
George Carrette
"Siod", written by George Carrette, was the starting point for SCM.
The major innovations taken from Siod are the evaluator's use of
the C-stack and being able to garbage collect off the C-stack
(*note Garbage Collection::).
There are many other contributors to SCM. They are acknowledged in the
file `ChangeLog', a log of changes that have been made to scm.
File: scm-5f2.info, Node: Copying, Next: Bibliography, Prev: SCM Authors, Up: Overview
|
1.3 Copyright
=============
Authors have assigned their SCM copyrights to:
Free Software Foundation, Inc.
59 Temple Place, Suite 330, Boston, MA 02111, USA
* Menu:
* The SCM License::
* SIOD copyright::
* GNU Free Documentation License:: Copying this Manual
File: scm-5f2.info, Node: The SCM License, Next: SIOD copyright, Prev: Copying, Up: Copying
|
1.3.1 The SCM License
---------------------
This program 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.
This program 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 this program. If not, see
`http://www.gnu.org/licenses/'.
File: scm-5f2.info, Node: SIOD copyright, Next: GNU Free Documentation License, Prev: The SCM License, Up: Copying
|
1.3.2 SIOD copyright
--------------------
COPYRIGHT (C) 1989 BY
PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.
ALL RIGHTS RESERVED
Permission to use, copy, modify, distribute and sell this software and
its documentation for any purpose and without fee is hereby granted,
provided that the above copyright notice appear in all copies and that
both that copyright notice and this permission notice appear in
supporting documentation, and that the name of Paradigm Associates Inc
not be used in advertising or publicity pertaining to distribution of
the software without specific, written prior permission.
PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO
EVENT SHALL PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR
CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF
USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
PERFORMANCE OF THIS SOFTWARE.
gjc@paradigm.com
Phone: 617-492-6079
Paradigm Associates Inc
29 Putnam Ave, Suite 6
Cambridge, MA 02138
File: scm-5f2.info, Node: GNU Free Documentation License, Prev: SIOD copyright, Up: Copying
|
1.3.3 GNU Free Documentation License
------------------------------------
Version 1.3, 3 November 2008
Copyright (C) 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc.
`http://fsf.org/'
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
0. PREAMBLE
The purpose of this License is to make a manual, textbook, or other
functional and useful document "free" in the sense of freedom: to
assure everyone the effective freedom to copy and redistribute it,
with or without modifying it, either commercially or
noncommercially. Secondarily, this License preserves for the
author and publisher a way to get credit for their work, while not
being considered responsible for modifications made by others.
This License is a kind of "copyleft", which means that derivative
works of the document must themselves be free in the same sense.
It complements the GNU General Public License, which is a copyleft
license designed for free software.
We have designed this License in order to use it for manuals for
free software, because free software needs free documentation: a
free program should come with manuals providing the same freedoms
that the software does. But this License is not limited to
software manuals; it can be used for any textual work, regardless
of subject matter or whether it is published as a printed book.
We recommend this License principally for works whose purpose is
instruction or reference.
1. APPLICABILITY AND DEFINITIONS
This License applies to any manual or other work, in any medium,
that contains a notice placed by the copyright holder saying it
can be distributed under the terms of this License. Such a notice
grants a world-wide, royalty-free license, unlimited in duration,
to use that work under the conditions stated herein. The
"Document", below, refers to any such manual or work. Any member
of the public is a licensee, and is addressed as "you". You
accept the license if you copy, modify or distribute the work in a
way requiring permission under copyright law.
A "Modified Version" of the Document means any work containing the
Document or a portion of it, either copied verbatim, or with
modifications and/or translated into another language.
A "Secondary Section" is a named appendix or a front-matter section
of the Document that deals exclusively with the relationship of the
publishers or authors of the Document to the Document's overall
subject (or to related matters) and contains nothing that could
fall directly within that overall subject. (Thus, if the Document
is in part a textbook of mathematics, a Secondary Section may not
explain any mathematics.) The relationship could be a matter of
historical connection with the subject or with related matters, or
of legal, commercial, philosophical, ethical or political position
regarding them.
The "Invariant Sections" are certain Secondary Sections whose
titles are designated, as being those of Invariant Sections, in
the notice that says that the Document is released under this
License. If a section does not fit the above definition of
Secondary then it is not allowed to be designated as Invariant.
The Document may contain zero Invariant Sections. If the Document
does not identify any Invariant Sections then there are none.
The "Cover Texts" are certain short passages of text that are
listed, as Front-Cover Texts or Back-Cover Texts, in the notice
that says that the Document is released under this License. A
Front-Cover Text may be at most 5 words, and a Back-Cover Text may
be at most 25 words.
A "Transparent" copy of the Document means a machine-readable copy,
represented in a format whose specification is available to the
general public, that is suitable for revising the document
straightforwardly with generic text editors or (for images
composed of pixels) generic paint programs or (for drawings) some
widely available drawing editor, and that is suitable for input to
text formatters or for automatic translation to a variety of
formats suitable for input to text formatters. A copy made in an
otherwise Transparent file format whose markup, or absence of
markup, has been arranged to thwart or discourage subsequent
modification by readers is not Transparent. An image format is
not Transparent if used for any substantial amount of text. A
copy that is not "Transparent" is called "Opaque".
Examples of suitable formats for Transparent copies include plain
ASCII without markup, Texinfo input format, LaTeX input format,
SGML or XML using a publicly available DTD, and
standard-conforming simple HTML, PostScript or PDF designed for
human modification. Examples of transparent image formats include
PNG, XCF and JPG. Opaque formats include proprietary formats that
can be read and edited only by proprietary word processors, SGML or
XML for which the DTD and/or processing tools are not generally
available, and the machine-generated HTML, PostScript or PDF
produced by some word processors for output purposes only.
The "Title Page" means, for a printed book, the title page itself,
plus such following pages as are needed to hold, legibly, the
material this License requires to appear in the title page. For
works in formats which do not have any title page as such, "Title
Page" means the text near the most prominent appearance of the
work's title, preceding the beginning of the body of the text.
The "publisher" means any person or entity that distributes copies
of the Document to the public.
A section "Entitled XYZ" means a named subunit of the Document
whose title either is precisely XYZ or contains XYZ in parentheses
following text that translates XYZ in another language. (Here XYZ
stands for a specific section name mentioned below, such as
"Acknowledgements", "Dedications", "Endorsements", or "History".)
To "Preserve the Title" of such a section when you modify the
Document means that it remains a section "Entitled XYZ" according
to this definition.
The Document may include Warranty Disclaimers next to the notice
which states that this License applies to the Document. These
Warranty Disclaimers are considered to be included by reference in
this License, but only as regards disclaiming warranties: any other
implication that these Warranty Disclaimers may have is void and
has no effect on the meaning of this License.
2. VERBATIM COPYING
You may copy and distribute the Document in any medium, either
commercially or noncommercially, provided that this License, the
copyright notices, and the license notice saying this License
applies to the Document are reproduced in all copies, and that you
add no other conditions whatsoever to those of this License. You
may not use technical measures to obstruct or control the reading
or further copying of the copies you make or distribute. However,
you may accept compensation in exchange for copies. If you
distribute a large enough number of copies you must also follow
the conditions in section 3.
You may also lend copies, under the same conditions stated above,
and you may publicly display copies.
3. COPYING IN QUANTITY
If you publish printed copies (or copies in media that commonly
have printed covers) of the Document, numbering more than 100, and
the Document's license notice requires Cover Texts, you must
enclose the copies in covers that carry, clearly and legibly, all
these Cover Texts: Front-Cover Texts on the front cover, and
Back-Cover Texts on the back cover. Both covers must also clearly
and legibly identify you as the publisher of these copies. The
front cover must present the full title with all words of the
title equally prominent and visible. You may add other material
on the covers in addition. Copying with changes limited to the
covers, as long as they preserve the title of the Document and
satisfy these conditions, can be treated as verbatim copying in
other respects.
If the required texts for either cover are too voluminous to fit
legibly, you should put the first ones listed (as many as fit
reasonably) on the actual cover, and continue the rest onto
adjacent pages.
If you publish or distribute Opaque copies of the Document
numbering more than 100, you must either include a
machine-readable Transparent copy along with each Opaque copy, or
state in or with each Opaque copy a computer-network location from
which the general network-using public has access to download
using public-standard network protocols a complete Transparent
copy of the Document, free of added material. If you use the
latter option, you must take reasonably prudent steps, when you
begin distribution of Opaque copies in quantity, to ensure that
this Transparent copy will remain thus accessible at the stated
location until at least one year after the last time you
distribute an Opaque copy (directly or through your agents or
retailers) of that edition to the public.
It is requested, but not required, that you contact the authors of
the Document well before redistributing any large number of
copies, to give them a chance to provide you with an updated
version of the Document.
4. MODIFICATIONS
You may copy and distribute a Modified Version of the Document
under the conditions of sections 2 and 3 above, provided that you
release the Modified Version under precisely this License, with
the Modified Version filling the role of the Document, thus
licensing distribution and modification of the Modified Version to
whoever possesses a copy of it. In addition, you must do these
things in the Modified Version:
A. Use in the Title Page (and on the covers, if any) a title
distinct from that of the Document, and from those of
previous versions (which should, if there were any, be listed
in the History section of the Document). You may use the
same title as a previous version if the original publisher of
that version gives permission.
B. List on the Title Page, as authors, one or more persons or
entities responsible for authorship of the modifications in
the Modified Version, together with at least five of the
principal authors of the Document (all of its principal
authors, if it has fewer than five), unless they release you
from this requirement.
C. State on the Title page the name of the publisher of the
Modified Version, as the publisher.
D. Preserve all the copyright notices of the Document.
E. Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.
F. Include, immediately after the copyright notices, a license
notice giving the public permission to use the Modified
Version under the terms of this License, in the form shown in
the Addendum below.
G. Preserve in that license notice the full lists of Invariant
Sections and required Cover Texts given in the Document's
license notice.
H. Include an unaltered copy of this License.
I. Preserve the section Entitled "History", Preserve its Title,
and add to it an item stating at least the title, year, new
authors, and publisher of the Modified Version as given on
the Title Page. If there is no section Entitled "History" in
the Document, create one stating the title, year, authors,
and publisher of the Document as given on its Title Page,
then add an item describing the Modified Version as stated in
the previous sentence.
J. Preserve the network location, if any, given in the Document
for public access to a Transparent copy of the Document, and
likewise the network locations given in the Document for
previous versions it was based on. These may be placed in
the "History" section. You may omit a network location for a
work that was published at least four years before the
Document itself, or if the original publisher of the version
it refers to gives permission.
K. For any section Entitled "Acknowledgements" or "Dedications",
Preserve the Title of the section, and preserve in the
section all the substance and tone of each of the contributor
acknowledgements and/or dedications given therein.
L. Preserve all the Invariant Sections of the Document,
unaltered in their text and in their titles. Section numbers
or the equivalent are not considered part of the section
titles.
M. Delete any section Entitled "Endorsements". Such a section
may not be included in the Modified Version.
N. Do not retitle any existing section to be Entitled
"Endorsements" or to conflict in title with any Invariant
Section.
O. Preserve any Warranty Disclaimers.
If the Modified Version includes new front-matter sections or
appendices that qualify as Secondary Sections and contain no
material copied from the Document, you may at your option
designate some or all of these sections as invariant. To do this,
add their titles to the list of Invariant Sections in the Modified
Version's license notice. These titles must be distinct from any
other section titles.
You may add a section Entitled "Endorsements", provided it contains
nothing but endorsements of your Modified Version by various
parties--for example, statements of peer review or that the text
has been approved by an organization as the authoritative
definition of a standard.
You may add a passage of up to five words as a Front-Cover Text,
and a passage of up to 25 words as a Back-Cover Text, to the end
of the list of Cover Texts in the Modified Version. Only one
passage of Front-Cover Text and one of Back-Cover Text may be
added by (or through arrangements made by) any one entity. If the
Document already includes a cover text for the same cover,
previously added by you or by arrangement made by the same entity
you are acting on behalf of, you may not add another; but you may
replace the old one, on explicit permission from the previous
publisher that added the old one.
The author(s) and publisher(s) of the Document do not by this
License give permission to use their names for publicity for or to
assert or imply endorsement of any Modified Version.
5. COMBINING DOCUMENTS
You may combine the Document with other documents released under
this License, under the terms defined in section 4 above for
modified versions, provided that you include in the combination
all of the Invariant Sections of all of the original documents,
unmodified, and list them all as Invariant Sections of your
combined work in its license notice, and that you preserve all
their Warranty Disclaimers.
The combined work need only contain one copy of this License, and
multiple identical Invariant Sections may be replaced with a single
copy. If there are multiple Invariant Sections with the same name
but different contents, make the title of each such section unique
by adding at the end of it, in parentheses, the name of the
original author or publisher of that section if known, or else a
unique number. Make the same adjustment to the section titles in
the list of Invariant Sections in the license notice of the
combined work.
In the combination, you must combine any sections Entitled
"History" in the various original documents, forming one section
Entitled "History"; likewise combine any sections Entitled
"Acknowledgements", and any sections Entitled "Dedications". You
must delete all sections Entitled "Endorsements."
6. COLLECTIONS OF DOCUMENTS
You may make a collection consisting of the Document and other
documents released under this License, and replace the individual
copies of this License in the various documents with a single copy
that is included in the collection, provided that you follow the
rules of this License for verbatim copying of each of the
documents in all other respects.
You may extract a single document from such a collection, and
distribute it individually under this License, provided you insert
a copy of this License into the extracted document, and follow
this License in all other respects regarding verbatim copying of
that document.
7. AGGREGATION WITH INDEPENDENT WORKS
A compilation of the Document or its derivatives with other
separate and independent documents or works, in or on a volume of
a storage or distribution medium, is called an "aggregate" if the
copyright resulting from the compilation is not used to limit the
legal rights of the compilation's users beyond what the individual
works permit. When the Document is included in an aggregate, this
License does not apply to the other works in the aggregate which
are not themselves derivative works of the Document.
If the Cover Text requirement of section 3 is applicable to these
copies of the Document, then if the Document is less than one half
of the entire aggregate, the Document's Cover Texts may be placed
on covers that bracket the Document within the aggregate, or the
electronic equivalent of covers if the Document is in electronic
form. Otherwise they must appear on printed covers that bracket
the whole aggregate.
8. TRANSLATION
Translation is considered a kind of modification, so you may
distribute translations of the Document under the terms of section
4. Replacing Invariant Sections with translations requires special
permission from their copyright holders, but you may include
translations of some or all Invariant Sections in addition to the
original versions of these Invariant Sections. You may include a
translation of this License, and all the license notices in the
Document, and any Warranty Disclaimers, provided that you also
include the original English version of this License and the
original versions of those notices and disclaimers. In case of a
disagreement between the translation and the original version of
this License or a notice or disclaimer, the original version will
prevail.
If a section in the Document is Entitled "Acknowledgements",
"Dedications", or "History", the requirement (section 4) to
Preserve its Title (section 1) will typically require changing the
actual title.
9. TERMINATION
You may not copy, modify, sublicense, or distribute the Document
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense, or distribute it is void,
and will automatically terminate your rights under this License.
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly
and finally terminates your license, and (b) permanently, if the
copyright holder fails to notify you of the violation by some
reasonable means prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from
that copyright holder, and you cure the violation prior to 30 days
after your receipt of the notice.
Termination of your rights under this section does not terminate
the licenses of parties who have received copies or rights from
you under this License. If your rights have been terminated and
not permanently reinstated, receipt of a copy of some or all of
the same material does not give you any rights to use it.
10. FUTURE REVISIONS OF THIS LICENSE
The Free Software Foundation may publish new, revised versions of
the GNU Free Documentation License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns. See
`http://www.gnu.org/copyleft/'.
Each version of the License is given a distinguishing version
number. If the Document specifies that a particular numbered
version of this License "or any later version" applies to it, you
have the option of following the terms and conditions either of
that specified version or of any later version that has been
published (not as a draft) by the Free Software Foundation. If
the Document does not specify a version number of this License,
you may choose any version ever published (not as a draft) by the
Free Software Foundation. If the Document specifies that a proxy
can decide which future versions of this License can be used, that
proxy's public statement of acceptance of a version permanently
authorizes you to choose that version for the Document.
11. RELICENSING
"Massive Multiauthor Collaboration Site" (or "MMC Site") means any
World Wide Web server that publishes copyrightable works and also
provides prominent facilities for anybody to edit those works. A
public wiki that anybody can edit is an example of such a server.
A "Massive Multiauthor Collaboration" (or "MMC") contained in the
site means any set of copyrightable works thus published on the MMC
site.
"CC-BY-SA" means the Creative Commons Attribution-Share Alike 3.0
license published by Creative Commons Corporation, a not-for-profit
corporation with a principal place of business in San Francisco,
California, as well as future copyleft versions of that license
published by that same organization.
"Incorporate" means to publish or republish a Document, in whole or
in part, as part of another Document.
An MMC is "eligible for relicensing" if it is licensed under this
License, and if all works that were first published under this
License somewhere other than this MMC, and subsequently
incorporated in whole or in part into the MMC, (1) had no cover
texts or invariant sections, and (2) were thus incorporated prior
to November 1, 2008.
The operator of an MMC Site may republish an MMC contained in the
site under CC-BY-SA on the same site at any time before August 1,
2009, provided the MMC is eligible for relicensing.
ADDENDUM: How to use this License for your documents
====================================================
To use this License in a document you have written, include a copy of
the License in the document and put the following copyright and license
notices just after the title page:
Copyright (C) YEAR YOUR NAME.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3
or any later version published by the Free Software Foundation;
with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
Texts. A copy of the license is included in the section entitled ``GNU
Free Documentation License''.
If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
replace the "with...Texts." line with this:
with the Invariant Sections being LIST THEIR TITLES, with
the Front-Cover Texts being LIST, and with the Back-Cover Texts
being LIST.
If you have Invariant Sections without Cover Texts, or some other
combination of the three, merge those two alternatives to suit the
situation.
If your document contains nontrivial examples of program code, we
recommend releasing these examples in parallel under your choice of
free software license, such as the GNU General Public License, to
permit their use in free software.
File: scm-5f2.info, Node: Bibliography, Prev: Copying, Up: Overview
|
1.4 Bibliography
================
[IEEE]
`IEEE Standard 1178-1990. IEEE Standard for the Scheme
Programming Language.' IEEE, New York, 1991.
[R4RS]
William Clinger and Jonathan Rees, Editors. Revised(4) Report on
the Algorithmic Language Scheme. `ACM Lisp Pointers' Volume IV,
Number 3 (July-September 1991), pp. 1-55.
*note Top: (r4rs)Top.
[R5RS]
Richard Kelsey and William Clinger and Jonathan (Rees, editors)
Revised(5) Report on the Algorithmic Language Scheme.
`Higher-Order and Symbolic Computation' Volume 11, Number 1 (1998),
pp. 7-105, and `ACM SIGPLAN Notices' 33(9), September 1998.
*note Top: (r5rs)Top.
[Exrename]
William Clinger Hygienic Macros Through Explicit Renaming `Lisp
Pointers' Volume IV, Number 4 (December 1991), pp 17-23.
[SICP]
Harold Abelson and Gerald Jay Sussman with Julie Sussman.
`Structure and Interpretation of Computer Programs.' MIT Press,
Cambridge, 1985.
[Simply]
Brian Harvey and Matthew Wright. `Simply Scheme: Introducing
Computer Science' MIT Press, 1994 ISBN 0-262-08226-8
[SchemePrimer]
$B8$;tBg(B(Dai Inukai) `$BF~Lg(BScheme'
1999$BG/(B12$B7n=iHG(B ISBN4-87966-954-7
[SLIB]
Todd R. Eigenschink, Dave Love, and Aubrey Jaffer. SLIB, The
Portable Scheme Library. Version 2c8, June 2000.
*note Top: (slib)Top.
[JACAL]
Aubrey Jaffer. JACAL Symbolic Mathematics System. Version 1b0,
Sep 1999.
*note Top: (jacal)Top.
`scm.texi'
`scm.info'
Documentation of `scm' extensions (beyond Scheme standards).
Documentation on the internal representation and how to extend or
include `scm' in other programs.
`Xlibscm.texi'
`Xlibscm.info'
Documentation of the Xlib - SCM Language X Interface.
File: scm-5f2.info, Node: Installing SCM, Next: Operational Features, Prev: Overview, Up: Top
|
2 Installing SCM
****************
SCM runs on a wide variety of platforms. "Distributions" is the |
starting point for all platforms. The process described in "GNU |
configure and make" will work on most Unix and GNU/Linux platforms. If |
it works for you, then you may skip the later sections of "Installing |
SCM". |
|
* Menu:
* Distributions:: Source and Binaries
* GNU configure and make:: For Unix and GNU/Linux
* Building SCM::
* Saving Executable Images:: For Faster Startup
* Installation::
* Troubleshooting and Testing::
File: scm-5f2.info, Node: Distributions, Next: GNU configure and make, Prev: Installing SCM, Up: Installing SCM
|
2.1 Distributions |
================= |
The SCM homepage contains links to precompiled binaries and source |
distributions. |
Downloads and instructions for installing the precompiled binaries are |
at `http://people.csail.mit.edu/jaffer/SCM#QuickStart'. |
|
If there is no precompiled binary for your platform, you may be able to |
build from the source distribution. The rest of these instructions |
deal with building and installing SCM and SLIB from sources. |
|
Download (both SCM and SLIB of) either the last release or current |
development snapshot from |
`http://people.csail.mit.edu/jaffer/SCM#BuildFromSource'. |
|
Unzip both the SCM and SLIB zips. For example, if you are working in |
`/usr/local/src/', this will create directories `/usr/local/src/scm/' |
and `/usr/local/src/slib/'. |
|
File: scm-5f2.info, Node: GNU configure and make, Next: Building SCM, Prev: Distributions, Up: Installing SCM
|
2.2 GNU configure and make |
========================== |
|
`scm/configure' and `slib/configure' are Shell scripts which create the |
files `scm/config.status' and `slib/config.status' on Unix and MinGW |
systems. |
|
The `config.status' files are used (included) by the Makefile to |
control where the packages will be installed by `make install'. With |
GNU shell (bash) and utilities, the following commands should build and |
install SCM and SLIB: |
|
bash$ (cd slib; ./configure --prefix=/usr/local/) |
bash$ (cd scm |
> ./configure --prefix=/usr/local/ |
> make scmlit |
> sudo make all |
> sudo make install) |
bash$ (cd slib; sudo make install) |
|
If the install commands worked, skip to *note Testing::. |
|
If `configure' doesn't work on your system, make `scm/config.status' |
and `slib/config.status' be empty files. |
|
For additional help on using the `configure' script, run |
`./configure --help'. |
|
`make all' will attempt to create a dumped executable (*note Saving |
Executable Images::), which has very small startup latency. If that |
fails, it will try to compile an ordinary `scm' executable. |
|
Note that the compilation output may contain error messages; be |
concerned only if the `make install' transcripts contain errors. |
|
`sudo' runs the command after it as user "root". On recent GNU/Linux |
systems, dumping requires that `make all' be run as user root; hence |
the use of `sudo'. |
|
`make install' requires root privileges if you are installing to |
standard Unix locations as specified to (or defaulted by) |
`./configure'. Note that this is independent of whether you did |
`sudo make all' or `make all'. |
|
* Menu:
|
* Making scmlit::
* Makefile targets::
|
File: scm-5f2.info, Node: Making scmlit, Next: Makefile targets, Prev: GNU configure and make, Up: GNU configure and make
|
2.2.1 Making scmlit |
------------------- |
|
The SCM distribution `Makefile' contains rules for making "scmlit", a |
"bare-bones" version of SCM sufficient for running `build'. `build' is |
a Scheme program used to compile (or create scripts to compile) full |
featured versions of SCM (*note Building SCM::). To create scmlit, run |
`make scmlit' in the `scm/' directory. |
|
Makefiles are not portable to the majority of platforms. If you need |
to compile SCM without `scmlit', there are several ways to proceed: |
* Use the build (http://people.csail.mit.edu/jaffer/buildscm.html)
web page to create custom batch scripts for compiling SCM.
* Use SCM on a different platform to run `build' to create a script
to build SCM;
* Use another implementation of Scheme to run `build' to create a
script to build SCM;
* Create your own script or `Makefile'.
Finding SLIB |
------------ |
If you didn't create scmlit using `make scmlit', then you must create a |
file named `scm/require.scm'. For most installations, |
`scm/require.scm' can just be copied from `scm/requires.scm', which is |
part of the SCM distribution. |
If, when executing `scmlit' or `scm', you get a message like: |
ERROR: "LOAD couldn't find file " "/usr/local/src/scm/require" |
then create a file `require.scm' in the SCM "implementation-vicinity" |
(this is the same directory as where the file `Init5f1.scm' is). |
`require.scm' should have the contents: |
(define (library-vicinity) "/usr/local/lib/slib/")
where the pathname string `/usr/local/lib/slib/' is to be replaced by
the pathname into which you unzipped (or installed) SLIB. |
|
Alternatively, you can set the (shell) environment variable |
`SCHEME_LIBRARY_PATH' to the pathname of the SLIB directory (*note |
SCHEME_LIBRARY_PATH: SCM Variables.). If set, this environment |
variable overrides `scm/require.scm'. |
|
Absolute pathnames are recommended here; if you use a relative |
pathname, SLIB can get confused when the working directory is changed |
(*note chmod: I/O-Extensions.). The way to specify a relative pathname |
is to append it to the implementation-vicinity, which is absolute: |
(define library-vicinity
(let ((lv (string-append (implementation-vicinity) "../slib/")))
(lambda () lv)))
File: scm-5f2.info, Node: Makefile targets, Prev: Making scmlit, Up: GNU configure and make
|
2.2.2 Makefile targets |
---------------------- |
|
Each of the following four `make' targets creates an executable named |
`scm'. Each target takes its build options from a file with an `.opt' |
suffix. If that options file doesn't exist, making that target will |
create the file with the `-F' features: cautious, bignums, arrays, |
inexact, engineering-notation, and dynamic-linking. Once that `.opt' |
file exists, you can edit it to your taste and it will be preserved. |
|
`make scm4' |
Produces a R4RS executable named `scm' lacking hygienic macros |
(but with defmacro). The build options are taken from `scm4.opt'. |
If build or the executable fails, try removing `dynamic-linking' |
from `scm4.opt'. |
|
`make scm5' |
R5RS; like `make scm4' but with `-F macro'. The build options are |
taken from `scm5.opt'. If build or the executable fails, try |
removing `dynamic-linking' from `scm5.opt'. |
|
`make dscm4' |
Produces a R4RS executable named `udscm4', which it starts and |
dumps to a low startup latency executable named `scm'. The build |
options are taken from `udscm4.opt'. |
|
If the build fails, then `build scm4' instead. If the dumped |
executable fails to run, then send me a bug report (and use |
`build scm4' until the problem with dump is corrected). |
|
`make dscm5' |
Like `make dscm4' but with `-F macro'. The build options are |
taken from `udscm5.opt'. |
|
If the build fails, then `build scm5' instead. If the dumped |
executable fails to run, then send me a bug report (and use |
`build scm5' until the problem with dump is corrected). |
|
|
If the above builds fail because of `-F dynamic-linking', then (because |
they can't be dynamically linked) you will likely want to add some |
other features to the build's `.opt' file. See the `-F' build option |
in *note Build Options::. |
|
If dynamic-linking is working, then you will likely want to compile |
most of the modules as "DLL"s. The build options for compiling DLLs |
are in `dlls.opt'. |
|
`make x.so' |
The `Xlib' module; *note SCM Language X Interface: (Xlibscm)Top. |
|
`make myturtle' |
Creates a DLL named `turtlegr.so' which is a simple graphics API. |
|
`make wbscm.so' |
The `wb' module; *note B-tree database implementation: (wb)Top. |
Compiling this requires that wb source be in a peer directory to |
scm. |
|
`make dlls' |
Compiles all the distributed library modules, but not `wbscm.so'. |
Many of the module compiles are recursively invoked in such a way |
that failure of one (which could be due to a system library not |
being installed) doesn't cause the top-level `make dlls' to fail. |
If `make dlls' fails as a whole, it is time to submit a bug report |
(*note Reporting Problems::). |
|
File: scm-5f2.info, Node: Building SCM, Next: Saving Executable Images, Prev: GNU configure and make, Up: Installing SCM
|
2.3 Building SCM
================
The file "build" loads the file "build.scm", which constructs a
relational database of how to compile and link SCM executables.
`build.scm' has information for the platforms which SCM has been ported
to (of which I have been notified). Some of this information is old,
incorrect, or incomplete. Send corrections and additions to |
agj@alum.mit.edu. |
* Menu:
* Invoking Build::
* Build Options:: build --help
* Compiling and Linking Custom Files::
File: scm-5f2.info, Node: Invoking Build, Next: Build Options, Prev: Building SCM, Up: Building SCM
|
2.3.1 Invoking Build
--------------------
This section teaches how to use `build', a Scheme program for creating |
compilation scripts to produce SCM executables and library modules. |
The options accepted by `build' are documented in *note Build Options::. |
|
Use the _any_ method if you encounter problems with the other two |
methods (MS-DOS, Unix). |
MS-DOS
From the SCM source directory, type `build' followed by up to 9
command line arguments.
Unix |
From the SCM source directory, type `./build' followed by command
line arguments.
_any_ |
From the SCM source directory, start `scm' or `scmlit' and type
`(load "build")'. Alternatively, start `scm' or `scmlit' with the
command line argument `-ilbuild'. This method will also work for |
MS-DOS and Unix. |
|
After loading various SLIB modules, the program will print: |
|
type (b "build ") to build |
type (b*) to enter build command loop |
|
The `b*' procedure enters into a "build shell" where you can enter |
commands (with or without the `build'). Blank lines are ignored. |
To create a build script with all defaults type `build'. |
|
If the build-shell encouters an error, you can reenter the |
build-shell by typing `(b*)'. To exit scm type `(quit)'. |
|
|
Here is a transcript of an interactive (b*) build-shell. |
|
bash$ scmlit |
SCM version 5e7, Copyright (C) 1990-2006 Free Software Foundation. |
SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'. |
This is free software, and you are welcome to redistribute it |
under certain conditions; type `(terms)' for details. |
> (load "build") |
;loading build |
; loading /home/jaffer/slib/getparam |
; loading /home/jaffer/slib/coerce |
... |
; done loading build.scm |
type (b "build ") to build |
type (b*) to enter build command loop |
;done loading build |
# |
> (b*) |
;loading /home/jaffer/slib/comparse |
;done loading /home/jaffer/slib/comparse.scm |
build> -t exe |
#! /bin/sh |
# unix (linux) script created by SLIB/batch Wed Oct 26 17:14:23 2011 |
# [-p linux] |
# ================ Write file with C defines |
rm -f scmflags.h |
echo '#define IMPLINIT "Init5e7.scm"'>>scmflags.h |
echo '#define BIGNUMS'>>scmflags.h |
echo '#define FLOATS'>>scmflags.h |
echo '#define ARRAYS'>>scmflags.h |
# ================ Compile C source files |
gcc -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
# ================ Link C object files |
gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc
"scm" |
build> -t exe -w myscript.sh |
"scm" |
build> (quit) |
No compilation was done. The `-t exe' command shows the compile |
script. The `-t exe -w myscript.sh' line creates a file `myscript.sh' |
containing the compile script. To actually compile and link it, type |
`./myscript.sh'. |
Invoking build without the `-F' option will build or create a shell
script with the `arrays', `inexact', and `bignums' options as defaults.
Invoking `build' with `-F lit -o scmlit' will make a script for |
compiling `scmlit'. |
bash$ ./build
-|
#! /bin/sh
# unix (linux) script created by SLIB/batch
# ================ Write file with C defines
rm -f scmflags.h
echo '#define IMPLINIT "Init5f1.scm"'>>scmflags.h |
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
# ================ Compile C source files
gcc -O2 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
# ================ Link C object files
gcc -rdynamic -o scm continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o -lm -lc
To cross compile for another platform, invoke build with the `-p' or
`--platform=' option. This will create a script for the platform named
in the `-p' or `--platform=' option.
bash$ ./build -o scmlit -p darwin -F lit
-|
#! /bin/sh
# unix (darwin) script created by SLIB/batch
# ================ Write file with C defines
rm -f scmflags.h
echo '#define IMPLINIT "Init5f1.scm"'>>scmflags.h |
# ================ Compile C source files
cc -O3 -c continue.c scm.c scmmain.c findexec.c script.c time.c repl.c scl.c eval.c sys.c subr.c debug.c unif.c rope.c
# ================ Link C object files
mv -f scmlit scmlit~
cc -o scmlit continue.o scm.o scmmain.o findexec.o script.o time.o repl.o scl.o eval.o sys.o subr.o debug.o unif.o rope.o
File: scm-5f2.info, Node: Build Options, Next: Compiling and Linking Custom Files, Prev: Invoking Build, Up: Building SCM
|
2.3.2 Build Options
-------------------
The options to "build" specify what, where, and how to build a SCM
program or dynamically linked module. These options are unrelated to
the SCM command line options.
-- Build Option: -p PLATFORM-NAME
-- Build Option: --platform=PLATFORM-NAME
specifies that the compilation should be for a
computer/operating-system combination called PLATFORM-NAME.
_Note_ The case of PLATFORM-NAME is distinguised. The current
PLATFORM-NAMEs are all lower-case.
The platforms defined by table "platform" in `build.scm' are:
Table: platform
name processor operating-system compiler
#f processor-family operating-system #f
symbol processor-family operating-system symbol
symbol symbol symbol symbol
================= ================= ================= =================
*unknown* *unknown* unix cc
acorn-unixlib acorn *unknown* cc
aix powerpc aix cc
alpha-elf alpha unix cc
alpha-linux alpha linux gcc
amiga-aztec m68000 amiga cc
amiga-dice-c m68000 amiga dcc
amiga-gcc m68000 amiga gcc
amiga-sas m68000 amiga lc
atari-st-gcc m68000 atari-st gcc
atari-st-turbo-c m68000 atari-st tcc
borland-c i8086 ms-dos bcc
darwin powerpc unix cc
djgpp i386 ms-dos gcc
freebsd *unknown* unix cc
gcc *unknown* unix gcc
gnu-win32 i386 unix gcc
highc i386 ms-dos hc386
hp-ux hp-risc hp-ux cc
irix mips irix gcc
linux *unknown* linux gcc
linux-aout i386 linux gcc
linux-ia64 ia64 linux gcc
microsoft-c i8086 ms-dos cl
microsoft-c-nt i386 ms-dos cl
microsoft-quick-c i8086 ms-dos qcl
ms-dos i8086 ms-dos cc
netbsd *unknown* unix gcc
openbsd *unknown* unix gcc
os/2-cset i386 os/2 icc
os/2-emx i386 os/2 gcc
osf1 alpha unix cc
plan9-8 i386 plan9 8c
sunos sparc sunos cc
svr4 *unknown* unix cc
svr4-gcc-sun-ld sparc sunos gcc
turbo-c i8086 ms-dos tcc
unicos cray unicos cc
unix *unknown* unix cc
vms vax vms cc
vms-gcc vax vms gcc
watcom-9.0 i386 ms-dos wcc386p
-- Build Option: -f PATHNAME
specifies that the build options contained in PATHNAME be spliced
into the argument list at this point. The use of option files can
separate functional features from platform-specific ones.
The `Makefile' calls out builds with the options in `.opt' files:
`dlls.opt'
Options for Makefile targets dlls, myturtle, and x.so. |
`gdb.opt'
Options for udgdbscm and gdbscm.
`libscm.opt'
Options for libscm.a.
`pg.opt'
Options for pgscm, which instruments C functions.
`udscm4.opt'
Options for targets udscm4 and dscm4 (scm).
`udscm5.opt'
Options for targets udscm5 and dscm5 (scm).
The Makefile creates options files it depends on only if they do
not already exist.
-- Build Option: -o FILENAME
-- Build Option: --outname=FILENAME
specifies that the compilation should produce an executable or
object name of FILENAME. The default is `scm'. Executable
suffixes will be added if neccessary, e.g. `scm' => `scm.exe'.
-- Build Option: -l LIBNAME ...
-- Build Option: --libraries=LIBNAME
specifies that the LIBNAME should be linked with the executable
produced. If compile flags or include directories (`-I') are
needed, they are automatically supplied for compilations. The `c'
library is always included. SCM "features" specify any libraries
they need; so you shouldn't need this option often.
-- Build Option: -D DEFINITION ...
-- Build Option: --defines=DEFINITION
specifies that the DEFINITION should be made in any C source
compilations. If compile flags or include directories (`-I') are
needed, they are automatically supplied for compilations. SCM
"features" specify any flags they need; so you shouldn't need this
option often.
-- Build Option: --compiler-options=FLAG
specifies that that FLAG will be put on compiler command-lines.
-- Build Option: --linker-options=FLAG
specifies that that FLAG will be put on linker command-lines.
-- Build Option: -s PATHNAME
-- Build Option: --scheme-initial=PATHNAME
specifies that PATHNAME should be the default location of the SCM
initialization file `Init5f1.scm'. SCM tries several likely |
locations before resorting to PATHNAME (*note File-System
Habitat::). If not specified, the current directory (where build
is building) is used.
-- Build Option: -c PATHNAME ...
-- Build Option: --c-source-files=PATHNAME
specifies that the C source files PATHNAME ... are to be compiled.
-- Build Option: -j PATHNAME ...
-- Build Option: --object-files=PATHNAME
specifies that the object files PATHNAME ... are to be linked.
-- Build Option: -i CALL ...
-- Build Option: --initialization=CALL
specifies that the C functions CALL ... are to be invoked during
initialization.
-- Build Option: -t BUILD-WHAT
-- Build Option: --type=BUILD-WHAT
specifies in general terms what sort of thing to build. The
choices are:
`exe'
executable program.
`lib'
library module.
`dlls'
archived dynamically linked library object files.
`dll'
dynamically linked library object file.
The default is to build an executable.
-- Build Option: -h BATCH-SYNTAX
-- Build Option: -batch-dialect=BATCH-SYNTAX
specifies how to build. The default is to create a batch file for
the host system. The SLIB file `batch.scm' knows how to create
batch files for:
* unix
* dos
* vms
* amigaos (was amigados)
* system
This option executes the compilation and linking commands
through the use of the `system' procedure.
* *unknown*
This option outputs Scheme code.
-- Build Option: -w BATCH-FILENAME
-- Build Option: -script-name=BATCH-FILENAME
specifies where to write the build script. The default is to
display it on `(current-output-port)'.
-- Build Option: -F FEATURE ...
-- Build Option: --features=FEATURE
specifies to build the given features into the executable. The
defined features are:
"array"
Alias for ARRAYS
"array-for-each"
array-map! and array-for-each (arrays must also be featured).
"arrays"
Use if you want arrays, uniform-arrays and uniform-vectors.
"bignums"
Large precision integers.
"byte"
Treating strings as byte-vectors.
"byte-number"
Byte/number conversions
"careful-interrupt-masking"
Define this for extra checking of interrupt masking and some
simple checks for proper use of malloc and free. This is for
debugging C code in `sys.c', `eval.c', `repl.c' and makes the
interpreter several times slower than usual.
"cautious"
Normally, the number of arguments arguments to interpreted
closures (from LAMBDA) are checked if the function part of a
form is not a symbol or only the first time the form is
executed if the function part is a symbol. defining
`reckless' disables any checking. If you want to have SCM
always check the number of arguments to interpreted closures
define feature `cautious'.
"cheap-continuations"
If you only need straight stack continuations, executables
compile with this feature will run faster and use less
storage than not having it. Machines with unusual stacks
_need_ this. Also, if you incorporate new C code into scm
which uses VMS system services or library routines (which
need to unwind the stack in an ordrly manner) you may need to
use this feature.
"compiled-closure"
Use if you want to use compiled closures.
"curses"
For the "curses" screen management package.
"debug"
Turns on the features `cautious' and
`careful-interrupt-masking'; uses `-g' flags for debugging
SCM source code.
"differ"
Sequence comparison
"dont-memoize-locals"
SCM normally converts references to local variables to ILOCs,
which make programs run faster. If SCM is badly broken, try
using this option to disable the MEMOIZE_LOCALS feature.
"dump"
Convert a running scheme program into an executable file.
"dynamic-linking"
Be able to load compiled files while running.
"edit-line"
interface to the editline or GNU readline library.
"engineering-notation"
Use if you want floats to display in engineering notation
(exponents always multiples of 3) instead of scientific
notation.
"generalized-c-arguments"
`make_gsubr' for arbitrary (< 11) arguments to C functions.
"i/o-extensions"
Commonly available I/O extensions: "exec", line I/O, file
positioning, file delete and rename, and directory functions.
"inexact"
Use if you want floating point numbers.
"lit"
Lightweight - no features
"macro"
C level support for hygienic and referentially transparent
macros (syntax-rules macros).
"mysql"
Client connections to the mysql databases.
"no-heap-shrink"
Use if you want segments of unused heap to not be freed up
after garbage collection. This may increase time in GC for
*very* large working sets.
"none"
No features
"posix"
Posix functions available on all "Unix-like" systems. fork
and process functions, user and group IDs, file permissions,
and "link".
"reckless"
If your scheme code runs without any errors you can disable
almost all error checking by compiling all files with
`reckless'.
"record"
The Record package provides a facility for user to define
their own record data types. See SLIB for documentation.
"regex"
String regular expression matching.
"rev2-procedures"
These procedures were specified in the `Revised^2 Report on
Scheme' but not in `R4RS'.
"sicp"
Use if you want to run code from:
Harold Abelson and Gerald Jay Sussman with Julie Sussman.
`Structure and Interpretation of Computer Programs.' The MIT
Press, Cambridge, Massachusetts, USA, 1985.
Differences from R5RS are:
* (eq? '() '#f)
* (define a 25) returns the symbol a.
* (set! a 36) returns 36.
"single-precision-only"
Use if you want all inexact real numbers to be single
precision. This only has an effect if SINGLES is also
defined (which is the default). This does not affect complex
numbers.
"socket"
BSD "socket" interface. Socket addr functions require
inexacts or bignums for 32-bit precision.
"tick-interrupts"
Use if you want the ticks and ticks-interrupt functions.
"turtlegr"
"Turtle" graphics calls for both Borland-C and X11 from
sjm@ee.tut.fi.
"unix"
Those unix features which have not made it into the Posix
specs: nice, acct, lstat, readlink, symlink, mknod and sync.
"wb"
WB database with relational wrapper.
"wb-no-threads" |
no-comment |
|
"windows"
Microsoft Windows executable.
"x"
Alias for Xlib feature.
"xlib"
Interface to Xlib graphics routines.
File: scm-5f2.info, Node: Compiling and Linking Custom Files, Prev: Build Options, Up: Building SCM
|
2.3.3 Compiling and Linking Custom Files
----------------------------------------
A correspondent asks:
How can we link in our own c files to the SCM interpreter so that
we can add our own functionality? (e.g. we have a bunch of tcp
functions we want access to). Would this involve changing
build.scm or the Makefile or both?
(*note Changing Scm:: has instructions describing the C code format). Suppose
a C file "foo.c" has functions you wish to add to SCM. To compile and
link your file at compile time, use the `-c' and `-i' options to build:
bash$ ./build -c foo.c -i init_foo
-|
#! /bin/sh
rm -f scmflags.h
echo '#define IMPLINIT "/home/jaffer/scm/Init5f1.scm"'>>scmflags.h |
echo '#define COMPILED_INITS init_foo();'>>scmflags.h
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
gcc -O2 -c continue.c scm.c findexec.c script.c time.c repl.c scl.c \
eval.c sys.c subr.c unif.c rope.c foo.c
gcc -rdynamic -o scm continue.o scm.o findexec.o script.o time.o \
repl.o scl.o eval.o sys.o subr.o unif.o rope.o foo.o -lm -lc
To make a dynamically loadable object file use the `-t dll' option:
bash$ ./build -t dll -c foo.c
-|
#! /bin/sh
rm -f scmflags.h
echo '#define IMPLINIT "/home/jaffer/scm/Init5f1.scm"'>>scmflags.h |
echo '#define BIGNUMS'>>scmflags.h
echo '#define FLOATS'>>scmflags.h
echo '#define ARRAYS'>>scmflags.h
echo '#define DLL'>>scmflags.h
gcc -O2 -fpic -c foo.c
gcc -shared -o foo.so foo.o -lm -lc
Once `foo.c' compiles correctly (and your SCM build supports
dynamic-loading), you can load the compiled file with the Scheme command
`(load "./foo.so")'. See *note Configure Module Catalog:: for how to
add a compiled dll file to SLIB's catalog.
File: scm-5f2.info, Node: Saving Executable Images, Next: Installation, Prev: Building SCM, Up: Installing SCM
|
2.4 Saving Executable Images |
============================
|
In SCM, the ability to save running program images is called "dump"
(*note Dump::). In order to make `dump' available to SCM, build with
feature `dump'. `dump'ed executables are compatible with dynamic
linking.
Most of the code for "dump" is taken from `emacs-19.34/src/unex*.c'.
No modifications to the emacs source code were required to use
`unexelf.c'. Dump has not been ported to all platforms. If `unexec.c'
or `unexelf.c' don't work for you, try using the appropriate `unex*.c'
file from emacs.
The `dscm4' and `dscm5' targets in the SCM `Makefile' save images from
`udscm4' and `udscm5' executables respectively.
"Address space layout randomization" interferes with `dump'. Here are |
the fixes for various operating-systems: |
Fedora-Core-1
Remove the `#' from the line `#SETARCH = setarch i386' in the
`Makefile'.
Fedora-Core-3
`http://jamesthornton.com/writing/emacs-compile.html' [For FC3] |
combreloc has become the default for recent GNU ld, which breaks |
the unexec/undump on all versions of both Emacs and XEmacs... |
Override by adding the following to `udscm5.opt':
`--linker-options="-z nocombreloc"'
Linux Kernels later than 2.6.11 |
`http://www.opensubscriber.com/message/emacs-devel@gnu.org/1007118.html'
mentions the "exec-shield" feature. Kernels later than 2.6.11
must do (as root):
echo 0 > /proc/sys/kernel/randomize_va_space
before dumping. `Makefile' has this `randomize_va_space' stuffing
scripted for targets `dscm4' and `dscm5'. You must either set
`randomize_va_space' to 0 or run as root to dump.
OS-X 10.6 |
`http://developer.apple.com/library/mac/#documentation/Darwin/Reference/Manpages/man1/dyld.1.html'
The dynamic linker uses the following environment variables. They |
affect any program that uses the dynamic linker. |
|
DYLD_NO_PIE |
|
Causes dyld to not randomize the load addresses of images in a |
process where the main executable was built position independent. |
This can be helpful when trying to reproduce and debug a problem |
in a PIE. |
|
File: scm-5f2.info, Node: Installation, Next: Troubleshooting and Testing, Prev: Saving Executable Images, Up: Installing SCM
|
2.5 Installation |
================ |
Once `scmlit', `scm', and `dlls' have been built, these commands will |
install them to the locations specified when you ran `./configure': |
bash$ (cd scm; make install) |
bash$ (cd slib; make install) |
Note that installation to system directories (like `/usr/bin/') will |
require that those commands be run as root: |
bash$ (cd scm; sudo make install) |
bash$ (cd slib; sudo make install) |
File: scm-5f2.info, Node: Troubleshooting and Testing, Prev: Installation, Up: Installing SCM
|
2.6 Troubleshooting and Testing |
=============================== |
|
* Menu:
|
* Problems Compiling::
* Problems Linking::
* Testing::
* Problems Starting::
* Problems Running::
* Reporting Problems::
|
File: scm-5f2.info, Node: Problems Compiling, Next: Problems Linking, Prev: Troubleshooting and Testing, Up: Troubleshooting and Testing
|
2.6.1 Problems Compiling |
------------------------ |
FILE PROBLEM / MESSAGE HOW TO FIX
*.c include file not found. Correct the status of
STDC_HEADERS in scmfig.h.
fix #include statement or add
#define for system type to
scmfig.h.
*.c Function should return a value. Ignore.
Parameter is never used.
Condition is always false.
Unreachable code in function.
scm.c assignment between incompatible Change SIGRETTYPE in scm.c.
types.
time.c CLK_TCK redefined. incompatablility between
and .
Remove STDC_HEADERS in scmfig.h.
Edit to remove
incompatability.
subr.c Possibly incorrect assignment Ignore.
in function lgcd.
sys.c statement not reached. Ignore.
constant in conditional
expression.
sys.c undeclared, outside of #undef STDC_HEADERS in scmfig.h.
functions.
scl.c syntax error. #define SYSTNAME to your system
type in scl.c (softtype).
File: scm-5f2.info, Node: Problems Linking, Next: Testing, Prev: Problems Compiling, Up: Troubleshooting and Testing
|
2.6.2 Problems Linking |
---------------------- |
PROBLEM HOW TO FIX
_sin etc. missing. Uncomment LIBS in makefile.
File: scm-5f2.info, Node: Testing, Next: Problems Starting, Prev: Problems Linking, Up: Troubleshooting and Testing
|
2.6.3 Testing |
------------- |
|
Loading `r4rstest.scm' in the distribution will run an [R4RS] |
conformance test on `scm'. |
|
> (load "r4rstest.scm") |
-| |
;loading r4rstest.scm |
SECTION(2 1) |
SECTION(3 4) |
# |
# |
# |
# |
... |
|
Loading `pi.scm' in the distribution will enable you to compute digits |
of pi. |
|
> (load "pi.scm") |
;loading pi.scm |
;done loading pi.scm |
# |
> (pi 100 5) |
00003 14159 26535 89793 23846 26433 83279 50288 41971 69399 |
37510 58209 74944 59230 78164 06286 20899 86280 34825 34211 |
70679 |
;Evaluation took 550 ms (60 in gc) 36976 cells work, 1548.B other |
# |
|
Performance |
----------- |
|
Loading `bench.scm' will compute and display performance statistics of |
SCM running `pi.scm'. `make bench' or `make benchlit' appends the |
performance report to the file `BenchLog', facilitating tracking |
effects of changes to SCM on performance. |
|
File: scm-5f2.info, Node: Problems Starting, Next: Problems Running, Prev: Testing, Up: Troubleshooting and Testing
|
2.6.4 Problems Starting |
----------------------- |
PROBLEM HOW TO FIX
/bin/bash: scm: program not found Is `scm' in a `$PATH' directory? |
/bin/bash: /usr/local/bin/scm: `chmod +x /usr/local/bin/scm' |
Permission denied |
Opening message and then machine Change memory model option to C
crashes. compiler (or makefile).
Make sure sizet definition is
correct in scmfig.h.
Reduce the size of HEAP_SEG_SIZE in
setjump.h.
Input hangs. #define NOSETBUF
ERROR: heap: need larger initial. Increase initial heap allocation
using -a or INIT_HEAP_SIZE.
ERROR: Could not allocate. Check sizet definition.
Use 32 bit compiler mode.
Don't try to run as subproccess.
remove in scmfig.h and Do so and recompile files.
recompile scm.
add in scmfig.h and
recompile scm.
ERROR: Init5f1.scm not found. Assign correct IMPLINIT in makefile |
or scmfig.h.
Define environment variable
SCM_INIT_PATH to be the full
pathname of Init5f1.scm. |
WARNING: require.scm not found. Define environment variable
SCHEME_LIBRARY_PATH to be the full
pathname of the scheme library
[SLIB].
Change library-vicinity in
Init5f1.scm to point to library or |
remove.
Make sure the value of
(library-vicinity) has a trailing
file separator (like / or \).
File: scm-5f2.info, Node: Problems Running, Next: Reporting Problems, Prev: Problems Starting, Up: Troubleshooting and Testing
|
2.6.5 Problems Running |
---------------------- |
PROBLEM HOW TO FIX
Runs some and then machine crashes. See above under machine crashes.
Runs some and then ERROR: ... Remove optimization option to C
(after a GC has happened). compiler and recompile.
#define SHORT_ALIGN in `scmfig.h'.
Some symbol names print incorrectly. Change memory model option to C
compiler (or makefile).
Check that HEAP_SEG_SIZE fits
within sizet.
Increase size of HEAP_SEG_SIZE (or
INIT_HEAP_SIZE if it is smaller
than HEAP_SEG_SIZE).
ERROR: Rogue pointer in Heap. See above under machine crashes.
Newlines don't appear correctly in Check file mode (define OPEN_... in
output files. `Init5f1.scm'). |
Spaces or control characters appear Check character defines in
in symbol names. `scmfig.h'.
Negative numbers turn positive. Check SRS in `scmfig.h'.
;ERROR: bignum: numerical overflow Increase NUMDIGS_MAX in `scmfig.h'
and recompile.
VMS: Couldn't unwind stack. #define CHEAP_CONTINUATIONS in
`scmfig.h'.
VAX: botched longjmp.
|
File: scm-5f2.info, Node: Reporting Problems, Prev: Problems Running, Up: Troubleshooting and Testing
|
2.6.6 Reporting Problems |
------------------------ |
Reported problems and solutions are grouped under Compiling, Linking,
Running, and Testing. If you don't find your problem listed there, you
can send a bug report to `agj@alum.mit.edu' or `scm-discuss@gnu.org'. |
The bug report should include: |
1. The version of SCM (printed when SCM is invoked with no arguments).
2. The type of computer you are using.
3. The name and version of your computer's operating system.
4. The values of the environment variables `SCM_INIT_PATH' and
`SCHEME_LIBRARY_PATH'.
5. The name and version of your C compiler.
6. If you are using an executable from a distribution, the name,
vendor, and date of that distribution. In this case,
corresponding with the vendor is recommended.
File: scm-5f2.info, Node: Operational Features, Next: The Language, Prev: Installing SCM, Up: Top
|
3 Operational Features
**********************
* Menu:
* Invoking SCM::
* SCM Options::
* Invocation Examples::
* SCM Variables::
* SCM Session::
* Editing Scheme Code::
* Debugging Scheme Code::
* Debugging Continuations::
* Errors::
* Memoized Expressions::
* Internal State::
* Scripting::
File: scm-5f2.info, Node: Invoking SCM, Next: SCM Options, Prev: Operational Features, Up: Operational Features
|
3.1 Invoking SCM
================
scm [-a kbytes] [-muvbiq] [-version] [-help]
[[-]-no-init-file] [--no-symbol-case-fold]
[-p int] [-r feature] [-h feature]
[-d filename] [-f filename] [-l filename]
[-c expression] [-e expression] [-o dumpname]
[-- | - | -s] [filename] [arguments ...]
Upon startup `scm' loads the file specified by by the environment
variable SCM_INIT_PATH.
If SCM_INIT_PATH is not defined or if the file it names is not present,
`scm' tries to find the directory containing the executable file. If
it is able to locate the executable, `scm' looks for the initialization
file (usually `Init5f1.scm') in platform-dependent directories relative |
to this directory. See *note File-System Habitat:: for a blow-by-blow
description.
As a last resort (if initialization file cannot be located), the C
compile parameter IMPLINIT (defined in the makefile or `scmfig.h') is
tried.
Unless the option `-no-init-file' or `--no-init-file' occurs in the
command line, or if `scm' is being invoked as a script, `Init5f1.scm' |
checks to see if there is file `ScmInit.scm' in the path specified by
the environment variable HOME (or in the current directory if HOME is
undefined). If it finds such a file, then it is loaded.
`Init5f1.scm' then looks for command input from one of three sources: |
From an option on the command line, from a file named on the command
line, or from standard input.
This explanation applies to SCMLIT or other builds of SCM.
Scheme-code files can also invoke SCM and its variants. *Note #!:
Lexical Conventions.
File: scm-5f2.info, Node: SCM Options, Next: Invocation Examples, Prev: Invoking SCM, Up: Operational Features
|
3.2 Options
===========
The options are processed in the order specified on the command line.
-- Command Option: -a k
specifies that `scm' should allocate an initial heapsize of K
kilobytes. This option, if present, must be the first on the
command line. If not specified, the default is `INIT_HEAP_SIZE'
in source file `setjump.h' which the distribution sets at
`25000*sizeof(cell)'.
-- Command Option: -no-init-file
-- Command Option: --no-init-file
Inhibits the loading of `ScmInit.scm' as described above.
-- Command Option: -no-symbol-case-fold
Symbol (and identifier) names will be case sensitive.
-- Command Option: --help
prints usage information and URI; then exit.
-- Command Option: --version
prints version information and exit.
-- Command Option: -r feature
requires FEATURE. This will load a file from [SLIB] if that
FEATURE is not already provided. If FEATURE is 2, 2rs, or r2rs;
3, 3rs, or r3rs; 4, 4rs, or r4rs; 5, 5rs, or r5rs; `scm' will
require the features neccessary to support [R2RS]; [R3RS]; [R4RS];
or [R5RS], respectively.
-- Command Option: -h feature
provides FEATURE.
-- Command Option: -l filename
-- Command Option: -f filename
loads FILENAME. `Scm' will load the first (unoptioned) file named
on the command line if no `-c', `-e', `-f', `-l', or `-s' option
preceeds it.
-- Command Option: -d filename
Loads SLIB `databases' feature and opens FILENAME as a database.
-- Command Option: -e expression
-- Command Option: -c expression
specifies that the scheme expression EXPRESSION is to be
evaluated. These options are inspired by `perl' and `sh'
respectively. On Amiga systems the entire option and argument
need to be enclosed in quotes. For instance `"-e(newline)"'.
-- Command Option: -o dumpname
saves the current SCM session as the executable program `dumpname'.
This option works only in SCM builds supporting `dump' (*note
Dump::).
If options appear on the command line after `-o DUMPNAME', then
the saved session will continue with processing those options when
it is invoked. Otherwise the (new) command line is processed as
usual when the saved image is invoked.
-- Command Option: -p level
sets the prolixity (verboseness) to LEVEL. This is the same as
the `scm' command (verobse LEVEL).
-- Command Option: -v
(verbose mode) specifies that `scm' will print prompts, evaluation
times, notice of loading files, and garbage collection statistics.
This is the same as `-p3'.
-- Command Option: -q
(quiet mode) specifies that `scm' will print no extra information.
This is the same as `-p0'.
-- Command Option: -m
specifies that subsequent loads, evaluations, and user
interactions will be with syntax-rules macro capability. To use a
specific syntax-rules macro implementation from [SLIB] (instead of
[SLIB]'s default) put `-r' MACROPACKAGE before `-m' on the command
line.
-- Command Option: -u
specifies that subsequent loads, evaluations, and user
interactions will be without syntax-rules macro capability.
Syntax-rules macro capability can be restored by a subsequent `-m'
on the command line or from Scheme code.
-- Command Option: -i
specifies that `scm' should run interactively. That means that
`scm' will not terminate until the `(quit)' or `(exit)' command is
given, even if there are errors. It also sets the prolixity level
to 2 if it is less than 2. This will print prompts, evaluation
times, and notice of loading files. The prolixity level can be
set by subsequent options. If `scm' is started from a tty, it
will assume that it should be interactive unless given a
subsequent `-b' option.
-- Command Option: -b
specifies that `scm' should run non-interactively. That means that
`scm' will terminate after processing the command line or if there
are errors.
-- Command Option: -s
specifies, by analogy with `sh', that `scm' should run
interactively and that further options are to be treated as program
aguments.
-- Command Option: -
-- Command Option: --
specifies that further options are to be treated as program
aguments.
File: scm-5f2.info, Node: Invocation Examples, Next: SCM Variables, Prev: SCM Options, Up: Operational Features
|
3.3 Invocation Examples
=======================
`% scm foo.scm'
Loads and executes the contents of `foo.scm' and then enters
interactive session.
`% scm -f foo.scm arg1 arg2 arg3'
Parameters `arg1', `arg2', and `arg3' are stored in the global
list `*argv*'; Loads and executes the contents of `foo.scm' and
exits.
`% scm -s foo.scm arg1 arg2'
Sets *argv* to `("foo.scm" "arg1" "arg2")' and enters interactive
session.
`% scm -e `(write (list-ref *argv* *optind*))' bar'
Prints `"bar"'.
`% scm -rpretty-print -r format -i'
Loads `pretty-print' and `format' and enters interactive session.
`% scm -r5'
Loads `dynamic-wind', `values', and syntax-rules macros and enters
interactive (with macros) session.
`% scm -r5 -r4'
Like above but `rev4-optional-procedures' are also loaded.
File: scm-5f2.info, Node: SCM Variables, Next: SCM Session, Prev: Invocation Examples, Up: Operational Features
|
3.4 Environment Variables
=========================
-- Environment Variable: SCM_INIT_PATH
is the pathname where `scm' will look for its initialization code.
The default is the file `Init5f1.scm' in the source directory. |
-- Environment Variable: SCHEME_LIBRARY_PATH
is the [SLIB] Scheme library directory.
-- Environment Variable: HOME
is the directory where `Init5f1.scm' will look for the user |
initialization file `ScmInit.scm'.
-- Environment Variable: EDITOR
is the name of the program which `ed' will call. If EDITOR is not
defined, the default is `ed'.
3.5 Scheme Variables
====================
-- Variable: *argv*
contains the list of arguments to the program. `*argv*' can change
during argument processing. This list is suitable for use as an
argument to [SLIB] `getopt'.
-- Variable: *syntax-rules*
controls whether loading and interaction support syntax-rules
macros. Define this in `ScmInit.scm' or files specified on the
command line. This can be overridden by subsequent `-m' and `-u'
options.
-- Variable: *interactive*
controls interactivity as explained for the `-i' and `-b' options.
Define this in `ScmInit.scm' or files specified on the command
line. This can be overridden by subsequent `-i' and `-b' options.
File: scm-5f2.info, Node: SCM Session, Next: Editing Scheme Code, Prev: SCM Variables, Up: Operational Features
|
3.6 SCM Session
===============
* Options, file loading and features can be specified from the
command line. *Note System interface: (scm)System interface.
*Note Require: (slib)Require.
* Typing the end-of-file character at the top level session (while
SCM is not waiting for parenthesis closure) causes SCM to exit.
* Typing the interrupt character aborts evaluation of the current
form and resumes the top level read-eval-print loop.
-- Function: quit
-- Function: quit n
-- Function: exit
-- Function: exit n
Aliases for `exit' (*note exit: (slib)System.). On many systems,
SCM can also tail-call another program. *Note execp:
I/O-Extensions.
-- Callback procedure: boot-tail dumped?
`boot-tail' is called by `scm_top_level' just before entering
interactive top-level. If `boot-tail' calls `quit', then
interactive top-level is not entered.
-- Function: program-arguments
Returns a list of strings of the arguments scm was called with.
-- Function: getlogin
Returns the (login) name of the user logged in on the controlling
terminal of the process, or #f if this information cannot be
determined.
For documentation of the procedures `getenv' and `system' *Note System
Interface: (slib)System Interface.
SCM extends `getenv' as suggested by draft SRFI-98:
-- Function: getenv name
Looks up NAME, a string, in the program environment. If NAME is
found a string of its value is returned. Otherwise, `#f' is
returned.
-- Function: getenv
Returns names and values of all the environment variables as an
association-list.
(getenv) =>
(("PATH" . "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin")
("USERNAME" . "taro"))
-- Function: vms-debug
If SCM is compiled under VMS this `vms-debug' will invoke the VMS
debugger.
File: scm-5f2.info, Node: Editing Scheme Code, Next: Debugging Scheme Code, Prev: SCM Session, Up: Operational Features
|
3.7 Editing Scheme Code
=======================
-- Function: ed arg1 ...
The value of the environment variable `EDITOR' (or just `ed' if it
isn't defined) is invoked as a command with arguments ARG1 ....
-- Function: ed filename
If SCM is compiled under VMS `ed' will invoke the editor with a
single the single argument FILENAME.
Gnu Emacs:
Editing of Scheme code is supported by emacs. Buffers holding
files ending in .scm are automatically put into scheme-mode.
If your Emacs can run a process in a buffer you can use the Emacs
command `M-x run-scheme' with SCM. Otherwise, use the emacs
command `M-x suspend-emacs'; or see "other systems" below.
Epsilon (MS-DOS):
There is lisp (and scheme) mode available by use of the package
`LISP.E'. It offers several different indentation formats. With
this package, buffers holding files ending in `.L', `.LSP', `.S',
and `.SCM' (my modification) are automatically put into lisp-mode.
It is possible to run a process in a buffer under Epsilon. With
Epsilon 5.0 the command line options `-e512 -m0' are neccessary to
manage RAM properly. It has been reported that when compiling SCM
with Turbo C, you need to `#define NOSETBUF' for proper operation
in a process buffer with Epsilon 5.0.
One can also call out to an editor from SCM if RAM is at a
premium; See "under other systems" below.
other systems:
Define the environment variable `EDITOR' to be the name of the
editing program you use. The SCM procedure `(ed arg1 ...)' will
invoke your editor and return to SCM when you exit the editor. The
following definition is convenient:
(define (e) (ed "work.scm") (load "work.scm"))
Typing `(e)' will invoke the editor with the file of interest.
After editing, the modified file will be loaded.
File: scm-5f2.info, Node: Debugging Scheme Code, Next: Debugging Continuations, Prev: Editing Scheme Code, Up: Operational Features
|
3.8 Debugging Scheme Code
=========================
The `cautious' option of `build' (*note Build Options::) supports
debugging in Scheme.
"CAUTIOUS"
If SCM is built with the `CAUTIOUS' flag, then when an error
occurs, a "stack trace" of certain pending calls are printed as
part of the default error response. A (memoized) expression and
newline are printed for each partially evaluated combination whose
procedure is not builtin. See *note Memoized Expressions:: for
how to read memoized expressions.
Also as the result of the `CAUTIOUS' flag, both `error' and
`user-interrupt' (invoked by ) to print stack traces and
conclude by calling `breakpoint' (*note Breakpoints:
(slib)Breakpoints.) instead of aborting to top level. Under
either condition, program execution can be resumed by `(continue)'.
In this configuration one can interrupt a running Scheme program
with , inspect or modify top-level values, trace or untrace
procedures, and continue execution with `(continue)'.
If `verbose' (*note verbose: Internal State.) is called with an
argument greater than 2, then the interpreter will check stack size
periodically. If the size of stack in use exceeds the C #define
`STACK_LIMIT' (default is `HEAP_SEG_SIZE'), SCM generates a `stack'
`segment violation'.
There are several SLIB macros which so useful that SCM automatically
loads the appropriate module from SLIB if they are invoked.
-- Macro: trace proc1 ...
Traces the top-level named procedures given as arguments.
-- Macro: trace
With no arguments, makes sure that all the currently traced
identifiers are traced (even if those identifiers have been
redefined) and returns a list of the traced identifiers.
-- Macro: untrace proc1 ...
Turns tracing off for its arguments.
-- Macro: untrace
With no arguments, untraces all currently traced identifiers and
returns a list of these formerly traced identifiers.
The routines I use most frequently for debugging are:
-- Function: print arg1 ...
`Print' writes all its arguments, separated by spaces. `Print'
outputs a `newline' at the end and returns the value of the last
argument.
One can just insert `(print '