scm-5e5/ 0000755 0017052 0001750 00000000000 10752352226 010036 5 ustar tb tb scm-5e5/disarm.scm 0000644 0017052 0001750 00000010110 10750211230 011775 0 ustar tb tb ;;;; "disarm.scm", Make SCM safe for client-server applications.
;; Copyright (C) 1998 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.
(define (disarm name)
(lambda args
;;(if (memq? name slib:features) (set! slib:features (remove name *features)))
(error name 'disabled)))
(define abort quit)
(define restart (disarm 'restart))
(define ed (disarm 'ed))
#+vms
(define vms-debug (disarm 'vms-debug))
;; opening files
(define open-file (disarm 'open-file))
(define transcript-on (disarm 'transcript-on))
#+i/o-extensions
(begin
(define system (disarm 'system))
(define execvp (disarm 'exec))
(define execv execvp)
(define execlp execvp)
(define execl execvp)
(define putenv (disarm 'putenv))
(define stat (disarm 'stat))
(define reopen-file (disarm 'reopen-file))
(define duplicate-port (disarm 'duplicate-port))
(define redirect-port! (disarm 'redirect-port!))
(define opendir (disarm 'opendir))
(define mkdir (disarm 'mkdir))
(define rmdir (disarm 'rmdir))
(define chdir (disarm 'chdir))
(define rename-file (disarm 'rename-file))
(define chmod (disarm 'chmod))
(define utime (disarm 'utime))
(define umask (disarm 'umask))
(define fileno (disarm 'fileno))
(define access (disarm 'access))
)
#+posix
(begin
(define open-pipe (disarm 'open-pipe))
(define fork (disarm 'fork))
(define setuid (disarm 'setuid))
(define setgid (disarm 'setgid))
(define seteuid (disarm 'seteuid))
(define setegid (disarm 'setegid))
(define kill (disarm 'kill))
(define waitpid (disarm 'waitpid))
(define uname (disarm 'uname))
(define getpw (disarm 'getpw))
(define getgr (disarm 'getgr))
(define getgroups (disarm 'getgroups))
(define link (disarm 'link))
(define chown (disarm 'chown))
)
;;#+unix
;;(begin
;; (define symlink (disarm 'symlink))
;; (define readlink (disarm 'readlink))
;; (define lstat (disarm 'lstat))
;; (define nice (disarm 'nice))
;; (define acct (disarm 'acct))
;; (define mknod (disarm 'mknod))
;; )
#+edit-line
(error 'edit-line 'inappropriate-for-server)
#+curses
(error 'curses 'inappropriate-for-server)
#+turtle-graphics
(error 'turtle-graphics 'inappropriate-for-server)
;;#+socket
;;(begin
;; (define make-stream-socket (disarm 'make-stream-socket))
;; (define make-stream-socketpair (disarm 'make-stream-socketpair))
;; (define socket:connect (disarm 'socket:connect))
;; (define socket:bind (disarm 'socket:bind))
;; (define socket:listen (disarm 'socket:listen))
;; (define socket:accept (disarm 'socket:accept))
;; )
;; load
(define load (disarm 'load))
(define try-load load)
(define scm:load load)
(define scm:load-source load)
(define link:link (disarm 'link:link))
;; SLIB loads
(define base:load load)
(define slib:load load)
(define slib:load-compiled load)
(define slib:load-source load)
(define defmacro:load load)
(define macro:load load)
;;(define macwork:load load)
;;(define syncase:load load)
;;(define synclo:load load)
;;;; eval
;;(define eval (disarm 'eval))
;;(define eval-string eval)
;;(define interaction-environment (disarm 'interaction-environment))
;;(define scheme-report-environment (disarm 'scheme-report-environment))
;;;; SLIB evals
;;(define base:eval eval)
;;(define slib:eval eval)
;;(define defmacro:eval eval)
;;(define macro:eval eval)
;;(define macwork:eval eval)
;;(define repl:eval eval)
;;(define syncase:eval eval)
;;(define syncase:eval-hook eval)
;;(define synclo:eval eval)
scm-5e5/bytenumb.c 0000644 0017052 0001750 00000030037 10750226347 012034 0 ustar tb tb /* "bytenumb.scm" Byte integer and IEEE floating-point conversions.
* Copyright (C) 2007 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 */
/* For documentation see:
http://cvs.savannah.gnu.org/viewcvs/slib/slib/bytenumb.scm?view=markup */
#include
#include
#include "scm.h"
int get_bytes_length(obj)
SCM obj;
{
array_dim *s;
if (IMP(obj)) return -1;
switch (TYP7(obj)) {
case tc7_string:
case tc7_VfixN8:
case tc7_VfixZ8:
return LENGTH(obj);
case tc7_smob:
if (!ARRAYP(obj)) return -1;
if (1 != ARRAY_NDIM(obj)) return -1;
s = ARRAY_DIMS(obj);
if (1 != s[0].inc) return -1;
return s[0].ubnd - s[0].lbnd;
default: return -1;
}
}
static char s_wrong_length[] = "wrong length";
static SCM list_of_0;
char * get_bytes(obj, minlen, s_name)
SCM obj;
int minlen;
const char *s_name;
{
ASRTER(NIMP(obj) && (TYP7(obj)==tc7_string ||
TYP7(obj)==tc7_VfixN8 ||
TYP7(obj)==tc7_VfixZ8),
obj, ARG1, s_name);
{
int byvlen = get_bytes_length(obj);
ASRTER(byvlen >= minlen, obj, s_wrong_length, s_name);
return (char*)scm_addr(cons(obj, list_of_0), s_name);
}
}
static char s_bytes_to_integer[] = "bytes->integer";
SCM scm_bytes_to_integer(sbyts, sn)
SCM sbyts;
SCM sn;
{
long n = INUM(sn);
if (!(n)) return INUM0;
{
int cnt = abs(n);
char *byts = get_bytes(sbyts, cnt, s_bytes_to_integer);
int iu = 0, id = cnt - sizeof(BIGDIG);
sizet ndigs = (cnt + sizeof(BIGDIG) - 1) / sizeof(BIGDIG);
int negp = (0x80 & byts[0]) && (0 > n);
SCM retval = mkbig(ndigs, negp);
BIGDIG *digs = BDIGITS(retval), carry = 1;
if (negp)
for (; iu < ndigs; iu++) {
int j = 0;
unsigned long dig = 0;
for (; j < sizeof(BIGDIG); j++) {
dig = (dig<<8) +
(0xFF ^ ((id + j >= 0) ? (((unsigned char *)byts)[id + j]) : 255));
/* printf("byts[%d + %d] = %lx\n", id, j, 0xFF & dig); */
}
dig = dig + carry;
digs[iu] = dig;
carry = dig >> (8 * sizeof(BIGDIG));
/* printf("id = %d; iu = %d; dig = %04lx\n", id, iu, dig); */
id = id - sizeof(BIGDIG);
} else
for (; iu < ndigs; iu++) {
int j = 0;
BIGDIG dig = 0;
for (; j < sizeof(BIGDIG); j++) {
dig = (dig<<8) +
((id + j >= 0) ? (((unsigned char *)byts)[id + j]) : 0);
}
digs[iu] = dig;
/* printf("id = %d; iu = %d; dig = %04x\n", id, iu, dig); */
id = id - sizeof(BIGDIG);
}
return normbig(retval);
}
}
static char s_integer_to_bytes[] = "integer->bytes";
SCM scm_integer_to_bytes(sn, slen)
SCM sn;
SCM slen;
{
ASRTER(INUMP(slen), slen, ARG2, s_integer_to_bytes);
{
int len = INUM(slen);
SCM sbyts = make_string(scm_iabs(slen), MAKICHR(0));
char *byts = CHARS(sbyts);
if (INUMP(sn)) {
int idx = -1 + (abs(len));
long n = num2long(sn, (char *)ARG1, s_integer_to_bytes);
if ((0 > n) && (0 > len)) {
long res = -1 - n;
while (!(0 > idx)) {
byts[idx--] = 0xFF ^ (res % 0x100);
res = res>>8;
}
}
else {
unsigned long res = n;
while (!(0 > idx)) {
byts[idx--] = res % 0x100;
res = res>>8;
}
}
} else {
ASRTER(NIMP(sn) && BIGP(sn), sn, ARG1, s_integer_to_bytes);
{
BIGDIG *digs = BDIGITS(sn), borrow = 1;
sizet ndigs = NUMDIGS(sn);
int iu = 0, id = abs(len) - 1;
unsigned long dig;
if ((0 > len) && (TYP16(sn)==tc16_bigneg))
for (; 0 <= id ; iu++) {
sizet j = sizeof(BIGDIG);
dig = (iu < ndigs) ? digs[iu] : 0;
dig = dig ^ ((1 << (8 * sizeof(BIGDIG))) - 1);
/* printf("j = %d; id = %d; iu = %d; dig = %04x; borrow = %d\n", j, id, iu, dig, borrow); */
for (; 0 < j-- && 0 <= id;) {
/* printf("byts[%d] = %02x\n", id, 0xFF & dig); */
int dg = (0xFF & dig) + borrow;
borrow = dg >> 8;
((unsigned char *)byts)[id--] = dg;
dig = (dig)>>8;
}
}
else
for (; 0 <= id ; iu++) {
BIGDIG dig = (iu < ndigs) ? digs[iu] : 0;
sizet j = sizeof(BIGDIG);
/* printf("j = %d; id = %d; iu = %d; dig = %04x\n", j, id, iu, dig); */
for (; 0 < j-- && 0 <= id;) {
/* printf("byts[%d] = %02x\n", id, 0xFF & dig); */
((unsigned char *)byts)[id--] = 0xFF & dig;
dig = (dig>>8);
}
}
}
}
return sbyts;
}
}
static char s_bytes_to_ieee_float[] = "bytes->ieee-float";
SCM scm_bytes_to_ieee_float(sbyts)
SCM sbyts;
{
char *byts = get_bytes(sbyts, 4, s_bytes_to_ieee_float);
int len = LENGTH(sbyts);
int s = (1<<(7)) & ((((unsigned char*)(byts))[0]));
int e = ((0x7f&((((unsigned char*)(byts))[0])))<<1)
+ ((0x80&((((unsigned char*)(byts))[1])))>>7);
float f = (((unsigned char*)(byts))[ -1 + (len)]);
int idx = -2 + (len);
while (!((idx)<=1)) {
{
int T_idx = -1 + (idx);
f = ((((unsigned char*)(byts))[idx])) + ((f) / 0x100);
idx = T_idx;
}
}
f = ((0x7f&((((unsigned char*)(byts))[1]))) + ((f) / 0x100)) / 0x80;
if ((0<(e))
&& ((e)<0xff))
return makdbl(ldexpf((s ? -1 : 1) * (1 + (f)), (e) - 0x7f), 0.0);
else if (!(e))
if (!(f)) return flo0;
else return makdbl(ldexpf((s ? -1 : 1) * (f), -126), 0.0);
else if (f)
return scm_narn;
else return makdbl((s ? -(1.0) : 1.0) / 0.0, 0.0);
}
static char s_bytes_to_ieee_double[] = "bytes->ieee-double";
SCM scm_bytes_to_ieee_double(sbyts)
SCM sbyts;
{
char *byts = get_bytes(sbyts, 8, s_bytes_to_ieee_double);
int len = LENGTH(sbyts);
int s = (1<<(7)) & ((((unsigned char*)(byts))[0]));
int e = ((0x7f&((((unsigned char*)(byts))[0])))<<4)
+ ((0xf0&((((unsigned char*)(byts))[1])))>>4);
double f = (((unsigned char*)(byts))[ -1 + (len)]);
int idx = -2 + (len);
while (!((idx)<=1)) {
{
int T_idx = -1 + (idx);
f = ((((unsigned char*)(byts))[idx])) + ((f) / 0x100);
idx = T_idx;
}
}
f = ((0xf&((((unsigned char*)(byts))[1]))) + ((f) / 0x100)) / 0x10;
if ((0<(e))
&& ((e)<0x7ff))
return makdbl(ldexp((s ? -1 : 1) * (1 + (f)), (e) - 0x3ff), 0.0);
else if (!(e))
if (!(f)) return flo0;
else return makdbl(ldexp((s ? -1 : 1) * (f), -1022), 0.0);
else if (f)
return scm_narn;
else return makdbl((s ? -(1.0) : 1.0) / 0.0, 0.0);
}
static char s_ieee_float_to_bytes[] = "ieee-float->bytes";
SCM scm_ieee_float_to_bytes(in_flt)
SCM in_flt;
{
double dbl = num2dbl(in_flt, (char *)ARG1, s_ieee_float_to_bytes);
float flt = (float) dbl;
SCM sbyts = make_string(MAKINUM(4), MAKICHR(0));
char *byts = CHARS(sbyts);
int s = flt < 0.0;
int scl = 0x7f;
flt = fabs(flt);
if (0.0==flt) {
if (s)
byts[0] = 0x80;
return sbyts;
}
else if (flt != flt) {
byts[0] = 0x7f;
byts[1] = 0xc0;
return sbyts;
}
else goto L_scale;
L_out:
{
float T_flt = 0x80 * (flt);
int val = (int)(floor(0x80 * (flt)));
int idx = 1;
float flt = T_flt;
while (!((idx) > 3)) {
byts[idx] = val;
{
float T_flt = 0x100 * ((flt) - (val));
int T_val = (int)(floor(0x100 * ((flt) - (val))));
idx = 1 + (idx);
flt = T_flt;
val = T_val;
}
}
byts[1] = (0x80 & (scl<<7)) | (0x7f & (((unsigned char*)(byts))[1]));
byts[0] = (s ? 0x80 : 0) + ((scl)>>1);
return sbyts;
}
L_scale:
if (!(scl)) {
flt = (flt)/2;
goto L_out;
}
else if ((flt)>=0x10) {
float flt16 = (flt) / 0x10;
if ((flt16)==(flt)) {
byts[0] = s ? 0xff : 0x7f;
byts[1] = 0x80;
return sbyts;
}
else {
flt = flt16;
scl = (scl) + 4;
goto L_scale;
}
}
else if ((flt) >= 2) {
flt = (flt) / 2;
scl = (scl) + 1;
goto L_scale;
}
else if (((scl) >= 4) && ((0x10 * (flt))<1)) {
flt = (flt) * 0x10;
scl = (scl)+ -4;
goto L_scale;
}
else if ((flt)<1) {
flt = (flt) * 2;
scl = (scl) + -1;
goto L_scale;
}
else {
flt = -1+(flt);
goto L_out;
}
}
static char s_ieee_double_to_bytes[] = "ieee-double->bytes";
SCM scm_ieee_double_to_bytes(in_flt)
SCM in_flt;
{
double flt = num2dbl(in_flt, (char *)ARG1, s_ieee_double_to_bytes);
SCM sbyts = make_string(MAKINUM(8), MAKICHR(0));
char *byts = CHARS(sbyts);
int s = flt < 0.0;
int scl = 0x3ff;
flt = fabs(flt);
if (0.0==flt) {
if (s)
byts[0] = 0x80;
return sbyts;
}
else if (flt != flt) {
byts[0] = 0x7f;
byts[1] = 0xf8;
return sbyts;
}
else goto L_scale;
L_out:
{
double T_flt = 0x10 * (flt);
int val = (int)(floor(0x10 * (flt)));
int idx = 1;
double flt = T_flt;
while (!((idx) > 7)) {
byts[idx] = val;
{
double T_flt = 0x100 * (flt - val);
int T_val = (int)floor(0x100 * (flt - val));
idx = 1 + (idx);
flt = T_flt;
val = T_val;
}
}
byts[1] = (0xf0 & (scl<<4)) | (0x0f & (((unsigned char*)(byts))[1]));
byts[0] = (s ? 0x80 : 0) + ((scl)>>4);
return sbyts;
}
L_scale:
if (!(scl)) {
flt = (flt) / 2;
goto L_out;
}
else if ((flt) >= 0x10) {
double flt16 = (flt) / 0x10;
if ((flt16)==(flt)) {
byts[0] = s ? 0xff : 0x7f;
byts[1] = 0xf0;
return sbyts;
}
else {
flt = flt16;
scl = (scl) + 4;
goto L_scale;
}
}
else if ((flt) >= 2) {
flt = (flt) / 2;
scl = (scl) + 1;
goto L_scale;
}
else if (((scl) >= 4) && ((0x10 * flt) < 1)) {
flt = (flt) * 0x10;
scl = (scl) + -4;
goto L_scale;
}
else if ((flt) < 1) {
flt = (flt) * 2;
scl = (scl) + -1;
goto L_scale;
}
else {
flt = -1 + (flt);
goto L_out;
}
}
static char s_integer_byte_collate_M[] = "integer-byte-collate!";
SCM scm_integer_byte_collate_M(byte_vector)
SCM byte_vector;
{
char* bv = get_bytes(byte_vector, 1, s_integer_byte_collate_M);
bv[0] = 0x80^(bv[0]);
return byte_vector;
}
static char s_ieee_byte_collate_M[] = "ieee-byte-collate!";
SCM scm_ieee_byte_collate_M(byte_vector)
SCM byte_vector;
{
char* byv = get_bytes(byte_vector, 4, s_ieee_byte_collate_M);
int byvlen = get_bytes_length(byte_vector);
if (0x80&(byv[0])) {
int idx = -1 + byvlen;
while (!(0 > (idx))) {
byv[idx] = 0xff^(byv[idx]);
idx = -1+(idx);
}
}
else
byv[0] = 0x80^(byv[0]);
return byte_vector;
}
static char s_ieee_byte_decollate_M[] = "ieee-byte-decollate!";
SCM scm_ieee_byte_decollate_M(byte_vector)
SCM byte_vector;
{
char* byv = get_bytes(byte_vector, 4, s_ieee_byte_collate_M);
int byvlen = get_bytes_length(byte_vector);
if (!(0x80&(byv[0]))) {
int idx = -1 + byvlen;
while (!(0 > (idx))) {
byv[idx] = 0xff^(byv[idx]);
idx = -1+(idx);
}
}
else
byv[0] = 0x80^(byv[0]);
return byte_vector;
}
static iproc subr1s[] = {
{s_bytes_to_ieee_float, scm_bytes_to_ieee_float},
{s_bytes_to_ieee_double, scm_bytes_to_ieee_double},
{s_ieee_float_to_bytes, scm_ieee_float_to_bytes},
{s_ieee_double_to_bytes, scm_ieee_double_to_bytes},
{s_integer_byte_collate_M, scm_integer_byte_collate_M},
{s_ieee_byte_collate_M, scm_ieee_byte_collate_M},
{s_ieee_byte_decollate_M, scm_ieee_byte_decollate_M},
{0, 0}};
void init_bytenumb()
{
list_of_0 = cons(INUM0, EOL);
scm_gc_protect(list_of_0);
make_subr(s_bytes_to_integer, tc7_subr_2, scm_bytes_to_integer);
make_subr(s_integer_to_bytes, tc7_subr_2, scm_integer_to_bytes);
init_iprocs(subr1s, tc7_subr_1);
scm_ldstr("\n\
(define (integer-byte-collate byte-vector)\n\
(integer-byte-collate! (bytes-copy byte-vector)))\n\
(define (ieee-byte-collate byte-vector)\n\
(ieee-byte-collate! (bytes-copy byte-vector)))\n\
(define (ieee-byte-decollate byte-vector)\n\
(ieee-byte-decollate! (bytes-copy byte-vector)))\n\
");
/* add_feature("byte-number"); */
}
scm-5e5/Init5e5.scm 0000644 0017052 0001750 00000146560 10750526465 012006 0 ustar tb tb ;;;; "Init.scm", Scheme initialization code for SCM.
;; Copyright (C) 1991-2008 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.
(define (scheme-implementation-type) 'scm)
(define (scheme-implementation-version) "5e5")
(define (scheme-implementation-home-page)
"http://swiss.csail.mit.edu/~jaffer/SCM")
;@
(define in-vicinity string-append)
;@
(define (user-vicinity)
(case (software-type)
((vms) "[.]")
(else "")))
;@
(define vicinity:suffix?
(let ((suffi
(case (software-type)
((amiga) '(#\: #\/))
((macos thinkc) '(#\:))
((ms-dos windows atarist os/2) '(#\\ #\/))
((nosve) '(#\: #\.))
((unix coherent plan9) '(#\/))
((vms) '(#\: #\]))
(else
(slib:warn "require.scm" 'unknown 'software-type (software-type))
"/"))))
(lambda (chr) (and (memv chr suffi) #t))))
;@
(define (pathname->vicinity pathname)
(let loop ((i (- (string-length pathname) 1)))
(cond ((negative? i) "")
((vicinity:suffix? (string-ref pathname i))
(substring pathname 0 (+ i 1)))
(else (loop (- i 1))))))
(define (program-vicinity)
(if *load-pathname*
(pathname->vicinity *load-pathname*)
(slib:error 'program-vicinity " called; use slib:load to load")))
;@
(define sub-vicinity
(case (software-type)
((vms) (lambda
(vic name)
(let ((l (string-length vic)))
(if (or (zero? (string-length vic))
(not (char=? #\] (string-ref vic (- l 1)))))
(string-append vic "[" name "]")
(string-append (substring vic 0 (- l 1))
"." name "]")))))
(else (let ((*vicinity-suffix*
(case (software-type)
((nosve) ".")
((macos thinkc) ":")
((ms-dos windows atarist os/2) "\\")
((unix coherent plan9 amiga) "/"))))
(lambda (vic name)
(string-append vic name *vicinity-suffix*))))))
;@
(define (make-vicinity ) )
;@
(define with-load-pathname
(let ((exchange
(lambda (new)
(let ((old *load-pathname*))
(set! *load-pathname* new)
old))))
(lambda (path thunk)
(let ((old #f))
(dynamic-wind
(lambda () (set! old (exchange path)))
thunk
(lambda () (exchange old)))))))
(define slib:features
(append '(ed getenv tmpnam abort transcript with-file
ieee-p1178 rev4-report rev4-optional-procedures
hash object-hash delay dynamic-wind fluid-let
multiarg-apply multiarg/and- logical defmacro
string-port source current-time sharp:semi
math-integer ;math-real and srfi-94 provided in "Transcen.scm"
vicinity srfi-59 srfi-96 srfi-23
srfi-60) ;logical
(if (defined? *features*) *features* slib:features)))
(if (defined? *features*) (set! *features* slib:features))
(define eval
(let ((@eval @eval)
(@copy-tree @copy-tree))
(lambda (x) (@eval (@copy-tree x)))))
(define (exec-self)
(require 'i/o-extensions)
(execv (execpath) (if *script*
(cons (car (program-arguments))
(cons "\\"
(member *script* (program-arguments))))
(program-arguments))))
(define (display-file file . port)
(call-with-input-file file
(lambda (inport)
(do ((c (read-char inport) (read-char inport)))
((eof-object? c))
(apply write-char c port)))))
(define (terms)
(display-file (in-vicinity (implementation-vicinity) "COPYING")))
;;; Read integer up to first non-digit
(define (read:try-number port . ic)
(define chr0 (char->integer #\0))
(let loop ((arg (and (not (null? ic)) (- (char->integer (car ic)) chr0))))
(let ((c (peek-char port)))
(cond ((eof-object? c) #f)
((char-numeric? c)
(loop (+ (* 10 (or arg 0))
(- (char->integer (read-char port)) chr0))))
(else arg)))))
(define (read-array-type port)
(define (bomb pc wid)
(error 'array 'syntax? (symbol-append "#" rank "A" pc wid)))
(case (char-downcase (peek-char port))
((#\:) (read-char port)
(let ((typ (let loop ((arg '()))
(if (= 4 (length arg))
(string->symbol (list->string (reverse arg)))
(let ((c (read-char port)))
(and (not (eof-object? c))
(loop (cons (char-downcase c) arg))))))))
(define wid (and typ (not (eq? 'bool typ)) (read:try-number port)))
(define (check-suffix chrs)
(define chr (read-char port))
(if (and (char? chr) (not (memv (char-downcase chr) chrs)))
(error 'array-type? (symbol-append ":" typ wid chr))))
(define prot (assq typ '((floc (128 . +64.0i)
(64 . +64.0i)
(32 . +32.0i)
(16 . +32.0i))
(flor (128 . 64.0)
(64 . 64.0)
(32 . 32.0)
(16 . 32.0))
(fixz (64 . -64)
(32 . -32)
(16 . -16)
(8 . -8))
(fixn (64 . 64)
(32 . 32)
(16 . 16)
(8 . 8))
(char . #\a)
(bool . #t))))
(if prot (set! prot (cdr prot)))
(cond ((pair? prot)
(set! prot (assv wid (cdr prot)))
(if (pair? prot) (set! prot (cdr prot)))
(if wid (check-suffix (if (and (inexact? prot) (real? prot))
'(#\b #\d)
'(#\b)))))
(prot)
(else (check-suffix '())))
prot))
((#\\) (read-char port) #\a)
((#\t) (read-char port) #t)
((#\c #\r) (let* ((pc (read-char port)) (wid (read:try-number port)))
(case wid
((64 32) (case pc
((#\c) (* +i wid))
(else (exact->inexact wid))))
(else (bomb pc wid)))))
((#\s #\u) (let* ((pc (read-char port)) (wid (read:try-number port)))
(case (or wid (peek-char port))
((32 16 8) (case pc
((#\s) (- wid))
(else wid)))
(else (bomb pc wid)))))
(else #f)))
;;; We come into read:array with number or #f for RANK.
(define (read:array rank dims port)
(define (make-it rank dims typ)
(list->uniform-array (cond (rank)
((null? dims) 1)
(else (length dims)))
typ
(read port)))
(let loop ((dims dims))
(define dim (read:try-number port))
(if dim
(loop (cons dim dims))
(case (peek-char port)
((#\*) (read-char port) (loop dims))
((#\: #\\ #\t #\c #\r #\s #\u #\T #\C #\R #\S #\U)
(make-it rank dims (read-array-type port)))
(else
(make-it rank dims #f))))))
;;; read-macros valid for LOAD and READ.
(define (read:sharp c port reader) ; ignore reader
(case c
;; Used in "implcat" and "slibcat"
((#\+) (if (slib:provided? (read port))
(read port)
(begin (read port) (if #f #f))))
;; Used in "implcat" and "slibcat"
((#\-) (if (slib:provided? (read port))
(begin (read port) (if #f #f))
(read port)))
((#\a #\A) (read:array #f '() port))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(let* ((num (read:try-number port c))
(chr (peek-char port)))
(case chr
((#\a #\A) (read-char port)
(read:array num '() port))
((#\*) (read-char port)
(read:array #f (list num) port))
(else
(read:array 1 (list num) port))
;;(else (error 'sharp 'syntax? (symbol-append "#" num chr)))
)))
(else (error "unknown # object" c))))
;;; read-macros valid only in LOAD.
(define (load:sharp c port reader) ;reader used only for #.
(case c
((#\') (read port))
((#\.) (eval (reader port)))
((#\!) (let skip ((metarg? #f))
(let ((c (read-char port)))
(case c
((#\newline) (if metarg? (skip #t)))
((#\\) (skip #t))
((#\!) (cond ((eqv? #\# (peek-char port))
(read-char port)
(if #f #f))
(else (skip metarg?))))
(else (if (char? c) (skip metarg?) c))))))
;; Make #; convert the rest of the line to a (comment ...) form.
;; "build.scm" uses this.
((#\;) (let skip-semi ()
(cond ((eqv? #\; (peek-char port))
(read-char port)
(skip-semi))
(else (require 'line-i/o)
`(comment ,(read-line port))))))
((#\?) (case (read port)
((line) (port-line port))
((column) (port-column port))
((file) (port-filename port))
(else #f)))
(else (read:sharp c port read))))
;;; We can assume TOK has at least 2 characters.
(define char:sharp
(letrec ((numeric-1
(lambda (tok radix)
(numeric (substring tok 1 (string-length tok)) radix)))
(numeric
(lambda (tok radix)
(cond ((string->number tok radix) => integer->char))))
(compose
(lambda (modifier tok)
(and (char=? #\- (string-ref tok 1))
(if (= 3 (string-length tok))
(modifier (string-ref tok 2))
(let ((c (char:sharp
(substring tok 2 (string-length tok)))))
(and c (modifier c)))))))
(control
(lambda (c)
(and (char? c)
(if (eqv? c #\?)
(integer->char 127)
(integer->char (logand #o237 (char->integer c)))))))
(meta
(lambda (c)
(and (char? c)
(integer->char (logior 128 (char->integer c)))))))
(lambda (tok)
(case (string-ref tok 0)
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) (numeric tok 8))
((#\O #\o) (numeric-1 tok 8))
((#\D #\d) (numeric-1 tok 10))
((#\X #\x) (numeric-1 tok 16))
((#\C #\c) (compose control tok))
((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1))))
((#\M #\m) (compose meta tok))))))
;;;; Function used to accumulate comments before a definition.
(define comment
(let ((*accumulated-comments* '()))
(lambda args
(cond ((null? args)
(let ((ans
(apply string-append
(map (lambda (comment)
(string-append (or comment "") "\n"))
(reverse *accumulated-comments*)))))
(set! *accumulated-comments* '())
(if (equal? "" ans)
"no-comment" ;#f
(substring ans 0 (+ -1 (string-length ans))))))
(else (set! *accumulated-comments*
(append (reverse args) *accumulated-comments*)))))))
(define : ':) ;for /bin/sh hack.
(define !#(if #f #f)) ;for scsh hack.
;;;; Here are some Revised^2 Scheme functions:
(define 1+ (let ((+ +)) (lambda (n) (+ n 1))))
(define -1+ (let ((+ +)) (lambda (n) (+ n -1))))
(define 1- -1+)
(define ? >)
(define >=? >=)
(define t #t)
(define nil #f)
(define identity cr)
(cond ((defined? defsyntax)
(defsyntax define-syntax (the-macro defsyntax)))
(else
(define defsyntax define)
(define the-macro identity)))
(defsyntax sequence (the-macro begin))
(define copy-tree @copy-tree)
;;; VMS does something strange when output is sent to both
;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
(case (software-type) ((vms) (set-current-error-port (current-output-port))))
;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
;;; mode to open files in. MS-DOS does carriage return - newline
;;; translation if not opened in `b' mode.
(define open_read (case (software-type)
((ms-dos windows atarist) 'rb)
(else 'r)))
(define open_write (case (software-type)
((ms-dos windows) 'wbc)
((atarist) 'wb)
(else 'w)))
(define open_both (case (software-type)
((ms-dos windows) 'r+bc)
((atarist) 'r+b)
(else 'r+)))
(define ((make-moder str) mode)
(if (symbol? mode)
(string->symbol (string-append (symbol->string mode) str))
(string-append mode str)))
(define _ionbf (make-moder "0"))
(define _tracked (make-moder "?"))
(define _exclusive (make-moder "x"))
(define could-not-open #f)
(define (open-output-file str)
(or (open-file str open_write)
(and (procedure? could-not-open) (could-not-open) #f)
(error "OPEN-OUTPUT-FILE couldn't open file " str)))
(define (open-input-file str)
(or (open-file str open_read)
(and (procedure? could-not-open) (could-not-open) #f)
(error "OPEN-INPUT-FILE couldn't open file " str)))
(define (string-index str chr)
(define len (string-length str))
(do ((pos 0 (+ 1 pos)))
((or (>= pos len) (char=? chr (string-ref str pos)))
(and (< pos len) pos))))
(if (not (defined? try-create-file))
(define (try-create-file str modes . perms)
(if (symbol? modes) (set! modes (symbol->string modes)))
(let ((idx (string-index modes #\x)))
(cond ((slib:in-catalog? 'i/o-extensions)
(require 'i/o-extensions)
(apply try-create-file str modes perms))
((not idx)
(warn "not exclusive modes?" modes str)
(try-open-file str modes))
(else (set! modes (string-append (substring modes 0 idx)
(substring modes (+ 1 idx)
(string-length modes))))
(cond ((not (string-index modes #\w))
(warn 'try-create-file "not writing?" modes str)
(try-open-file str modes))
(else
(cond ((and (not (null? perms))
(not (eqv? #o666 (car perms))))
(warn "perms?" (car perms) str)))
(cond ((file-exists? str) #f)
(else (try-open-file str modes))))))))))
(if (not (defined? file-position))
(define (file-position . args) #f))
(if (not (defined? file-set-position))
(define file-set-position file-position))
(define close-input-port close-port)
(define close-output-port close-port)
(define (call-with-open-ports . ports)
(define proc (car ports))
(cond ((procedure? proc) (set! ports (cdr ports)))
(else (set! ports (reverse ports))
(set! proc (car ports))
(set! ports (reverse (cdr ports)))))
(let ((ans (apply proc ports)))
(for-each close-port ports)
ans))
(define (call-with-input-file str proc)
(call-with-open-ports (open-input-file str) proc))
(define (call-with-output-file str proc)
(call-with-open-ports (open-output-file str) proc))
(define (with-input-from-port port thunk)
(dynamic-wind (lambda () (set! port (set-current-input-port port)))
thunk
(lambda () (set! port (set-current-input-port port)))))
(define (with-output-to-port port thunk)
(dynamic-wind (lambda () (set! port (set-current-output-port port)))
thunk
(lambda () (set! port (set-current-output-port port)))))
(define (with-error-to-port port thunk)
(dynamic-wind (lambda () (set! port (set-current-error-port port)))
thunk
(lambda () (set! port (set-current-error-port port)))))
(define (with-input-from-file file thunk)
(let* ((nport (open-input-file file))
(ans (with-input-from-port nport thunk)))
(close-port nport)
ans))
(define (with-output-to-file file thunk)
(let* ((nport (open-output-file file))
(ans (with-output-to-port nport thunk)))
(close-port nport)
ans))
(define (with-error-to-file file thunk)
(let* ((nport (open-output-file file))
(ans (with-error-to-port nport thunk)))
(close-port nport)
ans))
(define (call-with-outputs thunk proc)
(define stdout #f)
(define stderr #f)
(define status #f)
(set! stdout
(call-with-output-string
(lambda (stdout)
(set! stderr
(call-with-output-string
(lambda (stderr)
(call-with-current-continuation
(lambda (escape)
(dynamic-wind
(lambda ()
(set! status #f)
(set! stdout (set-current-output-port stdout))
(set! stderr (set-current-error-port stderr)))
(lambda () (set! status (list (thunk))))
(lambda ()
(set! stdout (set-current-output-port stdout))
(set! stderr (set-current-error-port stderr))
(if (not status) (escape #f))))))))))))
(apply proc stdout stderr (or status '())))
(define browse-url
(case (software-type)
((unix coherent plan9)
(lambda (url)
(define (try cmd end) (zero? (system (string-append cmd url end))))
(or (try "netscape-remote -remote 'openURL(" ")'")
(try "netscape -remote 'openURL(" ")'")
(try "netscape '" "'&")
(try "netscape '" "'"))))
(else
(lambda (url)
(slib:warn 'define (software-type) 'case 'of 'browse-url 'in
*load-pathname*)))))
(define (warn . args)
(define cep (current-error-port))
(if (defined? print-call-stack) (print-call-stack cep))
(perror "WARN")
(errno 0)
(display "WARN:" cep)
(for-each (lambda (x) (display #\space cep) (write x cep)) args)
(newline cep)
(force-output cep))
(define (error . args)
(define cep (current-error-port))
(if (defined? print-call-stack) (print-call-stack cep))
(perror "ERROR")
(errno 0)
(display "ERROR:" cep)
(for-each (lambda (x) (display #\space cep) (write x cep)) args)
(newline cep)
(force-output cep)
(abort))
(define set-errno errno)
(define slib:exit quit)
(define exit quit)
(define (print . args)
(define result #f)
(for-each (lambda (x) (set! result x) (write x) (display #\space)) args)
(newline)
result)
(define (pprint . args)
(define result #f)
(for-each (lambda (x) (set! result x) (pretty-print x)) args)
result)
(define (pp . args)
(for-each pretty-print args)
(if #f #f))
(if (not (defined? file-exists?))
(define (file-exists? str)
(let ((port (open-file str open_read)))
(errno 0)
(and port (close-port port) #t))))
(define (file-readable? str)
(let ((port (open-file str open_read)))
(errno 0)
(and port
(char-ready? port)
(do ((c (read-char port)
(and (char-ready? port) (read-char port)))
(i 0 (+ 1 i))
(l '() (cons c l)))
((or (not c) (eof-object? c) (<= 2 i))
(if (null? l) #f (list->string (reverse l))))))))
(define difftime -)
(define offset-time +)
(if (not (defined? ed))
(define (ed . args)
(system (apply string-append
(or (getenv "EDITOR") "ed")
(map (lambda (s) (string-append " " s)) args)))))
(if (not (defined? output-port-width))
(define (output-port-width . arg) 80))
(if (not (defined? output-port-height))
(define (output-port-height . arg) 24))
(if (not (defined? last-pair))
(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)))
(define slib:error error)
(define slib:warn warn)
(define slib:tab #\tab)
(define slib:form-feed #\page)
(define slib:eval eval)
(define (make-exchanger . pair) (lambda (rep) (swap-car! pair rep)))
;;;; Load.
(define load:indent 0)
(define (load:pre file)
(define cep (current-error-port))
(cond ((> (verbose) 1)
(display
(string-append ";" (make-string load:indent #\space) "loading " file)
cep)
(set! load:indent (modulo (+ 2 load:indent) 16))
(newline cep)))
(force-output cep))
(define (load:post filesuf)
(define cep (current-error-port))
(errno 0)
(cond ((> (verbose) 1)
(set! load:indent (modulo (+ -2 load:indent) 16))
(display (string-append ";" (make-string load:indent #\space)
"done loading " filesuf)
cep)
(newline cep)
(force-output cep))))
;;; Here for backward compatibility
(define scheme-file-suffix
(case (software-type)
((NOSVE) (lambda () "_scm"))
(else (lambda () ".scm"))))
(define (has-suffix? str suffix)
(let ((sufl (string-length suffix))
(sl (string-length str)))
(and (> sl sufl)
(string=? (substring str (- sl sufl) sl) suffix))))
(define *load-reader* #f)
(define (scm:load file . libs)
(define filesuf file)
(define hss (has-suffix? file (scheme-file-suffix)))
(load:pre file)
(or (and (defined? link:link) (not hss)
(or (let ((s2 (file-readable? file)))
(and s2 (not (equal? "#!" s2)) (apply link:link file libs)))
(and link:able-suffix
(let* ((fs (string-append file link:able-suffix))
(fs2 (file-readable? fs)))
(and fs2 (apply link:link fs libs) (set! filesuf fs) #t)
))))
(and (null? libs) (try-load file *load-reader*))
;;HERE is where the suffix gets specified
(and (not hss) (errno 0) ; clean up error from TRY-LOAD above
(set! filesuf (string-append file (scheme-file-suffix)))
(try-load filesuf *load-reader*))
(and (procedure? could-not-open) (could-not-open) #f)
(begin (set! load:indent 0)
(error "LOAD couldn't find file " file)))
(load:post filesuf))
(define load scm:load)
(define slib:load load)
(define (scm:load-source file)
(define sfs (scheme-file-suffix))
(define filesuf file)
(load:pre file)
(or (and (or (try-load file *load-reader*)
;;HERE is where the suffix gets specified
(and (not (has-suffix? file sfs))
(begin (set! filesuf (string-append file sfs))
(try-load filesuf *load-reader*)))))
(and (procedure? could-not-open) (could-not-open) #f)
(error "LOAD couldn't find file " file))
(load:post filesuf))
(define slib:load-source scm:load-source)
;;; This is the vicinity where this file resides.
(define implementation-vicinity #f)
;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
(define library-vicinity #f)
;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which
;;; customize a computer environment for a user.
(define home-vicinity #f)
(if (not (defined? getpw))
(define read-line
(if (defined? read-line)
read-line
(lambda port
(let* ((chr (apply read-char port)))
(if (eof-object? chr)
chr
(do ((chr chr (apply read-char port))
(clist '() (cons chr clist)))
((or (eof-object? chr) (char=? #\newline chr))
(list->string (reverse clist))))))))))
(if (not (defined? getpw))
(define string-index
(if (defined? string-index)
string-index
(lambda (str chr)
(define len (string-length str))
(do ((pos 0 (+ 1 pos)))
((or (>= pos len) (char=? chr (string-ref str pos)))
(and (< pos len) pos)))))))
(define (login->home-directory login)
(cond ((defined? getpw)
(let ((pwvect (getpw login)))
(and pwvect (vector-ref pwvect 5))))
((not (file-exists? "/etc/passwd")) #f)
(else
(call-with-input-file "/etc/passwd"
(lambda (iprt)
(let tryline ()
(define line (read-line iprt))
(define (get-field)
(define idx (string-index line #\:))
(and idx
(let ((fld (substring line 0 idx)))
(set! line (substring line (+ 1 idx)
(string-length line)))
fld)))
(cond ((eof-object? line) #f)
((string-index line #\:)
=> (lambda (idx)
(define name (substring line 0 idx))
(cond ((equal? login name)
(do ((ans (get-field) (get-field))
(cnt 4 (+ -1 cnt)))
((or (negative? cnt) (not ans)) ans)))
(else (tryline))))))))))))
(define (getlogin) (or (getenv "USER") (getenv "LOGNAME")))
;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use
;;; (implementation-vicinity) as (library-vicinity). "require.scm",
;;; the first file loaded from (library-vicinity), can redirect it.
(define (set-vicinities! init-file)
(set! implementation-vicinity
(let ((vic (substring
init-file
0
(- (string-length init-file)
(string-length "Init.scm")
(string-length (scheme-implementation-version))))))
(lambda () vic)))
(let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
(if library-path
(set! library-vicinity (lambda () library-path))
(let ((filename (in-vicinity (implementation-vicinity) "require.scm")))
(or (try-load filename)
(try-load (in-vicinity (implementation-vicinity) "requires.scm"))
(error "Can't load" filename))
(if (not library-vicinity) (error "Can't find library-vicinity")))))
(set! home-vicinity
(let ((home (getenv "HOME")))
(and (not home) login->home-directory
(let ((login (getlogin)))
(and login (set! home (login->home-directory login)))))
(and home
(case (software-type)
((unix coherent plan9 ms-dos) ;V7 unix has a / on HOME
(if (not
(eqv? #\/ (string-ref home (+ -1 (string-length home)))))
(set! home (string-append home "/"))))))
(lambda () home))))
;;; SET-VICINITIES! is also called from BOOT-TAIL
(set-vicinities! *load-pathname*)
;;;; Initialize SLIB
(load (in-vicinity (library-vicinity) "require"))
;;; This enables line-numbering for SLIB loads.
(define *slib-load-reader* (and (defined? read-numbered) read-numbered))
;;; DO NOT MOVE! SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after
;;; "require.scm" is loaded.
(define (slib:load-source file)
(fluid-let ((*load-reader* *slib-load-reader*))
(scm:load-source file)))
(define (slib:load file . libs)
(fluid-let ((*load-reader* *slib-load-reader*))
(apply scm:load file libs)))
;;; Legacy grease
(if (not (defined? slib:in-catalog?))
(define slib:in-catalog? require:feature->path))
;;; Dynamic link-loading
(cond ((or (defined? dyn:link)
(defined? vms:dynamic-link-call))
(load (in-vicinity (implementation-vicinity) "Link"))))
;;; Redefine to ease transition from *features* to slib:features.
(define (provide feature)
(cond ((not (memq feature slib:features))
(set! slib:features (cons feature slib:features))
(if (defined? *features*) (set! *features* slib:features)))))
(cond ((defined? link:link)
(define (slib:load-compiled . args)
(cond ((symbol? (car args))
(require (car args))
(apply slib:load-compiled (cdr args)))
((apply link:link args)
(if (defined? *features*) (set! slib:features *features*)))
(else (error "Couldn't link files " args))))
(provide 'compiled)))
;;; Complete the function set for feature STRING-CASE.
(cond
((defined? string-upcase!)
(define (string-upcase str) (string-upcase! (string-copy str)))
(define (string-downcase str) (string-downcase! (string-copy str)))
(define (string-capitalize str) (string-capitalize! (string-copy str)))
(define string-ci->symbol
(let ((s2cis (if (equal? "x" (symbol->string 'x))
string-downcase string-upcase)))
(lambda (str) (string->symbol (s2cis str)))))
(define symbol-append
(let ((s2cis (if (equal? "x" (symbol->string 'x))
string-downcase string-upcase)))
(lambda args
(string->symbol
(apply string-append
(map
(lambda (obj)
(cond ((char? obj) (string obj))
((string? obj) (s2cis obj))
((number? obj) (s2cis (number->string obj)))
((symbol? obj) (symbol->string obj))
((not obj) "")
(else (error 'wrong-type-to 'symbol-append obj))))
args))))))
(define (StudlyCapsExpand nstr . delimitr)
(set! delimitr
(cond ((null? delimitr) "-")
((char? (car delimitr)) (string (car delimitr)))
(else (car delimitr))))
(do ((idx (+ -1 (string-length nstr)) (+ -1 idx)))
((> 1 idx) nstr)
(cond ((and (> idx 1)
(char-upper-case? (string-ref nstr (+ -1 idx)))
(char-lower-case? (string-ref nstr idx)))
(set! nstr
(string-append (substring nstr 0 (+ -1 idx))
delimitr
(substring nstr (+ -1 idx)
(string-length nstr)))))
((and (char-lower-case? (string-ref nstr (+ -1 idx)))
(char-upper-case? (string-ref nstr idx)))
(set! nstr
(string-append (substring nstr 0 idx)
delimitr
(substring nstr idx
(string-length nstr))))))))
(provide 'string-case)))
;;;; Bit order and lamination
;;(define (logical:ones deg) (lognot (ash -1 deg)))
;;; New with SRFI-60
(define (rotate-bit-field n count start end)
(define width (- end start))
(set! count (modulo count width))
(let ((mask (lognot (ash -1 width))))
(define azn (logand mask (arithmetic-shift n (- start))))
(logior (arithmetic-shift
(logior (logand mask (arithmetic-shift azn count))
(arithmetic-shift azn (- count width)))
start)
(logand (lognot (ash mask start)) n))))
;;; Legacy
;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len))
(define (log2-binary-factors n)
(+ -1 (integer-length (logand n (- n)))))
(define (bit-reverse k n)
(do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1))
(k (+ -1 k) (+ -1 k))
(rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m))))
((negative? k) (if (negative? n) (lognot rvs) rvs))))
(define (reverse-bit-field n start end)
(define width (- end start))
(let ((mask (lognot (ash -1 width))))
(define zn (logand mask (arithmetic-shift n (- start))))
(logior (arithmetic-shift (bit-reverse width zn) start)
(logand (lognot (ash mask start)) n))))
(define (integer->list k . len)
(if (null? len)
(do ((k k (arithmetic-shift k -1))
(lst '() (cons (odd? k) lst)))
((<= k 0) lst))
(do ((idx (+ -1 (car len)) (+ -1 idx))
(k k (arithmetic-shift k -1))
(lst '() (cons (odd? k) lst)))
((negative? idx) lst))))
(define (list->integer bools)
(do ((bs bools (cdr bs))
(acc 0 (+ acc acc (if (car bs) 1 0))))
((null? bs) acc)))
(define (booleans->integer . bools)
(list->integer bools))
;;;; SRFI-60 aliases
(define arithmetic-shift ash)
(define bitwise-ior logior)
(define bitwise-xor logxor)
(define bitwise-and logand)
(define bitwise-not lognot)
;;(define bit-count logcount) ;Aliases bit-vector function
;;BITWISE-BIT-COUNT returns negative count for negative inputs.
(define bit-set? logbit?)
(define any-bits-set? logtest)
(define first-set-bit log2-binary-factors)
(define bitwise-merge bitwise-if)
(define @case-aux
(let ((integer-jump-table 1)
(char-jump-table 2))
(lambda (keys actions else-action)
(let ((n (length keys)))
(define (every-key pred)
(let test ((keys keys))
(or (null? keys)
(and (pred (car keys)) (test (cdr keys))))))
(define (jump-table keys)
(let ((minkey (apply min keys))
(maxkey (apply max keys)))
(and (< (- maxkey minkey) (* 4 n))
(let ((actv (make-vector
(+ 2 (- maxkey minkey)) else-action)))
(for-each
(lambda (key action)
(vector-set! actv (+ 1 (- key minkey)) action))
keys actions)
(list integer-jump-table minkey actv)))))
(cond ((< n 5) #f)
((every-key integer?)
(jump-table keys))
((every-key char?)
(let* ((int-keys (map char->integer keys)))
(cond ((jump-table int-keys) =>
(lambda (x)
(cons char-jump-table
(cons (integer->char (cadr x))
(cddr x)))))
(else #f)))))))))
;;;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer):
(define *defmacros* '())
(define (defmacro? m) (and (assq m *defmacros*) #t))
(define defmacro:transformer
(lambda (f)
(procedure->memoizing-macro
(lambda (exp env)
(@copy-tree (apply f (remove-line-numbers! (cdr exp))))))))
(define defmacro:get-destructuring-bind-pairs
(lambda (s e)
(let loop ((s s) (e e) (r '()))
(cond ((pair? s)
(loop (car s) `(car ,e)
(loop (cdr s) `(cdr ,e) r)))
((null? s) r)
((symbol? s) (cons `(,s ,e) r))
(else (error 'destructuring-bind "illegal syntax"))))))
(defsyntax destructuring-bind
(let ((destructuring-bind-transformer
(lambda (s x . ff)
(let ((tmp (gentemp)))
`(let ((,tmp ,x))
(let ,(defmacro:get-destructuring-bind-pairs s tmp)
,@ff))))))
(set! *defmacros*
(acons 'destructuring-bind
destructuring-bind-transformer *defmacros*))
(defmacro:transformer destructuring-bind-transformer)))
(defsyntax defmacro:simple-defmacro
(let ((defmacro-transformer
(lambda (name parms . body)
`(defsyntax ,name
(let ((transformer (lambda ,parms ,@body)))
(set! *defmacros* (acons ',name transformer *defmacros*))
(defmacro:transformer transformer))))))
(set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*))
(defmacro:transformer defmacro-transformer)))
(defmacro:simple-defmacro defmacro (name . body)
(define (expn name pattern body)
(let ((args (gentemp)))
`(defmacro:simple-defmacro ,name ,args
(destructuring-bind ,pattern ,args ,@body))))
(if (pair? name)
(expn (car name) (cdr name) body)
(expn name (car body) (cdr body))))
(define (macroexpand-1 e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a) (set! a (assq a *defmacros*))
(if a (apply (cdr a) (cdr e)) e))
(else e)))
e))
(define (macroexpand e)
(if (pair? e) (let ((a (car e)))
(cond ((symbol? a)
(set! a (assq a *defmacros*))
(if a (macroexpand (apply (cdr a) (cdr e))) e))
(else e)))
e))
(define gentemp
(let ((*gensym-counter* -1))
(lambda ()
(set! *gensym-counter* (+ *gensym-counter* 1))
(string->symbol
(string-append "scm:G" (number->string *gensym-counter*))))))
(define defmacro:eval slib:eval)
(define defmacro:load load)
;; slib:eval-load definition moved to "slib/require.scm"
;;;; Autoloads for SLIB procedures.
(define (trace-all . args) (require 'debug) (apply trace-all args))
(define (track-all . args) (require 'debug) (apply track-all args))
(define (stack-all . args) (require 'debug) (apply stack-all args))
(define (break-all . args) (require 'debug) (apply break-all args))
(define (pretty-print . args) (require 'pretty-print) (apply pretty-print args))
;;; (require 'transcript) would get us SLIB transcript -- not what we want.
(define (transcript-on arg)
(load (in-vicinity (implementation-vicinity)
(string-append "Tscript" (scheme-file-suffix))))
(transcript-on arg))
(define (transcript-off)
(error "No transcript active"))
;;;; Macros.
;;; Trace gets re-defmacroed when tracef autoloads.
(defmacro trace x (cond ((null? x) '()) (else (require 'trace) `(trace ,@x))))
(defmacro track x (cond ((null? x) '()) (else (require 'track) `(track ,@x))))
(defmacro stack x (cond ((null? x) '()) (else (require 'stack) `(stack ,@x))))
(defmacro break x (cond ((null? x) '()) (else (require 'break) `(break ,@x))))
(defmacro defvar (var val)
`(if (not (defined? ,var)) (define ,var ,val)))
(defmacro defconst (name value)
(cond ((list? name) `(defconst ,(car name) (lambda ,(cdr name) ,value)))
(else (cond ((not (slib:eval `(defined? ,name))))
((and (symbol? name) (equal? (slib:eval value)
(slib:eval name))))
(else (error 'trying-to-defconst name
'to-different-value value)))
`(define ,name ,value))))
(defmacro qase (key . clauses)
`(case ,key
,@(map (lambda (clause)
(if (list? (car clause))
(cons (apply
append
(map (lambda (elt)
(case elt
((unquote) '(unquote))
((unquote-splicing) '(unquote-splicing))
(else
(eval (list 'quasiquote (list elt))))))
(car clause)))
(cdr clause))
clause))
clauses)))
(defmacro (casev . args) `(qase ,@args))
(defmacro fluid-let (clauses . body)
(let ((ids (map car clauses))
(temp (gentemp))
(swap (gentemp)))
`(let* ((,temp (list ,@(map cadr clauses)))
(,swap (lambda () (set! ,temp (set! ,ids ,temp)))))
(dynamic-wind
,swap
(lambda () ,@body)
,swap))))
(define (scm:print-binding sexp frame)
(cond ((not (null? (cdr sexp)))
(display "In")
(for-each (lambda (exp) (display #\space) (display exp)) (cdr sexp))
(display ": ")))
(do ((vars (car frame) (cdr vars))
(vals (cdr frame) (cdr vals)))
((not (pair? vars))
(cond ((not (null? vars)) (write vars)
(display " := ") (write (car vals))))
(newline))
(write (car vars)) (display " = ") (write (car vals)) (display "; ")))
(define print-args
(procedure->memoizing-macro
(lambda (sexp env)
(define (fix-list frm)
(cond ((pair? frm) (cons (car frm) (fix-list (cdr frm))))
((null? frm) '())
((symbol? frm) (list frm))
(else '())))
(define frm (car env))
`(scm:print-binding
',sexp
,(cond ((symbol? frm) `(list ',frm ,frm))
((list? frm) `(list ',frm ,@frm))
((pair? frm)
(let ((jlp (fix-list frm)))
`(list ',(if (symbol? (cdr (last-pair frm))) frm jlp)
,@jlp))))))))
(cond
((defined? stack-trace)
;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR
(define error
(letrec ((oerror error)
(nerror
(lambda args
(dynamic-wind
(lambda () (set! error oerror))
(lambda ()
(define cep (current-error-port))
(if (defined? print-call-stack)
(print-call-stack cep))
(perror "ERROR")
(errno 0)
(display "ERROR: " cep)
(if (not (null? args))
(begin (display (car args) cep)
(for-each (lambda (x) (display #\space cep) (write x cep))
(cdr args))))
(newline cep)
(cond ((stack-trace) (newline cep)))
(display " * Breakpoint established: (continue ) to return." cep)
(newline cep) (force-output cep)
(require 'debug) (apply breakpoint args))
(lambda () (set! error nerror))))))
nerror))
(define (user-interrupt . args)
(define cep (current-error-port))
(newline cep)
(if (defined? print-call-stack)
(print-call-stack cep))
(display "ERROR: user interrupt" cep)
(newline cep)
(cond ((stack-trace) (newline cep)))
(display " * Breakpoint established: (continue ) to return." cep)
(newline cep) (force-output cep)
(require 'debug) (apply breakpoint args))
))
(cond ((and (inexact? (string->number "0.0")) (not (defined? exp)))
(or (and (defined? usr:lib)
(usr:lib "m")
(load (in-vicinity (implementation-vicinity) "Transcen")
(usr:lib "m")))
(load (in-vicinity (implementation-vicinity) "Transcen"))))
(else
(define (infinite? z) #f)
(define finite? number?)
(define inexact->exact identity)
(define exact->inexact identity)
(define round->exact identity)
(define floor->exact identity)
(define ceiling->exact identity)
(define truncate->exact identity)
(define expt integer-expt)))
(define (numerator q)
(if (not (rational? q)) (error 'numerator q))
(do ((num q (* 2 num)))
((integer? num) num)))
(define (denominator q)
(if (not (rational? q)) (error 'denominator q))
(do ((num q (* 2 num))
(den (- q q -1) (* 2 den)))
((integer? num) den)))
;@
(define (integer-log base k)
(define (ilog m b k)
(cond ((< k b) k)
(else
(set! n (+ n m))
(let ((q (ilog (+ m m) (* b b) (quotient k b))))
(cond ((< q b) q)
(else (set! n (+ m n))
(quotient q b)))))))
(define n 1)
(define (eigt? k j) (and (exact? k) (integer? k) (> k j)))
(cond ((not (and (eigt? base 1) (eigt? k 0)))
(slib:error 'integer-log base k))
((< k base) 0)
(else (ilog 1 base (quotient k base)) n)))
;;;; http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/math/isqrt/isqrt.txt
;;; Akira Kurihara
;;; School of Mathematics
;;; Japan Women's University
;@
(define integer-sqrt
(let ((table '#(0
1 1 1
2 2 2 2 2
3 3 3 3 3 3 3
4 4 4 4 4 4 4 4 4))
(square (lambda (x) (* x x))))
(lambda (n)
(define (isqrt n)
(if (> n 24)
(let* ((len/4 (quotient (- (integer-length n) 1) 4))
(top (isqrt (ash n (* -2 len/4))))
(init (ash top len/4))
(q (quotient n init))
(iter (quotient (+ init q) 2)))
(cond ((odd? q) iter)
((< (remainder n init) (square (- iter init))) (- iter 1))
(else iter)))
(vector-ref table n)))
(if (and (exact? n) (integer? n) (not (negative? n)))
(isqrt n)
(slib:error 'integer-sqrt n)))))
(if (defined? array?)
(begin
(define (array-null? array)
(zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd)))
(array-shape array)))))
(define (create-array prot . args)
(if (array-null? prot)
(dimensions->uniform-array args (array-prototype prot))
(dimensions->uniform-array args (array-prototype prot)
(apply array-ref prot
(map car (array-shape prot))))))
(define make-array create-array)
(define (list->array rank proto lst)
(list->uniform-array rank (array-prototype proto) lst))
(define (vector->array vect prototype . dimensions)
(define vdx (vector-length vect))
(if (not (eqv? vdx (apply * dimensions)))
(slib:error 'vector->array vdx '<> (cons '* dimensions)))
(let ((ra (apply make-array prototype dimensions)))
(define (v2ra dims idxs)
(cond ((null? dims)
(set! vdx (+ -1 vdx))
(apply array-set! ra (vector-ref vect vdx) (reverse idxs)))
(else
(do ((idx (+ -1 (car dims)) (+ -1 idx)))
((negative? idx) vect)
(v2ra (cdr dims) (cons idx idxs))))))
(v2ra dimensions '())
ra))
(define (array->vector ra)
(define dims (array-dimensions ra))
(let* ((vdx (apply * dims))
(vect (make-vector vdx)))
(define (ra2v dims idxs)
(if (null? dims)
(let ((val (apply array-ref ra (reverse idxs))))
(set! vdx (+ -1 vdx))
(vector-set! vect vdx val)
vect)
(do ((idx (+ -1 (car dims)) (+ -1 idx)))
((negative? idx) vect)
(ra2v (cdr dims) (cons idx idxs)))))
(ra2v dims '())))
(define (make-uniform-wrapper prot)
(if (string? prot) (set! prot (string->number prot)))
(if prot
(lambda opt (if (null? opt)
(list->uniform-array 1 prot '())
(list->uniform-array 0 prot (car opt))))
vector))
(define Ac64 (make-uniform-wrapper "+64i"))
(define Ac32 (make-uniform-wrapper "+32i"))
(define Ar64 (make-uniform-wrapper "64."))
(define Ar32 (make-uniform-wrapper "32."))
(define As64 (make-uniform-wrapper -64))
(define As32 (make-uniform-wrapper -32))
(define As16 (make-uniform-wrapper -16))
(define As8 (make-uniform-wrapper -8))
(define Au64 (make-uniform-wrapper 64))
(define Au32 (make-uniform-wrapper 32))
(define Au16 (make-uniform-wrapper 16))
(define Au8 (make-uniform-wrapper 8))
(define At1 (make-uniform-wrapper #t))
;;; New SRFI-58 names
;; flonums
(define A:floC128b Ac64)
(define A:floC64b Ac64)
(define A:floC32b Ac32)
(define A:floC16b Ac32)
(define A:floR128b Ar64)
(define A:floR64b Ar64)
(define A:floR32b Ar32)
(define A:floR16b Ar32)
;; decimal flonums
(define A:floQ128d Ar64)
(define A:floQ64d Ar64)
(define A:floQ32d Ar32)
;; fixnums
(define A:fixZ64b As64)
(define A:fixZ32b As32)
(define A:fixZ16b As16)
(define A:fixZ8b As8)
(define A:fixN64b Au64)
(define A:fixN32b Au32)
(define A:fixN16b Au16)
(define A:fixN8b Au8)
(define A:bool At1)
(define (array-shape a)
(let ((dims (array-dimensions a)))
(if (pair? dims)
(map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
dims)
dims)))
(define array=? equal?)
(provide 'srfi-47)
(provide 'srfi-58)
(provide 'srfi-63)
))
(define (alarm-interrupt) (alarm 0))
(if (defined? setitimer)
(begin
(define profile-alarm #f)
(define (profile-alarm-interrupt) (profile-alarm 0))
(define virtual-alarm #f)
(define (virtual-alarm-interrupt) (virtual-alarm 0))
(define milli-alarm #f)
(let ((make-alarm
(lambda (sym)
(and (setitimer sym 0 0) ;DJGPP supports only REAL and PROFILE
(lambda (value . interval)
(cadr
(setitimer sym value
(if (pair? interval) (car interval) 0))))))))
(set! profile-alarm (make-alarm 'profile))
(set! virtual-alarm (make-alarm 'virtual))
(set! milli-alarm (make-alarm 'real)))))
;;;; Initialize statically linked add-ons
(cond ((defined? scm_init_extensions)
(scm_init_extensions)
(if (defined? *features*) (set! slib:features *features*))
(set! scm_init_extensions #f)))
;;; Use *argv* instead of (program-arguments), to allow option
;;; processing to be done on it. "ScmInit.scm" must
;;; (set! *argv* (program-arguments))
;;; if it wants to alter the arguments which BOOT-TAIL processes.
(define *argv* #f)
(if (not (defined? *syntax-rules*))
(define *syntax-rules* #f))
(if (not (defined? *interactive*))
(define *interactive* #f))
(define (boot-tail dumped?)
(cond ((not *argv*)
(set! *argv* (program-arguments))
(cond (dumped?
(set-vicinities! dumped?)
(verbose (if (and (isatty? (current-input-port))
(isatty? (current-output-port)))
(if (<= (length *argv*) 1) 2 1)
0))))
(cond ((provided? 'getopt)
(set! *optind* 1)
(set! *optarg* #f)))))
;;; This loads the user's initialization file, or files named in
;;; program arguments.
(or *script*
(eq? (software-type) 'THINKC)
(member "-no-init-file" (program-arguments))
(member "--no-init-file" (program-arguments))
(try-load (in-vicinity (or (home-vicinity) (user-vicinity))
(string-append "ScmInit") (scheme-file-suffix))
*load-reader*)
(errno 0))
;; Include line numbers in loaded code.
(if (defined? read-numbered)
(set! *load-reader* read-numbered))
(cond
((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
(require 'getopt)
;;; (else
;;; (define *optind* 1)
;;; (define getopt:opt #f)
;;; (define (getopt optstring) #f))
(let* ((simple-opts "muvqibs")
(arg-opts '("a kbytes" "-version" "-help"
"-no-symbol-case-fold"
"no-init-file" "-no-init-file" "p number"
"h feature" "r feature" "d filename"
"f filename" "l filename"
"c string" "e string" "o filename"))
(opts (apply string-append ":" simple-opts
(map (lambda (o)
(string-append (string (string-ref o 0)) ":"))
arg-opts)))
(didsomething #f)
(moreopts #t)
(exe-name (symbol->string (scheme-implementation-type)))
(up-name (apply string (map char-upcase (string->list exe-name)))))
(define (do-thunk thunk)
(if *interactive*
(thunk)
(let ((complete #f))
(dynamic-wind
(lambda () #f)
(lambda ()
(thunk)
(set! complete #t))
(lambda ()
(if (not complete) (close-port (current-input-port))))))))
(define (do-string-arg)
(require 'string-port)
(do-thunk
(lambda ()
((if *syntax-rules* macro:eval eval)
(call-with-input-string
(string-append "(begin " *optarg* ")")
read))))
(set! didsomething #t))
(define (do-load file)
(do-thunk
(lambda ()
(cond (*syntax-rules* (require 'macro) (macro:load file))
(else (load file)))))
(set! didsomething #t))
(define (usage preopt opt postopt success?)
(define cep (if success? (current-output-port) (current-error-port)))
(define indent (make-string 6 #\space))
(define i 3)
(cond ((char? opt) (set! opt (string opt)))
;;((symbol? opt) (set! opt (symbol->string opt)))
)
(display (string-append preopt opt postopt) cep)
(newline cep)
(display (string-append "Usage: "
exe-name
" [-a kbytes] [-" simple-opts "]") cep)
(for-each
(lambda (o)
(display (string-append " [-" o "]") cep)
(set! i (+ 1 i))
(cond ((zero? (modulo i 5)) (newline cep) (display indent cep))))
(cdr arg-opts))
(display " [-- | -s | -] [file] [args...]" cep) (newline cep)
(if success? (display success? cep) (quit #f)))
;; -a int => ignore (handled by scm_init_from_argv)
;; -c str => (eval str)
;; -e str => (eval str)
;; -d str => (require 'databases) (open-database str)
;; -f str => (load str)
;; -l str => (load str)
;; -r sym => (require sym)
;; -h sym => (provide sym)
;; -o str => (dump str)
;; -p int => (verbose int)
;; -m => (set! *syntax-rules* #t)
;; -u => (set! *syntax-rules* #f)
;; -v => (verbose 3)
;; -q => (verbose 0)
;; -i => (set! *interactive* #t)
;; -b => (set! *interactive* #f)
;; -s => set argv, don't execute first one
;; --no-symbol-case-fold => symbols preserve character case
;; -no-init-file => don't load init file
;; --no-init-file => don't load init file
;; --help => print and exit
;; --version => print and exit
;; -- => last option
(let loop ((option (getopt-- opts)))
(case option
((#\a)
(cond ((> *optind* 3)
(usage "scm: option `-" getopt:opt "' must be first" #f))
((or (not (exact? (string->number *optarg*)))
(not (<= 1 (string->number *optarg*) 10000)))
;; This size limit should match scm.c ^^
(usage "scm: option `-" getopt:opt
(string-append *optarg* "' unreasonable") #f))))
((#\e #\c) (do-string-arg)) ;sh-like
((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*)
((#\d) (require 'databases)
(open-database *optarg*))
((#\o) (require 'dump)
(if (< *optind* (length *argv*))
(dump *optarg* #t)
(dump *optarg*)))
((#\r) (do-thunk (lambda ()
(if (and (= 1 (string-length *optarg*))
(char-numeric? (string-ref *optarg* 0)))
(case (string-ref *optarg* 0)
((#\2) (require 'r2rs))
((#\3) (require 'r3rs))
((#\4) (require 'r4rs))
((#\5) (require 'r5rs)
(set! *syntax-rules* #t))
(else (require (string->symbol *optarg*))))
(require (string->symbol *optarg*))))))
((#\h) (do-thunk (lambda () (provide (string->symbol *optarg*)))))
((#\p) (verbose (string->number *optarg*)))
((#\q) (verbose 0))
((#\v) (verbose 3))
((#\i) (set! *interactive* #t) ;sh-like
(verbose (max 2 (verbose))))
((#\b) (set! didsomething #t)
(set! *interactive* #f))
((#\s) (set! moreopts #f) ;sh-like
(set! didsomething #t)
(set! *interactive* #t))
((#\m) (set! *syntax-rules* #t))
((#\u) (set! *syntax-rules* #f))
((#\n) (if (not (string=? "o-init-file" *optarg*))
(usage "scm: unrecognized option `-n" *optarg* "'" #f)))
((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f))
((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f))
((#f) (set! moreopts #f) ;sh-like
(cond ((and (< *optind* (length *argv*))
(string=? "-" (list-ref *argv* *optind*)))
(set! *optind* (+ 1 *optind*)))))
(else
(or (cond ((not (string? option)) #f)
((string-ci=? "no-init-file" option))
((string-ci=? "no-symbol-case-fold" option))
((string-ci=? "version" option)
(display
(string-append exe-name " "
(scheme-implementation-version)
"
Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
"
up-name
" may be distributed under the terms of"
" the GNU General Public Licence;
certain other uses are permitted as well."
" For details, see the file `COPYING',
which is included in the "
up-name " distribution.
There is no warranty, to the extent permitted by law.
"
))
(cond ((execpath) =>
(lambda (path)
(display " This executable was loaded from ")
(write path)
(newline))))
(quit #t))
((string-ci=? "help" option)
(usage "This is "
up-name
", a Scheme interpreter."
(let ((sihp (scheme-implementation-home-page)))
(if sihp
(string-append "Latest info: " sihp "
")
"")))
(quit #t))
(else #f))
(usage "scm: unknown option `--" option "'" #f))))
(cond ((and moreopts (< *optind* (length *argv*)))
(loop (getopt-- opts)))
((< *optind* (length *argv*)) ;No more opts
(set! *argv* (list-tail *argv* *optind*))
(set! *optind* 1)
(cond ((and (not didsomething) *script*)
(do-load *script*)
(set! *optind* (+ 1 *optind*))))
(cond ((and (> (verbose) 2)
(not (= (+ -1 *optind*) (length *argv*))))
(display "scm: extra command arguments unused:"
(current-error-port))
(for-each (lambda (x) (display (string-append " " x)
(current-error-port)))
(list-tail *argv* (+ -1 *optind*)))
(newline (current-error-port)))))
((and (not didsomething) (= *optind* (length *argv*)))
(set! *interactive* #t)))))
(cond ((not *interactive*) (quit))
((and *syntax-rules* (not (provided? 'macro)))
(require 'repl)
(require 'macro)
(let* ((oquit quit))
(set! quit (lambda () (repl:quit)))
(set! exit quit)
(repl:top-level macro:eval)
(oquit))))
;;otherwise, fall into natural SCM repl.
)
(else (errno 0)
(set! *interactive* #t)
(for-each load (cdr (program-arguments))))))
scm-5e5/requires.scm 0000644 0017052 0001750 00000001406 10722100222 012362 0 ustar tb tb ;;; "require.scm" Trampoline to slib/require.scm
(define library-vicinity
(let* ((vl (case (software-type)
((amiga) '(#\: #\/))
((ms-dos windows atarist os/2) '(#\\ #\/))
((macos thinkc) '(#\:))
((nosve) '(#\: #\.))
((unix coherent plan9) '(#\/))
((vms) '(#\: #\]))))
(iv (implementation-vicinity))
(vc (and (positive? (string-length iv))
(string-ref iv (+ -1 (string-length iv)))))
(vs (if (memv vc vl) (string vc) "/"))
(lv (let loop ((pos (+ -2 (string-length iv))))
(cond ((or (< pos 0) (not vs))
(string-append iv ".." vs "slib" vs))
((memv (string-ref iv pos) vl)
(string-append (substring iv 0 (+ 1 pos)) "slib" vs))
(else (loop (- pos 1)))))))
(lambda () lv)))
scm-5e5/scm.h 0000644 0017052 0001750 00000124733 10750224617 011003 0 ustar tb tb /* "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((char *s, FILE *p)); */
/* sizet (*fwrite)P((char *s, sizet siz, sizet num, 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(1)
# define SCM_ENV_PROCNAME MAKINUM(2)
#endif
#define SCM_ENV_DOC MAKINUM(3)
#define SCM_ENV_ANNOTATION MAKINUM(4)
#define SCM_ENV_CONSTANT MAKINUM(5)
#define SCM_ENV_SYNTAX MAKINUM(6)
#define SCM_ENV_END MAKINUM(7)
#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_Vbool:case tc7_VfixN8:case tc7_VfixZ8:\
case tc7_VfixN16:case tc7_VfixZ16:case tc7_VfixN32:case tc7_VfixZ32:\
case tc7_VfloR32:case tc7_VfloC32:case tc7_VfloR64:case tc7_VfloC64
#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_Vbool 21
/* 23 */
#define tc7_VfixN8 29
#define tc7_VfixZ8 31
#define tc7_VfixN16 37
#define tc7_VfixZ16 39
#define tc7_VfixN32 45
#define tc7_VfixZ32 47
#define tc7_VfloR32 53
#define tc7_VfloC32 55
#define tc7_VfloR64 61
#define tc7_VfloC64 63
/* 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 NUM_PROTECTS 23
/* 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 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 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 lmax P((SCM x, SCM y));
SCM_EXPORT SCM lmin 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 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 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 iint2str P((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, long 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 lgetenv 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_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 unsigned long scm_addr P((SCM args, const char *name));
SCM_EXPORT unsigned long 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 big2dbl 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 unsigned int 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 modes));
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 1
#define ARG1 2
#define ARG2 3
#define ARG3 4
#define ARG4 5
#define ARG5 6
/* following must match entry indexes in errmsgs[] */
#define WNA 7
#define OVFLOW 8
#define OUTOFRANGE 9
#define NALLOC 10
#define THRASH 11
#define EXIT 12
#define HUP_SIGNAL 13
#define INT_SIGNAL 14
#define FPE_SIGNAL 15
#define BUS_SIGNAL 16
#define SEGV_SIGNAL 17
#define ALRM_SIGNAL 18
#define VTALRM_SIGNAL 19
#define PROF_SIGNAL 20
#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-5e5/COPYING.LESSER 0000644 0017052 0001750 00000016731 10746015031 012066 0 ustar tb tb GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public 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.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.
scm-5e5/continue.c 0000644 0017052 0001750 00000017571 10750224111 012026 0 ustar tb tb /* "continue.c" Scheme Continuations for C.
* 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 */
/* "setjump.h" contains definitions for the `other' field (type
CONTINUATION_OTHER) the struct Continuation. "setjump.h" must
#include "continue.h". CONTINUATION_OTHER defaults to `long' */
#define IN_CONTINUE_C
#ifdef USE_CONTINUE_H
# include "continue.h"
#else
# include "setjump.h"
#endif
/* For platforms with short integers, we use thrown_value instead of
the value returned from setjump so that any (long) value can be
returned. */
#ifdef SHORT_INT
long thrown_value;
#endif
/* stack_size() returns the number of units of size STACKITEM which
fit between @var{start} and the current top of stack. No check is
done in this routine to ensure that @var{start} is actually in the
current stack segment. */
long stack_size(start)
STACKITEM *start;
{
STACKITEM stack;
#ifdef STACK_GROWS_UP
return &stack - start;
#else
return start - &stack;
#endif /* def STACK_GROWS_UP */
}
/* make_root_continuation() allocates (malloc) storage for a
CONTINUATION near the current extent of stack. This newly
allocated CONTINUATION is returned if successful, 0 if not. After
make_root_continuation() returns, the calling routine still needs
to `setjump(new_continuation->jmpbuf)' in order to complete the
capture of this continuation. */
#ifndef __ia64__
CONTINUATION *make_root_continuation(stack_base)
STACKITEM *stack_base;
{
CONTINUATION *cont;
cont = (CONTINUATION *)malloc(sizeof(CONTINUATION));
if (!cont) return 0;
cont->length = 0;
cont->stkbse = stack_base;
cont->parent = cont;
return cont;
}
/* make_continuation() allocates storage for the current continuation,
copying (or encapsulating) the stack state from parent_cont->stkbse
to the current top of stack. The newly allocated CONTINUATION is
returned if successful, 0 if not. After make_continuation()
returns, the calling routine still needs to
`setjump(new_continuation->jmpbuf)' in order to complete the capture
of this continuation. */
/* Note: allocating local (stack) storage for the CONTINUATION would
not work; Think about it. */
CONTINUATION *make_continuation(parent_cont)
CONTINUATION *parent_cont;
{
CONTINUATION *cont;
# ifdef CHEAP_CONTINUATIONS
cont = (CONTINUATION *)malloc(sizeof(CONTINUATION));
if (!cont) return 0;
cont->length = 0;
cont->stkbse = parent_cont->stkbse;
# else
long j;
register STACKITEM *src, *dst;
FLUSH_REGISTER_WINDOWS;
j = stack_size(parent_cont->stkbse);
cont = (CONTINUATION *)malloc((sizeof(CONTINUATION) + j*sizeof(STACKITEM)));
if (!cont) return 0;
cont->length = j;
cont->stkbse = parent_cont->stkbse;
src = cont->stkbse;
# ifdef STACK_GROWS_UP
src += parent_cont->length;
# else
src -= parent_cont->length + cont->length;
# endif/* ndef STACK_GROWS_UP */
dst = (STACKITEM *)(cont + 1);
for (j = cont->length; 0 <= --j; ) *dst++ = *src++;
# endif /* ndef CHEAP_CONTINUATIONS */
cont->parent = parent_cont;
return cont;
}
#endif
/* free_continuation() is trivial, but who knows what the future
holds. */
void free_continuation(cont)
CONTINUATION *cont;
{
free(cont);
}
/* Final routine involved in throw()ing to a continuation. After
ensuring that there is sufficient room on the stack for the saved
continuation, dynthrow() copies the continuation onto the stack and
longjump()s into it. The routine does not return. */
/* If you use conservative GC and your Sparc(SUN-4) heap is growing
out of control:
You are experiencing a GC problem peculiar to the Sparc. The
problem is that SCM doesn't know how to clear register windows.
Every location which is not reused still gets marked at GC time.
This causes lots of stuff which should be collected to not be.
This will be a problem with any *conservative* GC until we find
what instruction will clear the register windows. This problem is
exacerbated by using lots of make-CONTINUATION.
Possibly adding the following before the thrown_value = val; line
might help to clear out unused stack above the continuation (a
small part of the problem).
#ifdef sparc
bzero((void *)&a, sizeof(STACKITEM) *
(((STACKITEM *)&a) - (dst - cont->length)))
#endif
Let me know if you try it. */
/* SCM_GROWTH is how many `long's to grow the stack by when we need room. */
#define SCM_GROWTH 100
#ifndef __ia64__
void dynthrow(a)
long *a;
{
register CONTINUATION *cont = (CONTINUATION *)(a[0]);
long val = a[1];
# ifndef CHEAP_CONTINUATIONS
register long j;
register STACKITEM *src, *dst = cont->stkbse;
# ifdef STACK_GROWS_UP
# ifndef hpux
if (a[2] && (a - ((long *)a[3]) < SCM_GROWTH))
puts("grow_throw: check if long growth[]; being optimized out");
# endif
/* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
if (PTR_GE(dst + (cont->length), (STACKITEM *)&a)) grow_throw(a);
# else
# ifndef hpux
if (a[2] && (((long *)a[3]) - a < SCM_GROWTH))
puts("grow_throw: check if long growth[]; being optimized out");
# endif
/* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
dst -= cont->length;
if (PTR_LE(dst, (STACKITEM *)&a)) grow_throw(a);
# endif/* def STACK_GROWS_UP */
FLUSH_REGISTER_WINDOWS;
src = (STACKITEM *)(cont + 1);
for (j = cont->length;0 <= --j;) *dst++ = *src++;
# endif /* ndef CHEAP_CONTINUATIONS */
# ifdef SHORT_INT
thrown_value = val;
longjump(cont->jmpbuf, 1);
# else
longjump(cont->jmpbuf, val);
# endif
}
/* grow_throw() grows the stack by SCM_GROWTH long words. If the
"sizeof growth" assignment is not sufficient to restrain your
overly optimistic compiler, the stack will grow by much less and
grow_throw() and dynthrow() will waste time calling each other. To
fix this you will have to compile grow_throw() in a separate file
so the compiler won't be able to guess that the growth array isn't
all used. */
# ifndef CHEAP_CONTINUATIONS
void grow_throw(a) /* Grow the stack so that there is room */
long *a; /* to copy in the continuation. Then */
{ /* retry the throw. */
long growth[SCM_GROWTH];
growth[0] = a[0];
growth[1] = a[1];
growth[2] = a[2] + 1;
growth[3] = (long) a;
growth[SCM_GROWTH-1] = sizeof growth;
dynthrow(growth);
}
# endif /* ndef CHEAP_CONTINUATIONS */
#endif
/* throw_to_continuation() restores the stack in effect when
@var{cont} was made and resumes @var{cont}'s processor state. If
the stack cannot be resotred because @var{cont} and @var{root_cont}
do not have the same stkbase, @code{throw_to_continuation()
returns. */
/* Note: If 2 or more @var{cont}s share a parent continuation and if
the values of stack allocated variables in that parent continuation
are changed, the results are unspecified. This is because the
parent continuation may or may not be reloaded, depending on what
other throws have intervened. */
void throw_to_continuation(cont, val, root_cont)
CONTINUATION *cont;
long val;
CONTINUATION *root_cont;
{
long a[3];
a[0] = (long)cont;
a[1] = val;
a[2] = 0;
if (cont->stkbse != root_cont->stkbse)
return; /* Stale continuation */
dynthrow(a);
}
scm-5e5/scmhob.h 0000644 0017052 0001750 00000011171 10750225413 011456 0 ustar tb tb /* "scmhob.h" is a header file for scheme source compiled with hobbit5x
* Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997 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
* .
*/
/* Author: Tanel Tammet */
#include "scm.h"
#define STBL_VECTOR_SET(v,k,o) (v[((long)INUM(k))] = o)
#define STBL_VECTOR_REF(v,k) (v[((long)INUM(k))])
#define CHAR_LESSP(x,y) ((ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F)
#define CHAR_LEQP(x,y) ((ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F)
#define CHCI_EQ(x,y) ((upcase[ICHR(x)]==upcase[ICHR(y)]) ? BOOL_T : BOOL_F)
#define CHCI_LESSP(x,y) ((upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F)
#define CHCI_LEQP(x,y) ((upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F)
#define CHAR_ALPHAP(chr) ((isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F)
#define CHAR_NUMP(chr) ((isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F)
#define CHAR_WHITEP(chr) ((isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F)
#define CHAR_UPPERP(chr) ((isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F)
#define CHAR_LOWERP(chr) ((isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F)
#define CHAR2INT(chr) MAKINUM(ICHR(chr))
#define INT2CHAR(n) MAKICHR(INUM(n))
#define CHAR_UPCASE(chr) MAKICHR(upcase[ICHR(chr)])
#define CHAR_DOWNCASE(chr) MAKICHR(downcase[ICHR(chr)])
#define ST_LENGTH(str) MAKINUM(LENGTH(str))
#define ST_REF(str,k) MAKICHR(CHARS(str)[INUM(k)])
#define VECTOR_LENGTH(v) MAKINUM(LENGTH(v))
#ifdef FLOATS
#include
#endif
#ifdef BIGDIG
#define PRE_TRANSC_FUN(x) (INUMP(x) ? (double) INUM(x) : (REALP(x) ? (double) REALPART(x) : (double) big2dbl(x)))
#else
#define PRE_TRANSC_FUN(x) (INUMP(x) ? (double) INUM(x) : (double) REALPART(x))
#endif
#define SIN_FUN(x) (makdbl( sin( PRE_TRANSC_FUN(x)), 0.0))
#define COS_FUN(x) (makdbl( cos( PRE_TRANSC_FUN(x)), 0.0))
#define TAN_FUN(x) (makdbl( tan( PRE_TRANSC_FUN(x)), 0.0))
#define ASIN_FUN(x) (makdbl( asin( PRE_TRANSC_FUN(x)), 0.0))
#define ACOS_FUN(x) (makdbl( acos( PRE_TRANSC_FUN(x)), 0.0))
#define ATAN_FUN(x) (makdbl( atan( PRE_TRANSC_FUN(x)), 0.0))
#define SINH_FUN(x) (makdbl( sinh( PRE_TRANSC_FUN(x)), 0.0))
#define COSH_FUN(x) (makdbl( cosh( PRE_TRANSC_FUN(x)), 0.0))
#define TANH_FUN(x) (makdbl( tanh( PRE_TRANSC_FUN(x)), 0.0))
#define ASINH_FUN(x) (makdbl( asinh( PRE_TRANSC_FUN(x)), 0.0))
#define ACOSH_FUN(x) (makdbl( acosh( PRE_TRANSC_FUN(x)), 0.0))
#define ATANH_FUN(x) (makdbl( atanh( PRE_TRANSC_FUN(x)), 0.0))
#define SQRT_FUN(x) (makdbl( sqrt( PRE_TRANSC_FUN(x)), 0.0))
#define EXPT_FUN(x,y) (makdbl( pow(( PRE_TRANSC_FUN(x)), ( PRE_TRANSC_FUN(y))), 0.0))
#define EXP_FUN(x) (makdbl( exp( PRE_TRANSC_FUN(x)), 0.0))
#define LOG_FUN(x) (makdbl( log( PRE_TRANSC_FUN(x)), 0.0))
#define ABS_FUN(x) (makdbl( fabs( PRE_TRANSC_FUN(x)), 0.0))
#define EX2IN_FUN(x) (makdbl( PRE_TRANSC_FUN(x), 0.0))
#define FLOOR_FUN(x) (makdbl( floor( PRE_TRANSC_FUN(x)), 0.0))
#define CEILING_FUN(x) (makdbl( ceil( PRE_TRANSC_FUN(x)), 0.0))
#define TRUNCATE_FUN(x) (makdbl( ltrunc( PRE_TRANSC_FUN(x)), 0.0))
#define ROUND_FUN(x) (makdbl(round( PRE_TRANSC_FUN(x)), 0.0))
/* the following defs come from the #ifdef HOBBIT part of scm.h */
#define SBOOL(x) ((x) ? BOOL_T : BOOL_F)
#define BOOLEAN_P(x) ((x)==BOOL_T || (x)==BOOL_F)
#define CHAR_P ICHRP
#define SYMBOL_P(x) (ISYMP(x) || (!(IMP(x)) && SYMBOLP(x)))
#define VECTOR_P(x) (!(IMP(x)) && VECTORP(x))
#define PAIR_P(x) (!(IMP(x)) && CONSP(x))
#define NUMBER_P INUMP
#define INTEGER_P INUMP
#define STRING_P(x) (!(IMP(x)) && STRINGP(x))
#define NULL_P NULLP
#define ZERO_P(x) ((x)==INUM0)
#define POSITIVE_P(x) ((x) > INUM0)
#define NEGATIVE_P(x) ((x) < INUM0)
#define NOT(x) ((x)==BOOL_F ? BOOL_T : BOOL_F)
#define SET_CAR(x,y) (CAR(x) = (SCM)(y))
#define SET_CDR(x,y) (CDR(x) = (SCM)(y))
#define VECTOR_SET(v,k,o) (VELTS(v)[((long)INUM(k))] = o)
#define VECTOR_REF(v,k) (VELTS(v)[((long)INUM(k))])
#define GLOBAL(x) (*(x))
#define append2(lst1,lst2) (append(cons2(lst1,lst2,EOL)))
#define procedure_pred_(x) (BOOL_T==procedurep(x))
/* new for hobbit5 - scm5 */
/*
SCM intp(SCM);
SCM eqv(SCM,SCM);
*/
scm-5e5/split.scm 0000644 0017052 0001750 00000004321 10750220563 011671 0 ustar tb tb ;;;; "split.scm", split input, output, and error streams into windows.
;; Copyright (C) 1993, 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.
(require 'curses)
(define *stdscr* (initscr))
(nocbreak)
(echo)
(nl)
(define subwindow-height (max 2 (quotient (output-port-height) 5)))
(define *output-window*
(newwin (- (output-port-height) (* 2 subwindow-height) 2)
(output-port-width)
0
0))
(define *input-window*
(newwin subwindow-height
(output-port-width)
(- (output-port-height) (* 2 subwindow-height) 1)
0))
(define *error-window*
(newwin subwindow-height
(output-port-width)
(- (output-port-height) subwindow-height)
0))
(wmove *stdscr* (- (output-port-height) subwindow-height 1) 0)
(wstandout *stdscr*)
(display (make-string (output-port-width) #\-) *stdscr*)
(wmove *stdscr* (- (output-port-height) (* 2 subwindow-height) 2) 0)
(display (make-string (output-port-width) #\-) *stdscr*)
(wstandend *stdscr*)
(touchwin *stdscr*)
(force-output *stdscr*)
(scrollok *output-window* #t)
(scrollok *input-window* #t)
(scrollok *error-window* #t)
(define *default-output-port* (set-current-output-port *output-window*))
(define *default-input-port* (set-current-input-port *input-window*))
(define *default-error-port* (set-current-error-port *error-window*))
(leaveok *output-window* #t)
(leaveok *input-window* #f)
(leaveok *error-window* #t)
(define (unsplit)
(cond ((endwin)
(set-current-output-port *default-output-port*)
(set-current-input-port *default-input-port*)
(set-current-error-port *default-error-port*))))
scm-5e5/r4rstest.scm 0000644 0017052 0001750 00000112015 10750211043 012321 0 ustar tb tb ;;;;"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 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 - 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 4.0)
(test 4 inexact->exact 4)
(test 4 inexact->exact 4.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)
(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))
(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")))))
(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 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))
(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 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-5e5/Tscript.scm 0000644 0017052 0001750 00000004635 10750217336 012202 0 ustar tb tb ;;;; "Tscript.scm" transcript-on and transcript-off.
;; Copyright (C) 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: Radey Shouman
(define transcript-on #f)
(define transcript-off #f)
(let ((*transcript-stack* '()))
(define (trans-on filename)
(let ((trans (open-output-file filename))
(inp (current-input-port))
(outp (current-output-port))
(errp (current-error-port)))
(define (clone-port port)
(make-soft-port
(vector (and (output-port? port)
(lambda (c)
(write-char c port)
(write-char c trans)))
(and (output-port? port)
(lambda (s)
(display s port)
(display s trans)))
(and (output-port? port)
(lambda ()
(force-output port)
(force-output trans)))
(and (input-port? port)
(lambda ()
(let ((c (read-char port)))
(if (eof-object? c)
(close-output-port trans)
(write-char c trans))
c)))
(lambda ()
(close-port port)))
(if (input-port? port)
(if (output-port? port) "r+" "r")
"w")))
(set! *transcript-stack*
(cons (list trans
(current-input-port)
(current-output-port)
(current-error-port))
*transcript-stack*))
(set-current-input-port (clone-port inp))
(set-current-output-port (clone-port outp))
(set-current-error-port (clone-port errp))))
(define (trans-off)
(cond ((pair? *transcript-stack*)
(apply (lambda (trans inp outp errp)
(close-port trans)
(set-current-input-port inp)
(set-current-output-port outp)
(set-current-error-port errp))
(car *transcript-stack*))
(set! *transcript-stack* (cdr *transcript-stack*)))
(else
(error "No transcript active"))))
(set! transcript-on trans-on)
(set! transcript-off trans-off))
(provide 'transcript)
scm-5e5/setjump.mar 0000644 0017052 0001750 00000002207 10647032750 012227 0 ustar tb tb .title setjump and longjump
; The VAX C runtime library uses the $unwind utility for
; implementing longjmp. That fails if your program does not
; follow normal stack decipline. This is a dirty implementation
; of setjmp and longjmp that does not have that problem. The
; names longjmp and setjmp are avoided so that the code can be
; linked with the vax c runtime library without name clashes.
; This code was contributed by an anonymous reviewer from
; comp.sources.reviewed.
.entry setjump,^M
movl 4(ap),r0
movq r2,(r0)+
movq r4,(r0)+
movq r6,(r0)+
movq r8,(r0)+
movq r10,(r0)+
movl fp,(r0)+
movo 4(fp),(r0)+
movq 20(fp),(r0)
clrl r0
ret
.entry longjump,^M
movl 4(ap),r0
movq (r0)+,r2
movq (r0)+,r4
movq (r0)+,r6
movq (r0)+,r8
movq (r0)+,r10
movl (r0)+,r1
movo (r0)+,4(r1)
movq (r0),20(r1)
movl 8(ap),r0
movl r1,fp
ret
.end
scm-5e5/unexec.c 0000644 0017052 0001750 00000103665 10750241211 011471 0 ustar tb tb /* Copyright (C) 1985,86,87,88,92,93,94 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
. */
/*
* unexec.c - Convert a running program into an a.out file.
*
* Author: Spencer W. Thomas
* Computer Science Dept.
* University of Utah
* Date: Tue Mar 2 1982
* Modified heavily since then.
*
* Synopsis:
* unexec (new_name, a_name, data_start, bss_start, entry_address)
* char *new_name, *a_name;
* unsigned data_start, bss_start, entry_address;
*
* Takes a snapshot of the program and makes an a.out format file in the
* file named by the string argument new_name.
* If a_name is non-NULL, the symbol table will be taken from the given file.
* On some machines, an existing a_name file is required.
*
* The boundaries within the a.out file may be adjusted with the data_start
* and bss_start arguments. Either or both may be given as 0 for defaults.
*
* Data_start gives the boundary between the text segment and the data
* segment of the program. The text segment can contain shared, read-only
* program code and literal data, while the data segment is always unshared
* and unprotected. Data_start gives the lowest unprotected address.
* The value you specify may be rounded down to a suitable boundary
* as required by the machine you are using.
*
* Specifying zero for data_start means the boundary between text and data
* should not be the same as when the program was loaded.
* If NO_REMAP is defined, the argument data_start is ignored and the
* segment boundaries are never changed.
*
* Bss_start indicates how much of the data segment is to be saved in the
* a.out file and restored when the program is executed. It gives the lowest
* unsaved address, and is rounded up to a page boundary. The default when 0
* is given assumes that the entire data segment is to be stored, including
* the previous data and bss as well as any additional storage allocated with
* break (2).
*
* The new file is set up to start at entry_address.
*
* If you make improvements I'd like to get them too.
* harpo!utah-cs!thomas, thomas@Utah-20
*
*/
/* Modified to support SysVr3 shared libraries by James Van Artsdalen
* of Dell Computer Corporation. james@bigtex.cactus.org.
*/
/* There are several compilation parameters affecting unexec:
* COFF
Define this if your system uses COFF for executables.
* COFF_ENCAPSULATE
Define this if you are using the GNU coff encapsulated a.out format.
This is closer to a.out than COFF. You should *not* define COFF if
you define COFF_ENCAPSULATE
Otherwise we assume you use Berkeley format.
* NO_REMAP
Define this if you do not want to try to save Emacs's pure data areas
as part of the text segment.
Saving them as text is good because it allows users to share more.
However, on machines that locate the text area far from the data area,
the boundary cannot feasibly be moved. Such machines require
NO_REMAP.
Also, remapping can cause trouble with the built-in startup routine
/lib/crt0.o, which defines `environ' as an initialized variable.
Dumping `environ' as pure does not work! So, to use remapping,
you must write a startup routine for your machine in Emacs's crt0.c.
If NO_REMAP is defined, Emacs uses the system's crt0.o.
* SECTION_ALIGNMENT
Some machines that use COFF executables require that each section
start on a certain boundary *in the COFF file*. Such machines should
define SECTION_ALIGNMENT to a mask of the low-order bits that must be
zero on such a boundary. This mask is used to control padding between
segments in the COFF file.
If SECTION_ALIGNMENT is not defined, the segments are written
consecutively with no attempt at alignment. This is right for
unmodified system V.
* SEGMENT_MASK
Some machines require that the beginnings and ends of segments
*in core* be on certain boundaries. For most machines, a page
boundary is sufficient. That is the default. When a larger
boundary is needed, define SEGMENT_MASK to a mask of
the bits that must be zero on such a boundary.
* A_TEXT_OFFSET(HDR)
Some machines count the a.out header as part of the size of the text
segment (a_text); they may actually load the header into core as the
first data in the text segment. Some have additional padding between
the header and the real text of the program that is counted in a_text.
For these machines, define A_TEXT_OFFSET(HDR) to examine the header
structure HDR and return the number of bytes to add to `a_text'
before writing it (above and beyond the number of bytes of actual
program text). HDR's standard fields are already correct, except that
this adjustment to the `a_text' field has not yet been made;
thus, the amount of offset can depend on the data in the file.
* A_TEXT_SEEK(HDR)
If defined, this macro specifies the number of bytes to seek into the
a.out file before starting to write the text segment.
* EXEC_MAGIC
For machines using COFF, this macro, if defined, is a value stored
into the magic number field of the output file.
* ADJUST_EXEC_HEADER
This macro can be used to generate statements to adjust or
initialize nonstandard fields in the file header
* ADDR_CORRECT(ADDR)
Macro to correct an int which is the bit pattern of a pointer to a byte
into an int which is the number of a byte.
This macro has a default definition which is usually right.
This default definition is a no-op on most machines (where a
pointer looks like an int) but not on all machines.
*/
#ifndef emacs
#define PERROR(arg) perror (arg); return -1
#else
#define IN_UNEXEC
#include
#define PERROR(file) report_error (file, new)
#endif
#ifndef CANNOT_DUMP /* all rest of file! */
#ifdef COFF_ENCAPSULATE
int need_coff_header = 1;
#include /* The location might be a poor assumption */
#else
#ifdef MSDOS
#if __DJGPP__ > 1
#include /* for O_RDONLY, O_RDWR */
#include /* for _crt0_startup_flags and its bits */
static int save_djgpp_startup_flags;
#endif
#include
#define filehdr external_filehdr
#define scnhdr external_scnhdr
#define syment external_syment
#define auxent external_auxent
#define n_numaux e_numaux
#define n_type e_type
struct aouthdr
{
unsigned short magic; /* type of file */
unsigned short vstamp; /* version stamp */
unsigned long tsize; /* text size in bytes, padded to FW bdry*/
unsigned long dsize; /* initialized data " " */
unsigned long bsize; /* uninitialized data " " */
unsigned long entry; /* entry pt. */
unsigned long text_start;/* base of text used for this file */
unsigned long data_start;/* base of data used for this file */
};
#else /* not MSDOS */
#include
#endif /* not MSDOS */
#endif
/* Define getpagesize if the system does not.
Note that this may depend on symbols defined in a.out.h. */
#include "getpagesize.h"
#ifndef makedev /* Try to detect types.h already loaded */
#include
#endif /* makedev */
#include
#include
#include
#include /* Must be after sys/types.h for USG and BSD4_1*/
#ifdef USG5
#include
#endif
#ifndef O_RDONLY
#define O_RDONLY 0
#endif
#ifndef O_RDWR
#define O_RDWR 2
#endif
extern char *start_of_text (); /* Start of text */
extern char *start_of_data (); /* Start of initialized data */
#ifdef COFF
static long block_copy_start; /* Old executable start point */
static struct filehdr f_hdr; /* File header */
static struct aouthdr f_ohdr; /* Optional file header (a.out) */
long bias; /* Bias to add for growth */
long lnnoptr; /* Pointer to line-number info within file */
#define SYMS_START block_copy_start
static long text_scnptr;
static long data_scnptr;
#else /* not COFF */
#ifdef HPUX
extern void *sbrk ();
#else
#if 0
/* Some systems with __STDC__ compilers still declare this `char *' in some
header file, and our declaration conflicts. The return value is always
cast, so it should be harmless to leave it undefined. Hopefully
machines with different size pointers and ints declare sbrk in a header
file. */
#ifdef __STDC__
extern void *sbrk ();
#else
extern char *sbrk ();
#endif /* __STDC__ */
#endif
#endif /* HPUX */
#define SYMS_START ((long) N_SYMOFF (ohdr))
/* Some machines override the structure name for an a.out header. */
#ifndef EXEC_HDR_TYPE
#define EXEC_HDR_TYPE struct exec
#endif
#ifdef HPUX
#ifdef HP9000S200_ID
#define MY_ID HP9000S200_ID
#else
#include
#define MY_ID MYSYS
#endif /* no HP9000S200_ID */
static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC};
static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC};
#define N_TXTOFF(x) TEXT_OFFSET(x)
#define N_SYMOFF(x) LESYM_OFFSET(x)
static EXEC_HDR_TYPE hdr, ohdr;
#else /* not HPUX */
#if defined (USG) && !defined (IBMAIX) && !defined (IRIS) && !defined (COFF_ENCAPSULATE) && !defined (LINUX)
static struct bhdr hdr, ohdr;
#define a_magic fmagic
#define a_text tsize
#define a_data dsize
#define a_bss bsize
#define a_syms ssize
#define a_trsize rtsize
#define a_drsize rdsize
#define a_entry entry
#define N_BADMAG(x) \
(((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\
((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC)
#define NEWMAGIC FMAGIC
#else /* IRIS or IBMAIX or not USG */
static EXEC_HDR_TYPE hdr, ohdr;
#define NEWMAGIC ZMAGIC
#endif /* IRIS or IBMAIX not USG */
#endif /* not HPUX */
static int unexec_text_start;
static int unexec_data_start;
#ifdef COFF_ENCAPSULATE
/* coffheader is defined in the GNU a.out.encap.h file. */
struct coffheader coffheader;
#endif
#endif /* not COFF */
static int pagemask;
/* Correct an int which is the bit pattern of a pointer to a byte
into an int which is the number of a byte.
This is a no-op on ordinary machines, but not on all. */
#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */
#define ADDR_CORRECT(x) ((char *)(x) - (char*)0)
#endif
#ifdef emacs
#include "lisp.h"
static
report_error (file, fd)
char *file;
int fd;
{
if (fd)
close (fd);
report_file_error ("Cannot unexec", Fcons (build_string (file), Qnil));
}
#endif /* emacs */
#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1
#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1
#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1
static
report_error_1 (fd, msg, a1, a2)
int fd;
char *msg;
int a1, a2;
{
close (fd);
#ifdef emacs
error (msg, a1, a2);
#else
fprintf (stderr, msg, a1, a2);
fprintf (stderr, "\n");
#endif
}
static int make_hdr ();
static int copy_text_and_data ();
static int copy_sym ();
static void mark_x ();
/* ****************************************************************
* unexec
*
* driving logic.
*/
unexec (new_name, a_name, data_start, bss_start, entry_address)
char *new_name, *a_name;
unsigned data_start, bss_start, entry_address;
{
int new, a_out = -1;
if (a_name && (a_out = open (a_name, O_RDONLY)) < 0)
{
PERROR (a_name);
}
if ((new = creat (new_name, 0666)) < 0)
{
PERROR (new_name);
}
if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0
|| copy_text_and_data (new, a_out) < 0
|| copy_sym (new, a_out, a_name, new_name) < 0
#ifdef COFF
#ifndef COFF_BSD_SYMBOLS
|| adjust_lnnoptrs (new, a_out, new_name) < 0
#endif
#endif
)
{
close (new);
/* unlink (new_name); /* Failed, unlink new a.out */
return -1;
}
close (new);
if (a_out >= 0)
close (a_out);
mark_x (new_name);
return 0;
}
/* ****************************************************************
* make_hdr
*
* Make the header in the new a.out from the header in core.
* Modify the text and data sizes.
*/
static int
make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name)
int new, a_out;
unsigned data_start, bss_start, entry_address;
char *a_name;
char *new_name;
{
int tem;
#ifdef COFF
auto struct scnhdr f_thdr; /* Text section header */
auto struct scnhdr f_dhdr; /* Data section header */
auto struct scnhdr f_bhdr; /* Bss section header */
auto struct scnhdr scntemp; /* Temporary section header */
register int scns;
#endif /* COFF */
#ifdef USG_SHARED_LIBRARIES
extern unsigned int bss_end;
#else
unsigned int bss_end;
#endif
pagemask = getpagesize () - 1;
/* Adjust text/data boundary. */
#ifdef NO_REMAP
data_start = (int) start_of_data ();
#else /* not NO_REMAP */
if (!data_start)
data_start = (int) start_of_data ();
#endif /* not NO_REMAP */
data_start = ADDR_CORRECT (data_start);
#ifdef SEGMENT_MASK
data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */
#else
data_start = data_start & ~pagemask; /* (Down) to page boundary. */
#endif
bss_end = ADDR_CORRECT (sbrk (0)) + pagemask;
bss_end &= ~ pagemask;
/* Adjust data/bss boundary. */
if (bss_start != 0)
{
bss_start = (ADDR_CORRECT (bss_start) + pagemask);
/* (Up) to page bdry. */
bss_start &= ~ pagemask;
if (bss_start > bss_end)
{
ERROR1 ("unexec: Specified bss_start (%u) is past end of program",
bss_start);
}
}
else
bss_start = bss_end;
if (data_start > bss_start) /* Can't have negative data size. */
{
ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)",
data_start, bss_start);
}
#ifdef COFF
/* Salvage as much info from the existing file as possible */
if (a_out >= 0)
{
if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
{
PERROR (a_name);
}
block_copy_start += sizeof (f_hdr);
if (f_hdr.f_opthdr > 0)
{
if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
{
PERROR (a_name);
}
block_copy_start += sizeof (f_ohdr);
}
/* Loop through section headers, copying them in */
lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0);
for (scns = f_hdr.f_nscns; scns > 0; scns--) {
if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
{
PERROR (a_name);
}
if (scntemp.s_scnptr > 0L)
{
if (block_copy_start < scntemp.s_scnptr + scntemp.s_size)
block_copy_start = scntemp.s_scnptr + scntemp.s_size;
}
if (strcmp (scntemp.s_name, ".text") == 0)
{
f_thdr = scntemp;
}
else if (strcmp (scntemp.s_name, ".data") == 0)
{
f_dhdr = scntemp;
}
else if (strcmp (scntemp.s_name, ".bss") == 0)
{
f_bhdr = scntemp;
}
}
}
else
{
ERROR0 ("can't build a COFF file from scratch yet");
}
/* Now we alter the contents of all the f_*hdr variables
to correspond to what we want to dump. */
#ifdef USG_SHARED_LIBRARIES
/* The amount of data we're adding to the file is distance from the
* end of the original .data space to the current end of the .data
* space.
*/
bias = bss_start - (f_ohdr.data_start + f_dhdr.s_size);
#endif
f_hdr.f_flags |= (F_RELFLG | F_EXEC);
#ifdef TPIX
f_hdr.f_nscns = 3;
#endif
#ifdef EXEC_MAGIC
f_ohdr.magic = EXEC_MAGIC;
#endif
#ifndef NO_REMAP
f_ohdr.text_start = (long) start_of_text ();
f_ohdr.tsize = data_start - f_ohdr.text_start;
f_ohdr.data_start = data_start;
#endif /* NO_REMAP */
f_ohdr.dsize = bss_start - f_ohdr.data_start;
f_ohdr.bsize = bss_end - bss_start;
#ifndef KEEP_OLD_TEXT_SCNPTR
/* On some machines, the old values are right.
??? Maybe on all machines with NO_REMAP. */
f_thdr.s_size = f_ohdr.tsize;
f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr);
f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr));
#endif /* KEEP_OLD_TEXT_SCNPTR */
#ifdef ADJUST_TEXT_SCNHDR_SIZE
/* On some machines, `text size' includes all headers. */
f_thdr.s_size -= f_thdr.s_scnptr;
#endif /* ADJUST_TEST_SCNHDR_SIZE */
lnnoptr = f_thdr.s_lnnoptr;
#ifdef SECTION_ALIGNMENT
/* Some systems require special alignment
of the sections in the file itself. */
f_thdr.s_scnptr
= (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT;
#endif /* SECTION_ALIGNMENT */
#ifdef TPIX
f_thdr.s_scnptr = 0xd0;
#endif
text_scnptr = f_thdr.s_scnptr;
#ifdef ADJUST_TEXTBASE
text_scnptr = sizeof (f_hdr) + sizeof (f_ohdr) + (f_hdr.f_nscns) * (sizeof (f_thdr));
#endif
#ifndef KEEP_OLD_PADDR
f_dhdr.s_paddr = f_ohdr.data_start;
#endif /* KEEP_OLD_PADDR */
f_dhdr.s_vaddr = f_ohdr.data_start;
f_dhdr.s_size = f_ohdr.dsize;
f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size;
#ifdef SECTION_ALIGNMENT
/* Some systems require special alignment
of the sections in the file itself. */
f_dhdr.s_scnptr
= (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT;
#endif /* SECTION_ALIGNMENT */
#ifdef DATA_SECTION_ALIGNMENT
/* Some systems require special alignment
of the data section only. */
f_dhdr.s_scnptr
= (f_dhdr.s_scnptr + DATA_SECTION_ALIGNMENT) & ~DATA_SECTION_ALIGNMENT;
#endif /* DATA_SECTION_ALIGNMENT */
data_scnptr = f_dhdr.s_scnptr;
#ifndef KEEP_OLD_PADDR
f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize;
#endif /* KEEP_OLD_PADDR */
f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize;
f_bhdr.s_size = f_ohdr.bsize;
f_bhdr.s_scnptr = 0L;
#ifndef USG_SHARED_LIBRARIES
bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start;
#endif
if (f_hdr.f_symptr > 0L)
{
f_hdr.f_symptr += bias;
}
if (f_thdr.s_lnnoptr > 0L)
{
f_thdr.s_lnnoptr += bias;
}
#ifdef ADJUST_EXEC_HEADER
ADJUST_EXEC_HEADER;
#endif /* ADJUST_EXEC_HEADER */
if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
{
PERROR (new_name);
}
if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
{
PERROR (new_name);
}
#ifndef USG_SHARED_LIBRARIES
if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
{
PERROR (new_name);
}
if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
{
PERROR (new_name);
}
if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
{
PERROR (new_name);
}
#else /* USG_SHARED_LIBRARIES */
/* The purpose of this code is to write out the new file's section
* header table.
*
* Scan through the original file's sections. If the encountered
* section is one we know (.text, .data or .bss), write out the
* correct header. If it is a section we do not know (such as
* .lib), adjust the address of where the section data is in the
* file, and write out the header.
*
* If any section precedes .text or .data in the file, this code
* will not adjust the file pointer for that section correctly.
*/
/* This used to use sizeof (f_ohdr) instead of .f_opthdr.
.f_opthdr is said to be right when there is no optional header. */
lseek (a_out, sizeof (f_hdr) + f_hdr.f_opthdr, 0);
for (scns = f_hdr.f_nscns; scns > 0; scns--)
{
if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
PERROR (a_name);
if (!strcmp (scntemp.s_name, f_thdr.s_name)) /* .text */
{
if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
PERROR (new_name);
}
else if (!strcmp (scntemp.s_name, f_dhdr.s_name)) /* .data */
{
if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
PERROR (new_name);
}
else if (!strcmp (scntemp.s_name, f_bhdr.s_name)) /* .bss */
{
if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
PERROR (new_name);
}
else
{
if (scntemp.s_scnptr)
scntemp.s_scnptr += bias;
if (write (new, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
PERROR (new_name);
}
}
#endif /* USG_SHARED_LIBRARIES */
return (0);
#else /* if not COFF */
/* Get symbol table info from header of a.out file if given one. */
if (a_out >= 0)
{
#ifdef COFF_ENCAPSULATE
if (read (a_out, &coffheader, sizeof coffheader) != sizeof coffheader)
{
PERROR(a_name);
}
if (coffheader.f_magic != COFF_MAGIC)
{
ERROR1("%s doesn't have legal coff magic number\n", a_name);
}
#endif
if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr)
{
PERROR (a_name);
}
if (N_BADMAG (ohdr))
{
ERROR1 ("invalid magic number in %s", a_name);
}
hdr = ohdr;
}
else
{
#ifdef COFF_ENCAPSULATE
/* We probably could without too much trouble. The code is in gld
* but I don't have that much time or incentive.
*/
ERROR0 ("can't build a COFF file from scratch yet");
#else
#ifdef MSDOS /* Demacs 1.1.1 91/10/16 HIRANO Satoshi */
bzero ((void *)&hdr, sizeof hdr);
#else
bzero (&hdr, sizeof hdr);
#endif
#endif
}
unexec_text_start = (long) start_of_text ();
unexec_data_start = data_start;
/* Machine-dependent fixup for header, or maybe for unexec_text_start */
#ifdef ADJUST_EXEC_HEADER
ADJUST_EXEC_HEADER;
#endif /* ADJUST_EXEC_HEADER */
hdr.a_trsize = 0;
hdr.a_drsize = 0;
if (entry_address != 0)
hdr.a_entry = entry_address;
hdr.a_bss = bss_end - bss_start;
hdr.a_data = bss_start - data_start;
#ifdef NO_REMAP
hdr.a_text = ohdr.a_text;
#else /* not NO_REMAP */
hdr.a_text = data_start - unexec_text_start;
#ifdef A_TEXT_OFFSET
hdr.a_text += A_TEXT_OFFSET (ohdr);
#endif
#endif /* not NO_REMAP */
#ifdef COFF_ENCAPSULATE
/* We are encapsulating BSD format within COFF format. */
{
struct coffscn *tp, *dp, *bp;
tp = &coffheader.scns[0];
dp = &coffheader.scns[1];
bp = &coffheader.scns[2];
tp->s_size = hdr.a_text + sizeof(struct exec);
dp->s_paddr = data_start;
dp->s_vaddr = data_start;
dp->s_size = hdr.a_data;
bp->s_paddr = dp->s_vaddr + dp->s_size;
bp->s_vaddr = bp->s_paddr;
bp->s_size = hdr.a_bss;
coffheader.tsize = tp->s_size;
coffheader.dsize = dp->s_size;
coffheader.bsize = bp->s_size;
coffheader.text_start = tp->s_vaddr;
coffheader.data_start = dp->s_vaddr;
}
if (write (new, &coffheader, sizeof coffheader) != sizeof coffheader)
{
PERROR(new_name);
}
#endif /* COFF_ENCAPSULATE */
if (write (new, &hdr, sizeof hdr) != sizeof hdr)
{
PERROR (new_name);
}
#if 0 /* This #ifndef caused a bug on Linux when using QMAGIC. */
/* This adjustment was done above only #ifndef NO_REMAP,
so only undo it now #ifndef NO_REMAP. */
/* #ifndef NO_REMAP */
#endif
#ifdef A_TEXT_OFFSET
hdr.a_text -= A_TEXT_OFFSET (ohdr);
#endif
return 0;
#endif /* not COFF */
}
/* ****************************************************************
* copy_text_and_data
*
* Copy the text and data segments from memory to the new a.out
*/
static int
copy_text_and_data (new, a_out)
int new, a_out;
{
register char *end;
register char *ptr;
#ifdef COFF
#ifdef USG_SHARED_LIBRARIES
int scns;
struct scnhdr scntemp; /* Temporary section header */
/* The purpose of this code is to write out the new file's section
* contents.
*
* Step through the section table. If we know the section (.text,
* .data) do the appropriate thing. Otherwise, if the section has
* no allocated space in the file (.bss), do nothing. Otherwise,
* the section has space allocated in the file, and is not a section
* we know. So just copy it.
*/
lseek (a_out, sizeof (struct filehdr) + sizeof (struct aouthdr), 0);
for (scns = f_hdr.f_nscns; scns > 0; scns--)
{
if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
PERROR ("temacs");
if (!strcmp (scntemp.s_name, ".text"))
{
lseek (new, (long) text_scnptr, 0);
ptr = (char *) f_ohdr.text_start;
end = ptr + f_ohdr.tsize;
write_segment (new, ptr, end);
}
else if (!strcmp (scntemp.s_name, ".data"))
{
lseek (new, (long) data_scnptr, 0);
ptr = (char *) f_ohdr.data_start;
end = ptr + f_ohdr.dsize;
write_segment (new, ptr, end);
}
else if (!scntemp.s_scnptr)
; /* do nothing - no data for this section */
else
{
char page[BUFSIZ];
int size, n;
long old_a_out_ptr = lseek (a_out, 0, 1);
lseek (a_out, scntemp.s_scnptr, 0);
for (size = scntemp.s_size; size > 0; size -= sizeof (page))
{
n = size > sizeof (page) ? sizeof (page) : size;
if (read (a_out, page, n) != n || write (new, page, n) != n)
PERROR ("emacs");
}
lseek (a_out, old_a_out_ptr, 0);
}
}
#else /* COFF, but not USG_SHARED_LIBRARIES */
#ifdef MSDOS
#if __DJGPP__ >= 2
/* Dump the original table of exception handlers, not the one
where our exception hooks are registered. */
__djgpp_exception_toggle ();
/* Switch off startup flags that might have been set at runtime
and which might change the way that dumped Emacs works. */
save_djgpp_startup_flags = _crt0_startup_flags;
_crt0_startup_flags &= ~(_CRT0_FLAG_NO_LFN | _CRT0_FLAG_NEARPTR);
#endif
#endif
lseek (new, (long) text_scnptr, 0);
ptr = (char *) f_ohdr.text_start;
#ifdef HEADER_INCL_IN_TEXT
/* For Gould UTX/32, text starts after headers */
ptr = (char *) (ptr + text_scnptr);
#endif /* HEADER_INCL_IN_TEXT */
end = ptr + f_ohdr.tsize;
write_segment (new, ptr, end);
lseek (new, (long) data_scnptr, 0);
ptr = (char *) f_ohdr.data_start;
end = ptr + f_ohdr.dsize;
write_segment (new, ptr, end);
#ifdef MSDOS
#if __DJGPP__ >= 2
/* Restore our exception hooks. */
__djgpp_exception_toggle ();
/* Restore the startup flags. */
_crt0_startup_flags = save_djgpp_startup_flags;
#endif
#endif
#endif /* USG_SHARED_LIBRARIES */
#else /* if not COFF */
/* Some machines count the header as part of the text segment.
That is to say, the header appears in core
just before the address that start_of_text returns.
For them, N_TXTOFF is the place where the header goes.
We must adjust the seek to the place after the header.
Note that at this point hdr.a_text does *not* count
the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */
#ifdef A_TEXT_SEEK
lseek (new, (long) A_TEXT_SEEK (hdr), 0);
#else
lseek (new, (long) N_TXTOFF (hdr), 0);
#endif /* no A_TEXT_SEEK */
#ifdef RISCiX
/* Acorn's RISC-iX has a wacky way of initialising the position of the heap.
* There is a little table in crt0.o that is filled at link time with
* the min and current brk positions, among other things. When start
* runs, it copies the table to where these parameters live during
* execution. This data is in text space, so it cannot be modified here
* before saving the executable, so the data is written manually. In
* addition, the table does not have a label, and the nearest accessible
* label (mcount) is not prefixed with a '_', thus making it inaccessible
* from within C programs. To overcome this, emacs's executable is passed
* through the command 'nm %s | fgrep mcount' into a pipe, and the
* resultant output is then used to find the address of 'mcount'. As far as
* is possible to determine, in RISC-iX releases prior to 1.2, the negative
* offset of the table from mcount is 0x2c, whereas from 1.2 onwards it is
* 0x30. bss_end has been rounded up to page boundary. This solution is
* based on suggestions made by Kevin Welton and Steve Hunt of Acorn, and
* avoids the need for a custom version of crt0.o for emacs which has its
* table in data space.
*/
{
char command[1024];
char errbuf[1024];
char address_text[32];
int proforma[4];
FILE *pfile;
char *temp_ptr;
char c;
int mcount_address, mcount_offset, count;
extern char *_execname;
/* The use of _execname is incompatible with RISCiX 1.1 */
sprintf (command, "nm %s | fgrep mcount", _execname);
if ( (pfile = popen(command, "r")) == NULL)
{
sprintf (errbuf, "Could not open pipe");
PERROR (errbuf);
}
count=0;
while ( ((c=getc(pfile)) != EOF) && (c != ' ') && (count < 31))
address_text[count++]=c;
address_text[count]=0;
if ((count == 0) || pclose(pfile) != NULL)
{
sprintf (errbuf, "Failed to execute the command '%s'\n", command);
PERROR (errbuf);
}
sscanf(address_text, "%x", &mcount_address);
ptr = (char *) unexec_text_start;
mcount_offset = (char *)mcount_address - ptr;
#ifdef RISCiX_1_1
#define EDATA_OFFSET 0x2c
#else
#define EDATA_OFFSET 0x30
#endif
end = ptr + mcount_offset - EDATA_OFFSET;
write_segment (new, ptr, end);
proforma[0] = bss_end; /* becomes _edata */
proforma[1] = bss_end; /* becomes _end */
proforma[2] = bss_end; /* becomes _minbrk */
proforma[3] = bss_end; /* becomes _curbrk */
write (new, proforma, 16);
temp_ptr = ptr;
ptr = end + 16;
end = temp_ptr + hdr.a_text;
write_segment (new, ptr, end);
}
#else /* !RISCiX */
ptr = (char *) unexec_text_start;
end = ptr + hdr.a_text;
write_segment (new, ptr, end);
#endif /* RISCiX */
ptr = (char *) unexec_data_start;
end = ptr + hdr.a_data;
/* This lseek is certainly incorrect when A_TEXT_OFFSET
and I believe it is a no-op otherwise.
Let's see if its absence ever fails. */
/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */
write_segment (new, ptr, end);
#endif /* not COFF */
return 0;
}
write_segment (new, ptr, end)
int new;
register char *ptr, *end;
{
register int i, nwrite, ret;
char buf[80];
extern int errno;
/* This is the normal amount to write at once.
It is the size of block that NFS uses. */
int writesize = 1 << 13;
int pagesize = getpagesize ();
char zeros[1 << 13];
bzero (zeros, sizeof (zeros));
for (i = 0; ptr < end;)
{
/* Distance to next multiple of writesize. */
nwrite = (((int) ptr + writesize) & -writesize) - (int) ptr;
/* But not beyond specified end. */
if (nwrite > end - ptr) nwrite = end - ptr;
ret = write (new, ptr, nwrite);
/* If write gets a page fault, it means we reached
a gap between the old text segment and the old data segment.
This gap has probably been remapped into part of the text segment.
So write zeros for it. */
if (ret == -1
#ifdef EFAULT
&& errno == EFAULT
#endif
)
{
/* Write only a page of zeros at once,
so that we we don't overshoot the start
of the valid memory in the old data segment. */
if (nwrite > pagesize)
nwrite = pagesize;
write (new, zeros, nwrite);
}
#if 0 /* Now that we have can ask `write' to write more than a page,
it is legit for write do less than the whole amount specified. */
else if (nwrite != ret)
{
sprintf (buf,
"unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d",
ptr, new, nwrite, ret, errno);
PERROR (buf);
}
#endif
i += nwrite;
ptr += nwrite;
}
}
/* ****************************************************************
* copy_sym
*
* Copy the relocation information and symbol table from the a.out to the new
*/
static int
copy_sym (new, a_out, a_name, new_name)
int new, a_out;
char *a_name, *new_name;
{
char page[1024];
int n;
if (a_out < 0)
return 0;
#ifdef COFF
if (SYMS_START == 0L)
return 0;
#endif /* COFF */
#ifdef COFF
if (lnnoptr) /* if there is line number info */
lseek (a_out, lnnoptr, 0); /* start copying from there */
else
#endif /* COFF */
lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */
while ((n = read (a_out, page, sizeof page)) > 0)
{
if (write (new, page, n) != n)
{
PERROR (new_name);
}
}
if (n < 0)
{
PERROR (a_name);
}
return 0;
}
/* ****************************************************************
* mark_x
*
* After successfully building the new a.out, mark it executable
*/
static void
mark_x (name)
char *name;
{
struct stat sbuf;
int um;
int new = 0; /* for PERROR */
um = umask (777);
umask (um);
if (stat (name, &sbuf) == -1)
{
PERROR (name);
}
sbuf.st_mode |= 0111 & ~um;
if (chmod (name, sbuf.st_mode) == -1)
PERROR (name);
}
#ifdef COFF
#ifndef COFF_BSD_SYMBOLS
/*
* If the COFF file contains a symbol table and a line number section,
* then any auxiliary entries that have values for x_lnnoptr must
* be adjusted by the amount that the line number section has moved
* in the file (bias computed in make_hdr). The #@$%&* designers of
* the auxiliary entry structures used the absolute file offsets for
* the line number entry rather than an offset from the start of the
* line number section!
*
* When I figure out how to scan through the symbol table and pick out
* the auxiliary entries that need adjustment, this routine will
* be fixed. As it is now, all such entries are wrong and sdb
* will complain. Fred Fish, UniSoft Systems Inc.
*/
/* This function is probably very slow. Instead of reopening the new
file for input and output it should copy from the old to the new
using the two descriptors already open (WRITEDESC and READDESC).
Instead of reading one small structure at a time it should use
a reasonable size buffer. But I don't have time to work on such
things, so I am installing it as submitted to me. -- RMS. */
adjust_lnnoptrs (writedesc, readdesc, new_name)
int writedesc;
int readdesc;
char *new_name;
{
register int nsyms;
register int new;
#if defined (amdahl_uts) || defined (pfa)
SYMENT symentry;
AUXENT auxentry;
#else
struct syment symentry;
union auxent auxentry;
#endif
if (!lnnoptr || !f_hdr.f_symptr)
return 0;
#ifdef MSDOS
if ((new = writedesc) < 0)
#else
if ((new = open (new_name, O_RDWR)) < 0)
#endif
{
PERROR (new_name);
return -1;
}
lseek (new, f_hdr.f_symptr, 0);
for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++)
{
read (new, &symentry, SYMESZ);
if (symentry.n_numaux)
{
read (new, &auxentry, AUXESZ);
nsyms++;
if (ISFCN (symentry.n_type) || symentry.n_type == 0x2400)
{
auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias;
lseek (new, -AUXESZ, 1);
write (new, &auxentry, AUXESZ);
}
}
}
#ifndef MSDOS
close (new);
#endif
return 0;
}
#endif /* COFF_BSD_SYMBOLS */
#endif /* COFF */
#endif /* not CANNOT_DUMP */
scm-5e5/scl.c 0000644 0017052 0001750 00000210377 10750224507 010773 0 ustar tb tb /* "scl.c" non-IEEE utility functions and non-integer arithmetic.
* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 2005, 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
* .
*/
/* Authors: Jerry D. Hedden and Aubrey Jaffer */
#include "scm.h"
#ifdef FLOATS
# ifndef PLAN9
# include
# endif
static double big2scaldbl P((SCM b, int expt));
static SCM bigdblop P((int op, SCM b, double re, double im));
static SCM inex_divbigbig P((SCM a, SCM b));
static int apx_log10 P((double x));
static double lpow10 P((double x, int n));
static sizet idbl2str P((double f, char *a));
static sizet iflo2str P((SCM flt, char *str));
static void safe_add_1 P((double f, double *fsum));
static long scm_twos_power P((SCM n));
static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar",
s_magnitude[] = "magnitude", s_angle[] = "angle",
s_real_part[] = "real-part", s_imag_part[] = "imag-part",
s_in2ex[] = "inexact->exact",s_ex2in[] = "exact->inexact";
static char s_expt[] = "real-expt", s_atan2[] = "$atan2";
#endif
static char s_memv[] = "memv", s_assv[] = "assv";
SCM sys_protects[NUM_PROTECTS];
sizet num_protects = NUM_PROTECTS;
char s_inexactp[] = "inexact?";
static char s_zerop[] = "zero?", s_abs[] = "abs",
s_positivep[] = "positive?", s_negativep[] = "negative?";
static char s_lessp[] = "<", s_grp[] = ">";
static char s_leqp[] = "<=", s_greqp[] = ">=";
#define s_eqp (&s_leqp[1])
static char s_max[] = "max", s_min[] = "min";
char s_sum[] = "+", s_difference[] = "-", s_product[] = "*",
s_divide[] = "/";
static char s_number2string[] = "number->string",
s_str2number[] = "string->number";
static char s_list_tail[] = "list-tail";
static char s_str2list[] = "string->list";
static char s_st_copy[] = "string-copy", s_st_fill[] = "string-fill!";
static char s_vect2list[] = "vector->list", s_ve_fill[] = "vector-fill!";
static char s_intexpt[] = "integer-expt";
static char str_inf0[] = "inf.0";
/*** NUMBERS -> STRINGS ***/
#ifdef FLOATS
static int dbl_mant_dig = 0;
static double max_dbl_int; /* Integers less than or equal to max_dbl_int
are representable exactly as doubles. */
static double dbl_eps;
double dbl_prec(x)
double x;
{
int expt;
double frac = frexp(x, &expt);
# ifdef DBL_MIN_EXP
if (0.0==x || expt < DBL_MIN_EXP) /* gradual underflow */
return ldexp(1.0, - dbl_mant_dig) * ldexp(1.0, DBL_MIN_EXP);
# endif
if (1.0==frac) return ldexp(1.0, expt - dbl_mant_dig + 1);
return ldexp(1.0, expt - dbl_mant_dig);
}
static double llog2 = 0.3010299956639812; /* log10(2) */
static int apx_log10(x)
double x;
{
int expt;
frexp(x, &expt);
expt -= 1;
if (expt >= 0)
return (int)(expt * llog2);
return -((int)(-expt * llog2));
}
static double p10[] = {1.0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7};
static double lpow10(x, n)
double x;
int n;
{
if (n >= 0) {
while (n > 7) {
x *= 1e8;
n -= 8;
}
return x*p10[n];
}
while (n < -7) {
x /= 1e8;
n += 8;
}
return x/p10[-n];
}
int inf2str(f, a)
double f;
char *a;
{
sizet ch = 0;
if (f < 0.0) a[ch++] = '-';
else if (f > 0.0) a[ch++] = '+';
else {
a[ch++] = '0'; a[ch++] = '/'; a[ch++] = '0';
return ch;
}
while (str_inf0[ch - 1]) {
a[ch] = str_inf0[ch - 1];
ch++;
}
/* # ifdef COMPACT_INFINITY_NOTATION */
/* else a[ch++] = '0'; */
/* # else */
/* a[ch++] = (f != f) ? '0' : '1'; */
/* # endif */
/* a[ch++] = '/'; a[ch++] = '0'; */
return ch;
}
/* DBL2STR_FUZZ is a somewhat arbitrary guard against
round off error in scaling f and fprec. */
# define DBL2STR_FUZZ 0.9
int dblprec;
static sizet idbl2str(f, a)
double f;
char *a;
{
double fprec = dbl_prec(f);
int efmt, dpt, d, i, exp;
sizet ch = 0;
if (f==0.0) {exp = 0; goto zero;} /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
if (f==2*f) return inf2str(f, a);
if (f < 0.0) {f = -f;a[ch++]='-';}
else if (f > 0.0) ;
else return inf2str(f, a);
exp = apx_log10(f);
f = lpow10(f, -exp);
fprec = lpow10(fprec, -exp);
# ifdef DBL_MIN_10_EXP /* Prevent random unnormalized values, as from
make-uniform-vector, from causing infinite loops,
but try to print gradually underflowing numbers. */
while (f < 1.0) {
f *= 10.0;
fprec *= 10.0;
if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) return inf2str(f, a);
}
while (f > 10.0) {
f /= 10.0;
fprec /= 10.0;
if (exp++ > DBL_MAX_10_EXP) return inf2str(f, a);
}
# else
while (f < 1.0) {f *= 10.0; fprec *= 10.0; exp--;}
while (f > 10.0) {f /= 10.0; fprec /= 10.0; exp++;}
# endif
fprec *= 0.5;
if (f+fprec >= 10.0) {f = 1.0; exp++;}
zero:
# ifdef ENGNOT
dpt = (exp+9999)%3;
exp -= dpt++;
efmt = 1;
# else
efmt = (exp < -3) || (exp > dblprec+2);
if (!efmt)
if (exp < 0) {
a[ch++] = '0';
a[ch++] = '.';
dpt = exp;
while (++dpt) a[ch++] = '0';
} else
dpt = exp+1;
else
dpt = 1;
# endif
for (i = 30; i--;) {
/* printf(" f = %.20g, fprec = %.20g, i = %d\n", f, fprec, i); */
d = f;
f -= d;
a[ch++] = d+'0';
if (f < fprec && f < DBL2STR_FUZZ*fprec) break;
if ((f + fprec) >= 1.0 && (f + DBL2STR_FUZZ*fprec) >= 1.0) {
a[ch-1]++;
break;
}
f *= 10.0;
fprec *= 10.0;
if (!(--dpt)) a[ch++] = '.';
}
if (dpt > 0)
# ifndef ENGNOT
if ((dpt > 4) && (exp > 6)) {
d = (a[0]=='-'?2:1);
for (i = ch++; i > d; i--)
a[i] = a[i-1];
a[d] = '.';
efmt = 1;
} else
# endif
{
while (--dpt) a[ch++] = '0';
a[ch++] = '.';
}
if (a[ch-1]=='.') a[ch++]='0'; /* trailing zero */
if (efmt && exp) {
a[ch++] = 'e';
if (exp < 0) {
exp = -exp;
a[ch++] = '-';
}
for (i = 10; i <= exp; i *= 10);
for (i /= 10; i; i /= 10) {
a[ch++] = exp/i + '0';
exp %= i;
}
}
return ch;
}
static sizet iflo2str(flt, str)
SCM flt;
char *str;
{
sizet i;
# ifdef SINGLES
if (SINGP(flt)) i = idbl2str(FLO(flt), str);
else
# endif
i = idbl2str(REAL(flt), str);
if (scm_narn==flt) return i;
if (CPLXP(flt)) {
if (!(0 > IMAG(flt))) str[i++] = '+';
i += idbl2str(IMAG(flt), &str[i]);
str[i++] = 'i';
}
return i;
}
#endif /* FLOATS */
sizet iuint2str(num, rad, p)
unsigned long num;
int rad;
char *p;
{
sizet j;
register int i = 1, d;
register unsigned long n = num;
for (n /= rad;n > 0;n /= rad) i++;
j = i;
n = num;
while (i--) {
d = n % rad;
n /= rad;
p[i] = d + ((d < 10) ? '0' : 'a' - 10);
}
return j;
}
sizet iint2str(num, rad, p)
long num;
int rad;
char *p;
{
if ((num < 0) && !(rad < 0)) {
*p++ = '-';
return 1 + iuint2str((unsigned long) -num, rad, p);
}
return iuint2str((unsigned long) num, rad < 0 ? -rad : rad, p);
}
#ifdef BIGDIG
static SCM big2str(b, radix)
SCM b;
register unsigned int radix;
{
SCM t = copybig(b, 0); /* sign of temp doesn't matter */
register BIGDIG *ds = BDIGITS(t);
sizet i = NUMDIGS(t);
sizet j = radix==16 ? (BITSPERDIG*i)/4+2
: radix >= 10 ? (BITSPERDIG*i*241L)/800+2
: (BITSPERDIG*i)+2;
sizet k = 0;
sizet radct = 0;
sizet ch; /* jeh */
BIGDIG radpow = 1, radmod = 0;
SCM ss = makstr((long)j);
char *s = CHARS(ss), c;
scm_protect_temp(&t);
while ((long) radpow * radix < BIGRAD) {
radpow *= radix;
radct++;
}
s[0] = tc16_bigneg==TYP16(b) ? '-' : '+';
while ((i || radmod) && j) {
if (k==0) {
radmod = (BIGDIG)divbigdig(ds, i, radpow);
k = radct;
if (!ds[i-1]) i--;
}
c = radmod % radix; radmod /= radix; k--;
s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
}
ch = s[0]=='-' ? 1 : 0; /* jeh */
if (ch < j) { /* jeh */
for (i = j;j < LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */
resizuve(ss, (SCM)MAKINUM(ch+LENGTH(ss)-i)); /* jeh */
}
return ss;
}
#endif
SCM number2string(x, radix)
SCM x, radix;
{
if (UNBNDP(radix)) radix=MAKINUM(10L);
else ASRTER(INUMP(radix), radix, ARG2, s_number2string);
#ifdef FLOATS
if (NINUMP(x)) {
char num_buf[FLOBUFLEN];
# ifdef BIGDIG
ASRTGO(NIMP(x), badx);
if (BIGP(x)) return big2str(x, (unsigned int)INUM(radix));
# ifndef RECKLESS
if (!(INEXP(x)))
badx: wta(x, (char *)ARG1, s_number2string);
# endif
# else
ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_number2string);
# endif
return makfromstr(num_buf, iflo2str(x, num_buf));
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_number2string);
return big2str(x, (unsigned int)INUM(radix));
}
# else
ASRTER(INUMP(x), x, ARG1, s_number2string);
# endif
#endif
{
char num_buf[INTBUFLEN];
return makfromstr(num_buf, iint2str(INUM(x), (int)INUM(radix), num_buf));
}
}
/* These print routines are stubbed here so that repl.c doesn't need
FLOATS or BIGDIGs conditionals */
int floprint(sexp, port, writing)
SCM sexp;
SCM port;
int writing;
{
#ifdef FLOATS
if (!errjmp_bad) {
char num_buf[FLOBUFLEN];
lfwrite(num_buf, (sizet)sizeof(char), iflo2str(sexp, num_buf), port);
return !0;
} else
#endif
scm_ipruk("float", sexp, port);
return !0;
}
int bigprint(exp, port, writing)
SCM exp;
SCM port;
int writing;
{
#ifdef BIGDIG
if (!errjmp_bad) {
exp = big2str(exp, (unsigned int)10);
lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
return !0;
} else
#endif
scm_ipruk("bignum", exp, port);
return !0;
}
/*** END nums->strs ***/
/*** STRINGS -> NUMBERS ***/
#ifdef BIGDIG
SCM istr2int(str, len, radix)
char *str;
long len;
register long radix;
{
sizet j;
register sizet k, blen = 1;
sizet i = 0;
int c;
SCM res;
register BIGDIG *ds;
register unsigned long t2;
if (0 >= len) return BOOL_F; /* zero length */
if (10==radix) j = 1+(84*len)/(BITSPERDIG*25);
else j = (8 < radix) ? 1+(4*len)/BITSPERDIG : 1+(3*len)/BITSPERDIG;
switch (str[0]) { /* leading sign */
case '-':
case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */
}
res = mkbig(j, '-'==str[0]);
ds = BDIGITS(res);
for (k = j;k--;) ds[k] = 0;
do {
switch (c = str[i++]) {
case DIGITS:
c = c - '0';
goto accumulate;
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
c = c-'A'+10;
goto accumulate;
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
c = c-'a'+10;
accumulate:
if (c >= radix) return BOOL_F; /* bad digit for radix */
k = 0;
t2 = c;
moretodo:
while(k < blen) {
/* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
t2 += ds[k]*radix;
ds[k++] = BIGLO(t2);
t2 = BIGDN(t2);
}
ASRTER(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum");
if (t2) {blen++; goto moretodo;}
break;
default:
return BOOL_F; /* not a digit */
}
} while (i < len);
if (blen * BITSPERDIG/CHAR_BIT <= sizeof(SCM))
if (INUMP(res = big2inum(res, blen))) return res;
if (j==blen) return res;
return adjbig(res, blen);
}
#else
SCM istr2int(str, len, radix)
register char *str;
long len;
register long radix;
{
register long n = 0, ln;
register int c;
register int i = 0;
int lead_neg = 0;
if (0 >= len) return BOOL_F; /* zero length */
switch (*str) { /* leading sign */
case '-': lead_neg = 1;
case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */
}
do {
switch (c = str[i++]) {
case DIGITS:
c = c - '0';
goto accumulate;
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
c = c-'A'+10;
goto accumulate;
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
c = c-'a'+10;
accumulate:
if (c >= radix) return BOOL_F; /* bad digit for radix */
ln = n;
n = n * radix - c;
if (n > ln
# ifdef hpux
|| (-n > -MOST_NEGATIVE_FIXNUM) /* workaround for HP700 cc bug */
# endif
) goto ovfl;
break;
default:
return BOOL_F; /* not a digit */
}
} while (i < len);
if (lead_neg) {
if (n < MOST_NEGATIVE_FIXNUM) goto ovfl;
}
else {
if (n < -MOST_POSITIVE_FIXNUM) goto ovfl;
n = -n;
}
return MAKINUM(n);
ovfl: /* overflow scheme integer */
return BOOL_F;
}
#endif
#ifdef FLOATS
# ifdef BIGDIG
static char twostab[] = {4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0};
static long scm_twos_power(n)
SCM n;
{
long d, c = 0;
int d4;
# ifdef BIGDIG
if (NINUMP(n)) {
BIGDIG *ds;
int i = 0;
ds = BDIGITS(n);
while (0==(d = ds[i++])) c += BITSPERDIG;
goto out;
}
# endif
d = INUM(n);
if (0==d) return 0;
out:
do {
d4 = 15 & d;
c += twostab[d4];
d >>= 4;
} while (0==d4);
return c;
}
# endif /* def BIGDIG */
SCM istr2flo(str, len, radix)
register char *str;
register long len;
register long radix;
{
register int c, i = 0;
double lead_sgn = 0.0;
double res = 0.0, tmp = 0.0;
int flg = 0;
int point = 0;
SCM second;
if (i >= len) return BOOL_F; /* zero length */
switch (*str) { /* leading sign */
case '-': lead_sgn = -1.0; i++; break;
case '+': lead_sgn = 1.0; i++; break;
}
if (i==len) return BOOL_F; /* bad if lone `+' or `-' */
if (6==len && ('+'==str[0] || '-'==str[0]))
if (0==strcmp(str_inf0, &str[1]))
return makdbl(1./0. * ('+'==str[0] ? 1 : -1), 0.0);
if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */
if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */
if (++i < len) return BOOL_F; /* `i' not last character */
return makdbl(0.0, lead_sgn);
}
/* # ifdef COMPACT_INFINITY_NOTATION */
if (0.0 != lead_sgn && str[i]=='/') {
res = 1;
flg = 1;
goto out1;
}
/* # endif */
do { /* check initial digits */
switch (c = str[i]) {
case DIGITS:
c = c - '0';
goto accum1;
case 'D': case 'E': case 'F':
if (radix==10) goto out1; /* must be exponent */
case 'A': case 'B': case 'C':
c = c-'A'+10;
goto accum1;
case 'd': case 'e': case 'f':
if (radix==10) goto out1;
case 'a': case 'b': case 'c':
c = c-'a'+10;
accum1:
if (c >= radix) return BOOL_F; /* bad digit for radix */
res = res * radix + c;
flg = 1; /* res is valid */
break;
default:
goto out1;
}
} while (++i < len);
out1:
/* if true, then we did see a digit above, and res is valid */
if (i==len) goto done;
/* By here, must have seen a digit,
or must have next char be a `.' with radix==10 */
if (!flg)
if (!(str[i]=='.' && radix==10))
return BOOL_F;
while (str[i]=='#') { /* optional sharps */
res *= radix;
if (++i==len) goto done;
}
if (str[i]=='/') {
while (++i < len) {
switch (c = str[i]) {
case DIGITS:
c = c - '0';
goto accum2;
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
c = c-'A'+10;
goto accum2;
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
c = c-'a'+10;
accum2:
if (c >= radix) return BOOL_F;
tmp = tmp * radix + c;
break;
default:
goto out2;
}
}
out2:
/* if (tmp==0.0) return BOOL_F; /\* `slash zero' not allowed *\/ */
if (i < len)
while (str[i]=='#') { /* optional sharps */
tmp *= radix;
if (++i==len) break;
}
res /= tmp;
goto done;
}
if (str[i]=='.') { /* decimal point notation */
if (radix != 10) return BOOL_F; /* must be radix 10 */
while (++i < len) {
switch (c = str[i]) {
case DIGITS:
point--;
res = res*10.0 + c-'0';
flg = 1;
break;
default:
goto out3;
}
}
out3:
if (!flg) return BOOL_F; /* no digits before or after decimal point */
if (i==len) goto adjust;
while (str[i]=='#') { /* ignore remaining sharps */
if (++i==len) goto adjust;
}
}
switch (str[i]) { /* exponent */
case 'd': case 'D':
case 'e': case 'E':
case 'f': case 'F':
case 'l': case 'L':
case 's': case 'S': {
int expsgn = 1, expon = 0;
if (radix != 10) return BOOL_F; /* only in radix 10 */
if (++i==len) return BOOL_F; /* bad exponent */
switch (str[i]) {
case '-': expsgn=(-1);
case '+': if (++i==len) return BOOL_F; /* bad exponent */
}
if (str[i] < '0' || str[i] > '9') return BOOL_F; /* bad exponent */
do {
switch (c = str[i]) {
case DIGITS:
expon = expon*10 + c-'0';
/* if (expon > MAXEXP) */
/* if (1==expsgn || expon > (MAXEXP + dblprec + 1)) */
/* return BOOL_F; /\* exponent too large *\/ */
break;
default:
goto out4;
}
} while (++i < len);
out4:
point += expsgn*expon;
}
}
adjust:
if (point >= 0)
while (point--) res *= 10.0;
else
# ifdef _UNICOS
while (point++) res *= 0.1;
# else
while (point++) res /= 10.0;
# endif
done:
/* at this point, we have a legitimate floating point result */
if (lead_sgn==-1.0) res = -res;
if (i==len) return makdbl(res, 0.0);
if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */
if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */
if (++i < len) return BOOL_F; /* `i' not last character */
return makdbl(0.0, res);
}
switch (str[i++]) {
case '-': lead_sgn = -1.0; break;
case '+': lead_sgn = 1.0; break;
case '@': { /* polar input for complex number */
/* get a `real' for angle */
second = istr2flo(&str[i], (long)(len-i), radix);
if (IMP(second)) return BOOL_F;
if (!(INEXP(second))) return BOOL_F; /* not `real' */
if (CPLXP(second)) return BOOL_F; /* not `real' */
tmp = REALPART(second);
return makdbl(res*cos(tmp), res*sin(tmp));
}
default: return BOOL_F;
}
/* at this point, last char must be `i' */
if (str[len-1] != 'i' && str[len-1] != 'I') return BOOL_F;
/* handles `x+i' and `x-i' */
if (i==(len-1)) return makdbl(res, lead_sgn);
/* get a `ureal' for complex part */
second = istr2flo(&str[i], (long)((len-i)-1), radix);
if (IMP(second)) return BOOL_F;
if (!(INEXP(second))) return BOOL_F; /* not `ureal' */
if (CPLXP(second)) return BOOL_F; /* not `ureal' */
tmp = REALPART(second);
if (tmp < 0.0) return BOOL_F; /* not `ureal' */
return makdbl(res, (lead_sgn*tmp));
}
#endif /* FLOATS */
SCM istring2number(str, len, radix)
char *str;
long len;
long radix;
{
int i = 0;
char ex = 0;
char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
SCM res;
if (len==1)
if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */
return BOOL_F;
while ((len-i) >= 2 && str[i]=='#' && ++i)
switch (str[i++]) {
case 'b': case 'B': if (rx_p++) return BOOL_F; radix = 2; break;
case 'o': case 'O': if (rx_p++) return BOOL_F; radix = 8; break;
case 'd': case 'D': if (rx_p++) return BOOL_F; radix = 10; break;
case 'x': case 'X': if (rx_p++) return BOOL_F; radix = 16; break;
case 'i': case 'I': if (ex_p++) return BOOL_F; ex = 2; break;
case 'e': case 'E': if (ex_p++) return BOOL_F; ex = 1; break;
default: return BOOL_F;
}
switch (ex) {
case 1:
return istr2int(&str[i], len-i, radix);
case 0:
res = istr2int(&str[i], len-i, radix);
if (NFALSEP(res)) return res;
#ifdef FLOATS
case 2: return istr2flo(&str[i], len-i, radix);
#endif
}
return BOOL_F;
}
SCM string2number(str, radix)
SCM str, radix;
{
if (UNBNDP(radix)) radix=MAKINUM(10L);
else ASRTER(INUMP(radix), radix, ARG2, s_str2number);
ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_str2number);
return istring2number(CHARS(str), LENGTH(str), INUM(radix));
}
/*** END strs->nums ***/
#ifdef FLOATS
SCM makdbl (x, y)
double x, y;
{
SCM z;
if ((y==0.0) && (x==0.0)) return flo0;
# ifndef _MSC_VER
# ifndef SINGLESONLY
if ((y != y) || (x != x) || (y==(2 * y) && (y != 0.0))) return scm_narn;
if ((x==(2 * x)) && (x != 0.0)) y = 0.0;
# endif
# endif
DEFER_INTS;
if (y==0.0) {
# ifdef SINGLES
float fx = x; /* David Yeh
changed this so that MSVC works */
# ifndef SINGLESONLY
if ((-FLTMAX < x) && (x < FLTMAX) && ( (double)fx == x) )
# endif
{
NEWCELL(z);
CAR(z) = tc_flo;
FLO(z) = x;
ALLOW_INTS;
return z;
}
# endif /* def SINGLES */
z = must_malloc_cell(1L*sizeof(double), (SCM)tc_dblr, "real");
}
else {
z = must_malloc_cell(2L*sizeof(double), (SCM)tc_dblc, "complex");
IMAG(z) = y;
}
REAL(z) = x;
ALLOW_INTS;
return z;
}
#endif /* FLOATS */
#ifndef INUMS_ONLY
SCM eqv(x, y)
SCM x, y;
{
if (x==y) return BOOL_T;
if (IMP(x)) return BOOL_F;
if (IMP(y)) return BOOL_F;
/* this ensures that types and length are the same. */
if (CAR(x) != CAR(y)) return BOOL_F;
if (NUMP(x)) {
# ifdef BIGDIG
if (BIGP(x)) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
# endif
# ifdef FLOATS
return floequal(x, y);
# endif
}
return BOOL_F;
}
SCM memv(x, lst) /* m.borza 12.2.91 */
SCM x, lst;
{
for (;NIMP(lst);lst = CDR(lst)) {
ASRTGO(CONSP(lst), badlst);
if (NFALSEP(eqv(CAR(lst), x))) return lst;
}
# ifndef RECKLESS
if (!(NULLP(lst)))
badlst: wta(lst, (char *)ARG2, s_memv);
# endif
return BOOL_F;
}
SCM assv(x, alist) /* m.borza 12.2.91 */
SCM x, alist;
{
SCM tmp;
for (;NIMP(alist);alist = CDR(alist)) {
ASRTGO(CONSP(alist), badlst);
tmp = CAR(alist);
ASRTGO(NIMP(tmp) && CONSP(tmp), badlst);
if (NFALSEP(eqv(CAR(tmp), x))) return tmp;
}
# ifndef RECKLESS
if (!(NULLP(alist)))
badlst: wta(alist, (char *)ARG2, s_assv);
# endif
return BOOL_F;
}
#endif
SCM list_tail(lst, k)
SCM lst, k;
{
register long i;
ASRTER(INUMP(k), k, ARG2, s_list_tail);
i = INUM(k);
while (i-- > 0) {
ASRTER(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail);
lst = CDR(lst);
}
return lst;
}
SCM string2list(str)
SCM str;
{
long i;
SCM res = EOL;
unsigned char *src;
ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_str2list);
src = UCHARS(str);
for (i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKICHR(src[i]), res);
return res;
}
SCM string_copy(str)
SCM str;
{
ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy);
return makfromstr(CHARS(str), (sizet)LENGTH(str));
}
SCM string_fill(str, chr)
SCM str, chr;
{
register char *dst, c;
register long k;
ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_fill);
ASRTER(ICHRP(chr), chr, ARG2, s_st_fill);
c = ICHR(chr);
dst = CHARS(str);
for (k = LENGTH(str)-1;k >= 0;k--) dst[k] = c;
return UNSPECIFIED;
}
SCM vector2list(v)
SCM v;
{
SCM res = EOL;
long i;
SCM *data;
ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_vect2list);
data = VELTS(v);
for (i = LENGTH(v)-1;i >= 0;i--) res = cons(data[i], res);
return res;
}
SCM vector_fill(v, fill)
SCM v, fill;
{
register long i;
register SCM *data;
ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_fill);
data = VELTS(v);
for (i = LENGTH(v)-1;i >= 0;i--) data[i] = fill;
return UNSPECIFIED;
}
static SCM vector_equal(x, y)
SCM x, y;
{
long i;
for (i = LENGTH(x)-1;i >= 0;i--)
if (FALSEP(equal(VELTS(x)[i], VELTS(y)[i]))) return BOOL_F;
return BOOL_T;
}
#ifdef BIGDIG
SCM bigequal(x, y)
SCM x, y;
{
if (0==bigcomp(x, y)) return BOOL_T;
return BOOL_F;
}
#endif
#ifdef FLOATS
SCM floequal(x, y)
SCM x, y;
{
if ((REALPART(x) != REALPART(y))) return BOOL_F;
if (CPLXP(x))
return (CPLXP(y) && (IMAG(x)==IMAG(y))) ? BOOL_T : BOOL_F;
return CPLXP(y) ? BOOL_F : BOOL_T;
}
#endif
SCM equal(x, y)
SCM x, y;
{
CHECK_STACK;
tailrecurse: POLL;
if (x==y) return BOOL_T;
if (IMP(x)) return BOOL_F;
if (IMP(y)) return BOOL_F;
if (CONSP(x) && CONSP(y)) {
if (FALSEP(equal(CAR(x), CAR(y)))) return BOOL_F;
x = CDR(x);
y = CDR(y);
goto tailrecurse;
}
/* this ensures that types and length are the same. */
if (CAR(x) != CAR(y)) return BOOL_F;
switch (TYP7(x)) {
default: return BOOL_F;
case tc7_string: return st_equal(x, y);
case tc7_vector: return vector_equal(x, y);
case tc7_smob: {
int i = SMOBNUM(x);
if (!(i < numsmob)) return BOOL_F;
if (smobs[i].equalp) return (smobs[i].equalp)(x, y);
else return BOOL_F;
}
case tc7_Vbool: case tc7_VfixN8: case tc7_VfixZ8:
case tc7_VfixN16: case tc7_VfixZ16: case tc7_VfixN32: case tc7_VfixZ32:
case tc7_VfloR32: case tc7_VfloC32: case tc7_VfloC64: case tc7_VfloR64: {
SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp;
if (pred) return (*pred)(x, y);
else return BOOL_F;
}
}
}
SCM numberp(obj)
SCM obj;
{
if (INUMP(obj)) return BOOL_T;
#ifdef FLOATS
if (NIMP(obj) && NUMP(obj)) return BOOL_T;
#else
# ifdef BIGDIG
if (NIMP(obj) && NUMP(obj)) return BOOL_T;
# endif
#endif
return BOOL_F;
}
#ifdef FLOATS
SCM scm_complex_p(obj)
SCM obj;
{
if (obj==scm_narn) return BOOL_F;
return numberp(obj);
}
# ifdef BIGDIG
int scm_bigdblcomp(b, d)
SCM b;
double d;
{
sizet dlen, blen;
int dneg = d < 0 ? 1 : 0;
int bneg = BIGSIGN(b) ? 1 : 0;
if (bneg < dneg) return -1;
if (bneg > dneg) return 1;
frexp(d, &dlen);
blen = INUM(scm_intlength(b));
if (blen > dlen) return dneg ? 1 : -1;
if (blen < dlen) return dneg ? -1 : 1;
if ((blen <= dbl_mant_dig) || (blen - scm_twos_power(b)) <= dbl_mant_dig) {
double bd = big2dbl(b);
if (bd > d) return -1;
if (bd < d) return 1;
return 0;
}
return bigcomp(b, dbl2big(d));
}
# endif
SCM realp(x)
SCM x;
{
if (INUMP(x)) return BOOL_T;
if (IMP(x)) return BOOL_F;
if (REALP(x)) return BOOL_T;
# ifdef BIGDIG
if (BIGP(x)) return BOOL_T;
# endif
return BOOL_F;
}
SCM scm_rationalp(x)
SCM x;
{
if (INUMP(x)) return BOOL_T;
if (IMP(x)) return BOOL_F;
if (REALP(x)) {
float y = REALPART(x);
if (y==2*y && y != 0.0) return BOOL_F;
return BOOL_T;
}
# ifdef BIGDIG
if (BIGP(x)) return BOOL_T;
# endif
return BOOL_F;
}
SCM intp(x)
SCM x;
{
double r;
if (INUMP(x)) return BOOL_T;
if (IMP(x)) return BOOL_F;
# ifdef BIGDIG
if (BIGP(x)) return BOOL_T;
# endif
if (!INEXP(x)) return BOOL_F;
if (CPLXP(x)) return BOOL_F;
r = REALPART(x);
if (r != floor(r)) return BOOL_F;
if (r==2*r && r != 0.0) return BOOL_F;
return BOOL_T;
}
#endif /* FLOATS */
SCM inexactp(x)
SCM x;
{
#ifdef FLOATS
if (NIMP(x) && INEXP(x)) return BOOL_T;
#endif
return BOOL_F;
}
SCM eqp(x, y)
SCM x, y;
{
#ifdef FLOATS
SCM t;
if (NINUMP(x)) {
# ifdef BIGDIG
# ifndef RECKLESS
if (!(NIMP(x)))
badx: wta(x, (char *)ARG1, s_eqp);
# endif
if (BIGP(x)) {
if (INUMP(y)) return BOOL_F;
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
ASRTGO(INEXP(y), bady);
bigreal:
return (REALP(y) && (0==scm_bigdblcomp(x, REALPART(y)))) ?
BOOL_T : BOOL_F;
}
ASRTGO(INEXP(x), badx);
# else
ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_eqp);
# endif
if (INUMP(y)) {t = x; x = y; y = t; goto realint;}
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;}
ASRTGO(INEXP(y), bady);
# else
ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
if (x==y) return BOOL_T;
return floequal(x, y);
}
if (NINUMP(y)) {
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return BOOL_F;
# ifndef RECKLESS
if (!(INEXP(y)))
bady: wta(y, (char *)ARG2, s_eqp);
# endif
# else
# ifndef RECKLESS
if (!(NIMP(y) && INEXP(y)))
bady: wta(y, (char *)ARG2, s_eqp);
# endif
# endif
realint:
return (REALP(y) && (((double)INUM(x))==REALPART(y))) ? BOOL_T : BOOL_F;
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_eqp);
if (INUMP(y)) return BOOL_F;
ASRTGO(NIMP(y) && BIGP(y), bady);
return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
}
if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_eqp);
# endif
return BOOL_F;
}
# else
ASRTER(INUMP(x), x, ARG1, s_eqp);
ASRTER(INUMP(y), y, ARG2, s_eqp);
# endif
#endif
return ((long)x==(long)y) ? BOOL_T : BOOL_F;
}
SCM lessp(x, y)
SCM x, y;
{
#ifdef FLOATS
if (NINUMP(x)) {
# ifdef BIGDIG
# ifndef RECKLESS
if (!(NIMP(x)))
badx: wta(x, (char *)ARG1, s_lessp);
# endif
if (BIGP(x)) {
if (INUMP(y)) return BIGSIGN(x) ? BOOL_T : BOOL_F;
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F;
ASRTGO(REALP(y), bady);
return (1==scm_bigdblcomp(x, REALPART(y))) ? BOOL_T : BOOL_F;
}
ASRTGO(REALP(x), badx);
# else
ASRTER(NIMP(x) && REALP(x), x, ARG1, s_lessp);
# endif
if (INUMP(y)) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F;
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return (-1==scm_bigdblcomp(y, REALPART(x))) ? BOOL_T : BOOL_F;
ASRTGO(REALP(y), bady);
# else
ASRTGO(NIMP(y) && REALP(y), bady);
# endif
return (REALPART(x) < REALPART(y)) ? BOOL_T : BOOL_F;
}
if (NINUMP(y)) {
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return BIGSIGN(y) ? BOOL_F : BOOL_T;
# ifndef RECKLESS
if (!(REALP(y)))
bady: wta(y, (char *)ARG2, s_lessp);
# endif
# else
# ifndef RECKLESS
if (!(NIMP(y) && REALP(y)))
bady: wta(y, (char *)ARG2, s_lessp);
# endif
# endif
return (((double)INUM(x)) < REALPART(y)) ? BOOL_T : BOOL_F;
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_lessp);
if (INUMP(y)) return BIGSIGN(x) ? BOOL_T : BOOL_F;
ASRTGO(NIMP(y) && BIGP(y), bady);
return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F;
}
if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_lessp);
# endif
return BIGSIGN(y) ? BOOL_F : BOOL_T;
}
# else
ASRTER(INUMP(x), x, ARG1, s_lessp);
ASRTER(INUMP(y), y, ARG2, s_lessp);
# endif
#endif
return ((long)x < (long)y) ? BOOL_T : BOOL_F;
}
SCM greaterp(x, y)
SCM x, y;
{
return lessp(y, x);
}
SCM leqp(x, y)
SCM x, y;
{
return BOOL_NOT(lessp(y, x));
}
SCM greqp(x, y)
SCM x, y;
{
return BOOL_NOT(lessp(x, y));
}
SCM zerop(z)
SCM z;
{
#ifdef FLOATS
if (NINUMP(z)) {
# ifdef BIGDIG
ASRTGO(NIMP(z), badz);
if (BIGP(z)) return BOOL_F;
# ifndef RECKLESS
if (!(INEXP(z)))
badz: wta(z, (char *)ARG1, s_zerop);
# endif
# else
ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_zerop);
# endif
return (z==flo0) ? BOOL_T : BOOL_F;
}
#else
# ifdef BIGDIG
if (NINUMP(z)) {
ASRTER(NIMP(z) && BIGP(z), z, ARG1, s_zerop);
return BOOL_F;
}
# else
ASRTER(INUMP(z), z, ARG1, s_zerop);
# endif
#endif
return (z==INUM0) ? BOOL_T: BOOL_F;
}
SCM positivep(x)
SCM x;
{
#ifdef FLOATS
if (NINUMP(x)) {
# ifdef BIGDIG
ASRTGO(NIMP(x), badx);
if (BIGP(x)) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F;
# ifndef RECKLESS
if (!(REALP(x)))
badx: wta(x, (char *)ARG1, s_positivep);
# endif
# else
ASRTER(NIMP(x) && REALP(x), x, ARG1, s_positivep);
# endif
return (REALPART(x) > 0.0) ? BOOL_T : BOOL_F;
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_positivep);
return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F;
}
# else
ASRTER(INUMP(x), x, ARG1, s_positivep);
# endif
#endif
return (x > INUM0) ? BOOL_T : BOOL_F;
}
SCM negativep(x)
SCM x;
{
#ifdef FLOATS
if (NINUMP(x)) {
# ifdef BIGDIG
ASRTGO(NIMP(x), badx);
if (BIGP(x)) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T;
# ifndef RECKLESS
if (!(REALP(x)))
badx: wta(x, (char *)ARG1, s_negativep);
# endif
# else
ASRTER(NIMP(x) && REALP(x), x, ARG1, s_negativep);
# endif
return (REALPART(x) < 0.0) ? BOOL_T : BOOL_F;
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_negativep);
return (TYP16(x)==tc16_bigneg) ? BOOL_T : BOOL_F;
}
# else
ASRTER(INUMP(x), x, ARG1, s_negativep);
# endif
#endif
return (x < INUM0) ? BOOL_T : BOOL_F;
}
static char s_exactprob[] = "not representable as inexact";
SCM lmax(x, y)
SCM x, y;
{
#ifdef FLOATS
SCM t;
double z;
#endif
if (UNBNDP(y)) {
#ifndef RECKLESS
if (!(NUMBERP(x)))
badx: wta(x, (char *)ARG1, s_max);
#endif
return x;
}
#ifdef FLOATS
if (NINUMP(x)) {
# ifdef BIGDIG
ASRTGO(NIMP(x), badx);
if (BIGP(x)) {
if (INUMP(y)) return BIGSIGN(x) ? y : x;
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return (1==bigcomp(x, y)) ? y : x;
ASRTGO(REALP(y), bady);
big_dbl:
if (-1 != scm_bigdblcomp(x, REALPART(y))) return y;
z = big2dbl(x);
ASRTER(0==scm_bigdblcomp(x, z), x, s_exactprob, s_max);
return makdbl(z, 0.0);
}
ASRTGO(REALP(x), badx);
# else
ASRTER(NIMP(x) && REALP(x), x, ARG1, s_max);
# endif
if (INUMP(y)) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x;
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {
t = y; y = x; x = t; goto big_dbl;
}
ASRTGO(REALP(y), bady);
# else
ASRTGO(NIMP(y) && REALP(y), bady);
# endif
return (REALPART(x) < REALPART(y)) ? y : x;
}
if (NINUMP(y)) {
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return BIGSIGN(y) ? x : y;
# ifndef RECKLESS
if (!(REALP(y)))
bady: wta(y, (char *)ARG2, s_max);
# endif
# else
# ifndef RECKLESS
if (!(NIMP(y) && REALP(y)))
bady: wta(y, (char *)ARG2, s_max);
# endif
# endif
return ((z = INUM(x)) < REALPART(y)) ? y : makdbl(z, 0.0);
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_max);
if (INUMP(y)) return BIGSIGN(x) ? y : x;
ASRTGO(NIMP(y) && BIGP(y), bady);
return (1==bigcomp(x, y)) ? y : x;
}
if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_max);
# endif
return BIGSIGN(y) ? x : y;
}
# else
ASRTER(INUMP(x), x, ARG1, s_max);
ASRTER(INUMP(y), y, ARG2, s_max);
# endif
#endif
return ((long)x < (long)y) ? y : x;
}
SCM lmin(x, y)
SCM x, y;
{
#ifdef FLOATS
SCM t;
double z;
#endif
if (UNBNDP(y)) {
#ifndef RECKLESS
if (!(NUMBERP(x)))
badx: wta(x, (char *)ARG1, s_min);
#endif
return x;
}
#ifdef FLOATS
if (NINUMP(x)) {
# ifdef BIGDIG
ASRTGO(NIMP(x), badx);
if (BIGP(x)) {
if (INUMP(y)) return BIGSIGN(x) ? x : y;
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return (-1==bigcomp(x, y)) ? y : x;
ASRTGO(REALP(y), bady);
big_dbl:
if (1 != scm_bigdblcomp(x, REALPART(y))) return y;
z = big2dbl(x);
ASRTER(0==scm_bigdblcomp(x, z), x, s_exactprob, s_min);
return makdbl(z, 0.0);
}
ASRTGO(REALP(x), badx);
# else
ASRTER(NIMP(x) && REALP(x), x, ARG1, s_min);
# endif
if (INUMP(y)) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x;
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {
t = y; y = x; x = t; goto big_dbl;
}
ASRTGO(REALP(y), bady);
# else
ASRTGO(NIMP(y) && REALP(y), bady);
# endif
return (REALPART(x) > REALPART(y)) ? y : x;
}
if (NINUMP(y)) {
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return BIGSIGN(y) ? y : x;
# ifndef RECKLESS
if (!(REALP(y)))
bady: wta(y, (char *)ARG2, s_min);
# endif
# else
# ifndef RECKLESS
if (!(NIMP(y) && REALP(y)))
bady: wta(y, (char *)ARG2, s_min);
# endif
# endif
return ((z = INUM(x)) > REALPART(y)) ? y : makdbl(z, 0.0);
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_min);
if (INUMP(y)) return BIGSIGN(x) ? x : y;
ASRTGO(NIMP(y) && BIGP(y), bady);
return (-1==bigcomp(x, y)) ? y : x;
}
if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_min);
# endif
return BIGSIGN(y) ? y : x;
}
# else
ASRTER(INUMP(x), x, ARG1, s_min);
ASRTER(INUMP(y), y, ARG2, s_min);
# endif
#endif
return ((long)x > (long)y) ? y : x;
}
SCM sum(x, y)
SCM x, y;
{
if (UNBNDP(y)) {
if (UNBNDP(x)) return INUM0;
#ifndef RECKLESS
if (!(NUMBERP(x)))
badx: wta(x, (char *)ARG1, s_sum);
#endif
return x;
}
#ifdef FLOATS
if (NINUMP(x)) {
SCM t;
# ifdef BIGDIG
ASRTGO(NIMP(x), badx);
if (BIGP(x)) {
if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {
if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
}
ASRTGO(INEXP(y), bady);
bigreal: return makdbl(big2dbl(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0);
}
ASRTGO(INEXP(x), badx);
# else
ASRTGO(NIMP(x) && INEXP(x), badx);
# endif
if (INUMP(y)) {t = x; x = y; y = t; goto intreal;}
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;}
# ifndef RECKLESS
else if (!(INEXP(y)))
bady: wta(y, (char *)ARG2, s_sum);
# endif
# else
# ifndef RECKLESS
if (!(NIMP(y) && INEXP(y)))
bady: wta(y, (char *)ARG2, s_sum);
# endif
# endif
{
double i = 0.0;
if (CPLXP(x)) i = IMAG(x);
if (CPLXP(y)) i += IMAG(y);
return makdbl(REALPART(x)+REALPART(y), i);
}
}
if (NINUMP(y)) {
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y))
intbig: {
# ifndef DIGSTOOBIG
long z = pseudolong(INUM(x));
return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
# else
BIGDIG zdigs[DIGSPERLONG];
longdigs(INUM(x), zdigs);
return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
# endif
}
ASRTGO(INEXP(y), bady);
# else
ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
intreal: return makdbl(INUM(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0);
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
SCM t;
ASRTGO(NIMP(x) && BIGP(x), badx);
if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
ASRTGO(NIMP(y) && BIGP(y), bady);
if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
}
if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_sum);
# endif
intbig: {
# ifndef DIGSTOOBIG
long z = pseudolong(INUM(x));
return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
# else
BIGDIG zdigs[DIGSPERLONG];
longdigs(INUM(x), zdigs);
return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
# endif
}
}
# else
ASRTGO(INUMP(x), badx);
ASRTER(INUMP(y), y, ARG2, s_sum);
# endif
#endif
x = INUM(x)+INUM(y);
if (FIXABLE(x)) return MAKINUM(x);
#ifdef BIGDIG
return long2big(x);
#else
# ifdef FLOATS
return makdbl((double)x, 0.0);
# else
wta(y, (char *)OVFLOW, s_sum);
# endif
#endif
}
SCM difference(x, y)
SCM x, y;
{
#ifdef FLOATS
if (NINUMP(x)) {
# ifndef RECKLESS
if (!(NIMP(x)))
badx: wta(x, (char *)ARG1, s_difference);
# endif
if (UNBNDP(y)) {
# ifdef BIGDIG
if (BIGP(x)) {
x = copybig(x, !BIGSIGN(x));
return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ?
big2inum(x, NUMDIGS(x)) : x;
}
# endif
ASRTGO(INEXP(x), badx);
return makdbl(-REALPART(x), CPLXP(x)?-IMAG(x):0.0);
}
if (INUMP(y)) return sum(x, MAKINUM(-INUM(y)));
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(x)) {
if (BIGP(y)) return (NUMDIGS(x) < NUMDIGS(y)) ?
addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) :
addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0);
ASRTGO(INEXP(y), bady);
return makdbl(big2dbl(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
}
ASRTGO(INEXP(x), badx);
if (BIGP(y)) return makdbl(REALPART(x)-big2dbl(y), CPLXP(x)?IMAG(x):0.0);
ASRTGO(INEXP(y), bady);
# else
ASRTGO(INEXP(x), badx);
ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
if (CPLXP(x)) {
if (CPLXP(y))
return makdbl(REAL(x)-REAL(y), IMAG(x)-IMAG(y));
else
return makdbl(REAL(x)-REALPART(y), IMAG(x));
}
return makdbl(REALPART(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
}
if (UNBNDP(y)) {x = -INUM(x); goto checkx;}
if (NINUMP(y)) {
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {
# ifndef DIGSTOOBIG
long z = pseudolong(INUM(x));
return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
# else
BIGDIG zdigs[DIGSPERLONG];
longdigs(INUM(x), zdigs);
return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
# endif
}
# ifndef RECKLESS
if (!(INEXP(y)))
bady: wta(y, (char *)ARG2, s_difference);
# endif
# else
# ifndef RECKLESS
if (!(NIMP(y) && INEXP(y)))
bady: wta(y, (char *)ARG2, s_difference);
# endif
# endif
return makdbl(INUM(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_difference);
if (UNBNDP(y)) {
x = copybig(x, !BIGSIGN(x));
return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ?
big2inum(x, NUMDIGS(x)) : x;
}
if (INUMP(y)) {
# ifndef DIGSTOOBIG
long z = pseudolong(INUM(y));
return addbig((BIGDIG *)&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
# else
BIGDIG zdigs[DIGSPERLONG];
longdigs(INUM(x), zdigs);
return addbig(zdigs, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
# endif
}
ASRTGO(NIMP(y) && BIGP(y), bady);
return (NUMDIGS(x) < NUMDIGS(y)) ?
addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) :
addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0);
}
if (UNBNDP(y)) {x = -INUM(x); goto checkx;}
if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_difference);
# endif
{
# ifndef DIGSTOOBIG
long z = pseudolong(INUM(x));
return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
# else
BIGDIG zdigs[DIGSPERLONG];
longdigs(INUM(x), zdigs);
return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
# endif
}
}
# else
ASRTER(INUMP(x), x, ARG1, s_difference);
if (UNBNDP(y)) {x = -INUM(x); goto checkx;}
ASRTER(INUMP(y), y, ARG2, s_difference);
# endif
#endif
x = INUM(x)-INUM(y);
checkx:
if (FIXABLE(x)) return MAKINUM(x);
#ifdef BIGDIG
return long2big(x);
#else
# ifdef FLOATS
return makdbl((double)x, 0.0);
# else
wta(y, (char *)OVFLOW, s_difference);
# endif
#endif
}
SCM product(x, y)
SCM x, y;
{
if (UNBNDP(y)) {
if (UNBNDP(x)) return MAKINUM(1L);
#ifndef RECKLESS
if (!(NUMBERP(x)))
badx: wta(x, (char *)ARG1, s_product);
#endif
return x;
}
#ifdef FLOATS
if (NINUMP(x)) {
SCM t;
# ifdef BIGDIG
ASRTGO(NIMP(x), badx);
if (BIGP(x)) {
if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
BIGSIGN(x) ^ BIGSIGN(y));
ASRTGO(INEXP(y), bady);
bigreal:
return bigdblop('*', x, REALPART(y), CPLXP(y) ? IMAG(y) : 0.0);
}
ASRTGO(INEXP(x), badx);
# else
ASRTGO(NIMP(x) && INEXP(x), badx);
# endif
if (INUMP(y)) {t = x; x = y; y = t; goto intreal;}
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;}
# ifndef RECKLESS
else if (!(INEXP(y)))
bady: wta(y, (char *)ARG2, s_product);
# endif
# else
# ifndef RECKLESS
if (!(NIMP(y) && INEXP(y)))
bady: wta(y, (char *)ARG2, s_product);
# endif
# endif
if (CPLXP(x)) {
if (CPLXP(y))
return makdbl(REAL(x)*REAL(y)-IMAG(x)*IMAG(y),
REAL(x)*IMAG(y)+IMAG(x)*REAL(y));
else
return makdbl(REAL(x)*REALPART(y), IMAG(x)*REALPART(y));
}
return makdbl(REALPART(x)*REALPART(y),
CPLXP(y)?REALPART(x)*IMAG(y):0.0);
}
if (NINUMP(y)) {
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {
intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y;
{
# ifndef DIGSTOOBIG
long z = pseudolong(INUM(x));
return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
BIGSIGN(y) ? (x>0) : (x<0));
# else
BIGDIG zdigs[DIGSPERLONG];
longdigs(INUM(x), zdigs);
return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
BIGSIGN(y) ? (x>0) : (x<0));
# endif
}
}
ASRTGO(INEXP(y), bady);
# else
ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
intreal: return makdbl(INUM(x)*REALPART(y), CPLXP(y)?INUM(x)*IMAG(y):0.0);
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
ASRTGO(NIMP(x) && BIGP(x), badx);
if (INUMP(y)) {SCM t = x; x = y; y = t; goto intbig;}
ASRTGO(NIMP(y) && BIGP(y), bady);
return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
BIGSIGN(x) ^ BIGSIGN(y));
}
if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_product);
# endif
intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y;
{
# ifndef DIGSTOOBIG
long z = pseudolong(INUM(x));
return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
BIGSIGN(y) ? (x>0) : (x<0));
# else
BIGDIG zdigs[DIGSPERLONG];
longdigs(INUM(x), zdigs);
return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
BIGSIGN(y) ? (x>0) : (x<0));
# endif
}
}
# else
ASRTGO(INUMP(x), badx);
ASRTER(INUMP(y), y, ARG2, s_product);
# endif
#endif
{
long i, j, k;
i = INUM(x);
if (0==i) return x;
j = INUM(y);
k = i * j;
y = MAKINUM(k);
if (k != INUM(y) || k/i != j)
#ifdef BIGDIG
{
int sgn = (i < 0) ^ (j < 0);
# ifndef DIGSTOOBIG
i = pseudolong(i);
j = pseudolong(j);
return mulbig((BIGDIG *)&i, DIGSPERLONG,
(BIGDIG *)&j, DIGSPERLONG, sgn);
# else /* DIGSTOOBIG */
BIGDIG idigs[DIGSPERLONG];
BIGDIG jdigs[DIGSPERLONG];
longdigs(i, idigs);
longdigs(j, jdigs);
return mulbig(idigs, DIGSPERLONG, jdigs, DIGSPERLONG, sgn);
# endif
}
#else
# ifdef FLOATS
return makdbl(((double)i)*((double)j), 0.0);
# else
wta(y, (char *)OVFLOW, s_product);
# endif
#endif
return y;
}
}
/* Use "Smith's formula" to extend dynamic range */
/* David Goldberg
What Every Computer Scientist Should Know About Floating-Point Arithmetic
http://cch.loria.fr/documentation/IEEE754/ACM/goldberg.pdf */
SCM divide(x, y)
SCM x, y;
{
#ifdef FLOATS
double den, a = 1.0;
if (NINUMP(x)) {
# ifndef RECKLESS
if (!(NIMP(x)))
badx: wta(x, (char *)ARG1, s_divide);
# endif
if (UNBNDP(y)) {
# ifdef BIGDIG
if (BIGP(x)) return makdbl(1.0/big2dbl(x), 0.0);
# endif
/* reciprocal */
ASRTGO(INEXP(x), badx);
if (REALP(x)) return makdbl(1.0/REALPART(x), 0.0);
{
y = x;
a = 1.0;
goto real_over_complex;
}
}
# ifdef BIGDIG
if (BIGP(x)) {
SCM z;
if (INUMP(y)) {
z = INUM(y);
ASRTER(z, y, OVFLOW, s_divide);
if (1==z) return x;
if (z < 0) z = -z;
if (z < BIGRAD) {
SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
return divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z) ?
bigdblop('/', x, INUM(y), 0.0) : normbig(w);
}
# ifndef DIGSTOOBIG
z = pseudolong(z);
z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG,
BIGSIGN(x) ? (y>0) : (y<0), 3);
# else
{
BIGDIG zdigs[DIGSPERLONG];
longdigs(z, zdigs);
z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
BIGSIGN(x) ? (y>0) : (y<0), 3);
}
# endif
return z ? z : bigdblop('/', x, INUM(y), 0.0);
}
ASRTGO(NIMP(y), bady);
if (BIGP(y)) {
z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
BIGSIGN(x) ^ BIGSIGN(y), 3);
return z ? z : inex_divbigbig(x, y);
}
ASRTGO(INEXP(y), bady);
return bigdblop('/', x, REALPART(y), CPLXP(y) ? IMAG(y) : 0.0);
}
# endif
ASRTGO(INEXP(x), badx);
if (INUMP(y)) {den = INUM(y); goto basic_div;}
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return bigdblop('\\', y, REALPART(x), CPLXP(x) ? IMAG(x) : 0.0);
ASRTGO(INEXP(y), bady);
# else
ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
if (REALP(y)) {
den = REALPART(y);
basic_div: return makdbl(REALPART(x)/den, CPLXP(x)?IMAG(x)/den:0.0);
}
a = REALPART(x);
if (REALP(x)) goto real_over_complex;
/* Both x and y are complex */
/* Use "Smith's formula" to extend dynamic range */
{
double b = IMAG(x);
double c = REALPART(y);
double d = IMAG(y);
if ((d > 0 ? d : -d) < (c > 0 ? c : -c)) {
double r = d/c;
double i = c + d*r;
return makdbl((a + b*r)/i, (b - a*r)/i);
}
{
double r = c/d;
double i = d + c*r;
return makdbl((b + a*r)/i, (-a + b*r)/i);
}
}
}
if (UNBNDP(y)) {
if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
return makdbl(1.0/((double)INUM(x)), 0.0);
}
if (NINUMP(y)) {
# ifdef BIGDIG
ASRTGO(NIMP(y), bady);
if (BIGP(y)) return bigdblop('\\', y, INUM(x), 0.0);
# ifndef RECKLESS
if (!(INEXP(y)))
bady: wta(y, (char *)ARG2, s_divide);
# endif
# else
# ifndef RECKLESS
if (!(NIMP(y) && INEXP(y)))
bady: wta(y, (char *)ARG2, s_divide);
# endif
# endif
if (REALP(y)) return makdbl(INUM(x)/REALPART(y), 0.0);
a = INUM(x);
real_over_complex:
/* Both x and y are complex */
/* Use "Smith's formula" to extend dynamic range */
{
double c = REALPART(y);
double d = IMAG(y);
if ((d > 0 ? d : -d) < (c > 0 ? c : -c)) {
double r = d/c;
double i = c + d*r;
return makdbl((a)/i, (- a*r)/i);
}
{
double r = c/d;
double i = d + c*r;
return makdbl((a*r)/i, (-a)/i);
}
}
}
#else
# ifdef BIGDIG
if (NINUMP(x)) {
SCM z;
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_divide);
if (UNBNDP(y)) goto ov;
if (INUMP(y)) {
z = INUM(y);
if (!z) goto ov;
if (1==z) return x;
if (z < 0) z = -z;
if (z < BIGRAD) {
SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
if (divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z)) goto ov;
return w;
}
# ifndef DIGSTOOBIG
z = pseudolong(z);
z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG,
BIGSIGN(x) ? (y>0) : (y<0), 3);
# else
{
BIGDIG zdigs[DIGSPERLONG];
longdigs(z, zdigs);
z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
BIGSIGN(x) ? (y>0) : (y<0), 3);
}
# endif
} else {
ASRTGO(NIMP(y) && BIGP(y), bady);
z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
BIGSIGN(x) ^ BIGSIGN(y), 3);
}
if (!z) goto ov;
return z;
}
if (UNBNDP(y)) {
if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
goto ov;
}
if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_divide);
# endif
goto ov;
}
# else
ASRTER(INUMP(x), x, ARG1, s_divide);
if (UNBNDP(y)) {
if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
goto ov;
}
ASRTER(INUMP(y), y, ARG2, s_divide);
# endif
#endif
{
long z = INUM(y);
if ((0==z) || INUM(x)%z) goto ov;
z = INUM(x)/z;
if (FIXABLE(z)) return MAKINUM(z);
#ifdef BIGDIG
return long2big(z);
#endif
#ifdef FLOATS
ov: return makdbl(((double)INUM(x))/((double)INUM(y)), 0.0);
#else
ov: wta(x, (char *)OVFLOW, s_divide);
#endif
}
}
SCM scm_intexpt(z1, z2)
SCM z1, z2;
{
SCM acc = MAKINUM(1L);
int recip = 0;
#ifdef FLOATS
double dacc, dz1;
#endif
if (INUM0==z2) return sum(acc, product(z1, INUM0));
ASRTER(INUMP(z2), z2, ARG2, s_intexpt);
if (acc==z1) return z1;
if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc;
z2 = INUM(z2);
if (z2 < 0) {
z2 = -z2;
recip = 1; /* z1 = divide(z1, UNDEFINED); */
}
if (INUMP(z1)) {
long tmp, iacc = 1, iz1 = INUM(z1);
#ifdef FLOATS
if (recip) { dz1 = iz1; goto flocase; }
#endif
while (1) {
if (0==z2) {
acc = long2num(iacc);
break;
}
if (0==iz1)
if (0==recip) return z1;
else goto overflow;
if (1==z2) {
tmp = iacc*iz1;
if (tmp/iacc != iz1) {
overflow:
z1 = long2num(iz1);
acc = long2num(iacc);
ASRTGO(NFALSEP(z1) && NFALSEP(acc), errout);
goto gencase;
}
acc = long2num(tmp);
break;
}
if (z2 & 1) {
tmp = iacc*iz1;
if (tmp/iacc != iz1) goto overflow;
iacc = tmp;
z2 = z2 - 1; /* so jumping to gencase works */
}
tmp = iz1*iz1;
if (tmp/iz1 != iz1) goto overflow;
iz1 = tmp;
z2 >>= 1;
}
#ifndef RECKLESS
if (FALSEP(acc))
errout: wta(UNDEFINED, (char *)OVFLOW, s_intexpt);
#endif
goto ret;
}
ASRTER(NIMP(z1), z1, ARG1, s_intexpt);
#ifdef FLOATS
if (REALP(z1)) {
dz1 = REALPART(z1);
flocase:
dacc = 1.0;
while(1) {
if (0==z2) break;
if (1==z2) {dacc = dacc*dz1; break;}
if (z2 & 1) dacc = dacc*dz1;
dz1 = dz1*dz1;
z2 >>= 1;
}
return makdbl(recip ? 1.0/dacc : dacc, 0.0);
}
#endif
gencase:
while(1) {
if (0==z2) break;
if (1==z2) {acc = product(acc, z1); break;}
if (z2 & 1) acc = product(acc, z1);
z1 = product(z1, z1);
z2 >>= 1;
}
ret: return recip ? divide(acc, UNDEFINED) : acc;
}
#ifdef FLOATS
# ifndef HAVE_ATANH
double asinh(x)
double x;
{
return log(x+sqrt(x*x+1));
}
double acosh(x)
double x;
{
return log(x+sqrt(x*x-1));
}
double atanh(x)
double x;
{
return 0.5*log((1+x)/(1-x));
}
# endif
double scm_truncate(x)
double x;
{
if (x < 0.0) return -floor(-x);
return floor(x);
}
double scm_round(x)
double x;
{
double plus_half = x + 0.5;
double result = floor(plus_half);
/* Adjust so that the round is towards even. */
return (plus_half==result && plus_half / 2 != floor(plus_half / 2))
? result - 1 : result;
}
struct dpair {double x, y;};
void two_doubles(z1, z2, sstring, xy)
SCM z1, z2;
char *sstring;
struct dpair *xy;
{
if (INUMP(z1)) xy->x = INUM(z1);
else {
# ifdef BIGDIG
ASRTGO(NIMP(z1), badz1);
if (BIGP(z1)) xy->x = big2dbl(z1);
else {
# ifndef RECKLESS
if (!(REALP(z1)))
badz1: wta(z1, (char *)ARG1, sstring);
# endif
xy->x = REALPART(z1);}
# else
{ASRTER(NIMP(z1) && REALP(z1), z1, ARG1, sstring);
xy->x = REALPART(z1);}
# endif
}
if (INUMP(z2)) xy->y = INUM(z2);
else {
# ifdef BIGDIG
ASRTGO(NIMP(z2), badz2);
if (BIGP(z2)) xy->y = big2dbl(z2);
else {
# ifndef RECKLESS
if (!(REALP(z2)))
badz2: wta(z2, (char *)ARG2, sstring);
# endif
xy->y = REALPART(z2);}
# else
{
ASRTER(NIMP(z2) && REALP(z2), z2, ARG2, sstring);
xy->y = REALPART(z2);
}
# endif
}
}
SCM expt(z1, z2)
SCM z1, z2;
{
struct dpair xy;
two_doubles(z1, z2, s_expt, &xy);
return makdbl(pow(xy.x, xy.y), 0.0);
}
SCM latan2(z1, z2)
SCM z1, z2;
{
struct dpair xy;
two_doubles(z1, z2, s_atan2, &xy);
return makdbl(atan2(xy.x, xy.y), 0.0);
}
SCM makrect(z1, z2)
SCM z1, z2;
{
struct dpair xy;
two_doubles(z1, z2, s_makrect, &xy);
return makdbl(xy.x, xy.y);
}
SCM makpolar(z1, z2)
SCM z1, z2;
{
struct dpair xy;
two_doubles(z1, z2, s_makpolar, &xy);
return makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y));
}
SCM real_part(z)
SCM z;
{
if (NINUMP(z)) {
# ifdef BIGDIG
ASRTGO(NIMP(z), badz);
if (BIGP(z)) return z;
# ifndef RECKLESS
if (!(INEXP(z)))
badz: wta(z, (char *)ARG1, s_real_part);
# endif
# else
ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_real_part);
# endif
if (CPLXP(z)) return makdbl(REAL(z), 0.0);
}
return z;
}
SCM imag_part(z)
SCM z;
{
if (INUMP(z)) return INUM0;
# ifdef BIGDIG
ASRTGO(NIMP(z), badz);
if (BIGP(z)) return INUM0;
# ifndef RECKLESS
if (!(INEXP(z)))
badz: wta(z, (char *)ARG1, s_imag_part);
# endif
# else
ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_imag_part);
# endif
if (CPLXP(z)) return makdbl(IMAG(z), 0.0);
return flo0;
}
SCM scm_abs(z)
SCM z;
{
if (INUMP(z)) return scm_iabs(z);
ASRTGO(NIMP(z), badz);
# ifdef BIGDIG
if (BIGP(z)) return scm_iabs(z);
# endif
if (!REALP(z))
badz: wta(z, (char *)ARG1, s_abs);
return makdbl(fabs(REALPART(z)), 0.0);
}
SCM scm_magnitude(z)
SCM z;
{
if (INUMP(z)) return scm_iabs(z);
ASRTGO(NIMP(z), badz);
# ifdef BIGDIG
if (BIGP(z)) return scm_iabs(z);
# endif
if (!INEXP(z))
badz: wta(z, (char *)ARG1, s_magnitude);
if (CPLXP(z))
{
double i = IMAG(z), r = REAL(z);
if (i < 0) i = -i;
if (r < 0) r = -r;
if (i < r) {
double q = i / r;
return makdbl(r * sqrt(1 + q * q), 0.0);
}
if (0.0==i) return i;
{
double q = r / i;
return makdbl(i * sqrt(1 + q * q), 0.0);
}
}
return makdbl(fabs(REALPART(z)), 0.0);
}
SCM angle(z)
SCM z;
{
double x, y = 0.0;
if (INUMP(z)) {x = (z>=INUM0) ? 1.0 : -1.0; goto do_angle;}
# ifdef BIGDIG
ASRTGO(NIMP(z), badz);
if (BIGP(z)) {x = (TYP16(z)==tc16_bigpos) ? 1.0 : -1.0; goto do_angle;}
# ifndef RECKLESS
if (!(INEXP(z))) {
badz: wta(z, (char *)ARG1, s_angle);}
# endif
# else
ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_angle);
# endif
if (REALP(z)) {x = REALPART(z); goto do_angle;}
x = REAL(z); y = IMAG(z);
do_angle:
return makdbl(atan2(y, x), 0.0);
}
SCM ex2in(z)
SCM z;
{
if (INUMP(z)) return makdbl((double)INUM(z), 0.0);
ASRTGO(NIMP(z), badz);
if (INEXP(z)) return z;
# ifdef BIGDIG
if (BIGP(z)) return makdbl(big2dbl(z), 0.0);
# endif
badz: wta(z, (char *)ARG1, s_ex2in);
}
SCM in2ex(z)
SCM z;
{
if (INUMP(z)) return z;
# ifdef BIGDIG
ASRTGO(NIMP(z), badz);
if (BIGP(z)) return z;
# ifndef RECKLESS
if (!(REALP(z)))
badz: wta(z, (char *)ARG1, s_in2ex);
# endif
# else
ASRTER(NIMP(z) && REALP(z), z, ARG1, s_in2ex);
# endif
# ifdef BIGDIG
{
double u = floor(REALPART(z)+0.5);
if ((u <= MOST_POSITIVE_FIXNUM)
# ifdef hpux
&& (-u <= -MOST_NEGATIVE_FIXNUM) /* workaround for HP700 cc bug */
# endif
) {
SCM ans = MAKINUM((long)u);
if (INUM(ans)==(long)u) return ans;
}
ASRTGO(!((u==2*u) || (u)!=(u)), badz); /* problem? */
return dbl2big(u);
}
# else
return MAKINUM((long)floor(REALPART(z)+0.5));
# endif
}
#else /* ~FLOATS */
static char s_trunc[] = "truncate";
SCM numident(x)
SCM x;
{
# ifdef BIGDIG
ASRTER(INUMP(x) || (NIMP(x) && BIGP(x)), x, ARG1, s_trunc);
# else
ASRTER(INUMP(x), x, ARG1, s_trunc);
# endif
return x;
}
#endif /* FLOATS */
SCM scm_iabs(x)
SCM x;
{
#ifdef BIGDIG
if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_abs);
if (TYP16(x)==tc16_bigpos) return x;
return copybig(x, 0);
}
#else
ASRTER(INUMP(x), x, ARG1, s_abs);
#endif
if (INUM(x) >= 0) return x;
x = -INUM(x);
if (!POSFIXABLE(x))
#ifdef BIGDIG
return long2big(x);
#else
wta(MAKINUM(-x), (char *)OVFLOW, s_abs);
#endif
return MAKINUM(x);
}
#ifdef BIGDIG
# ifdef FLOATS
SCM dbl2big(d)
double d; /* must be integer */
{
sizet i = 0;
long c;
BIGDIG *digits;
SCM ans;
double u = (d < 0)?-d:d;
while (0 != floor(u)) {u /= BIGRAD;i++;}
ans = mkbig(i, d < 0);
digits = BDIGITS(ans);
while (i--) {
u *= BIGRAD;
c = floor(u);
u -= c;
digits[i] = c;
}
ASRTER(0==u, INUM0, OVFLOW, "dbl2big");
return ans;
}
double big2dbl(b)
SCM b;
{
double ans = 0.0;
sizet i = NUMDIGS(b);
BIGDIG *digits = BDIGITS(b);
while (i--) ans = digits[i] + BIGRAD*ans;
if (tc16_bigneg==TYP16(b)) return -ans;
return ans;
}
static double big2scaldbl(b, expt)
SCM b;
int expt;
{
double ans = 0.0;
int i = NUMDIGS(b) - 1;
BIGDIG *digits = BDIGITS(b);
while (i > (expt/BITSPERDIG)) {
ans = digits[i] + BIGRAD*ans;
i--;
}
ans = ldexp(ans, BITSPERDIG - expt);
/*
if (expt = (expt % BITSPERDIG)) {
ans = (digits[i] >> expt) +
(1L << (BITSPERDIG - expt))*ans;
}
if ((1L << (BITSPERDIG - expt - 1)) & digits[i])
ans += 1;
*/
if (tc16_bigneg==TYP16(b)) return -ans;
return ans;
}
static SCM bigdblop(op, b, re, im)
int op;
SCM b;
double re, im;
{
double bm = 0.0;
int i = 0;
if (NUMDIGS(b)*BITSPERDIG < DBL_MAX_EXP) {
bm = big2dbl(b);
}
else {
i = INUM(scm_intlength(b));
if (i < DBL_MAX_EXP) {
i = 0;
bm = big2dbl(b);
}
else {
i = i + 1 - DBL_MAX_EXP;
bm = big2scaldbl(b, i);
}
}
switch (op) {
case '*':
return makdbl(ldexp(bm*re, i), 0.0==im ? 0.0 : ldexp(bm*im, i));
case '/': {
double d = re*re + im*im;
return makdbl(ldexp(bm*(re/d), i), ldexp(-bm*(im/d), i));
}
case '\\':
return makdbl(ldexp(re/bm, -i), 0.0==im ? 0.0 : ldexp(im/bm, -i));
default:
return UNSPECIFIED;
}
}
static SCM inex_divbigbig(a, b)
SCM a, b;
{
double r;
if ((NUMDIGS(a)*BITSPERDIG < DBL_MAX_EXP) &&
(NUMDIGS(b)*BITSPERDIG < DBL_MAX_EXP))
r = big2dbl(a) / big2dbl(b);
else {
int i = INUM(scm_intlength(a));
int j = INUM(scm_intlength(b));
i = (i > j) ? i : j;
if (i < DBL_MAX_EXP)
r = big2dbl(a) / big2dbl(b);
else {
i = i + 1 - DBL_MAX_EXP;
r = big2scaldbl(a, i) / big2scaldbl(b, i);
}
}
return makdbl(r, 0.0);
}
static char s_dfloat_parts[] = "double-float-parts";
SCM scm_dfloat_parts(f)
SCM f;
{
int expt, ndig = dbl_mant_dig;
double mant = frexp(num2dbl(f, (char *)ARG1, s_dfloat_parts), &expt);
# ifdef DBL_MIN_EXP
if (expt < DBL_MIN_EXP)
ndig -= DBL_MIN_EXP - expt;
# endif
mant *= ldexp(1.0, ndig);
expt -= ndig;
return scm_values(dbl2big(mant), MAKINUM(expt), EOL, s_dfloat_parts);
}
static char s_make_dfloat[] = "make-double-float";
SCM scm_make_dfloat(mant, expt)
SCM mant, expt;
{
double dmant = num2dbl(mant, (char *)ARG1, s_make_dfloat);
int e = INUM(expt);
ASRTER(INUMP(expt), expt, ARG2, s_make_dfloat);
ASRTER((dmant < 0 ? -dmant : dmant)<=max_dbl_int, mant,
OUTOFRANGE, s_make_dfloat);
return makdbl(ldexp(dmant, e), 0.0);
}
static char s_next_dfloat[] = "next-double-float";
SCM scm_next_dfloat(f1, f2)
SCM f1, f2;
{
int e, neg = 0;
double d1 = num2dbl(f1, (char *)ARG1, s_next_dfloat);
double dif = num2dbl(f2, (char *)ARG2, s_next_dfloat) - d1;
double d = frexp(d1, &e), eps = dbl_eps;
if (d1 < 0) {neg = 1; dif = -dif; d = -d;}
if (dif > 0) {
# ifdef DBL_MIN_EXP
if (e < DBL_MIN_EXP)
eps = ldexp(eps, DBL_MIN_EXP - e);
else if (0.0==d)
eps = ldexp(1.0, DBL_MIN_EXP - dbl_mant_dig);
# endif
d = ldexp(d + eps, e);
}
else if (dif < 0) {
# ifdef DBL_MIN_EXP
if (e < DBL_MIN_EXP)
eps = ldexp(eps, DBL_MIN_EXP - e);
else if (0.0==d)
eps = ldexp(-1.0, DBL_MIN_EXP - dbl_mant_dig);
# endif
if (0.5==d) eps *= 0.5;
d = ldexp(d - eps, e);
}
else if (0.0==dif)
return f1;
return makdbl(neg ? -d : d, 0.0);
}
# endif
#endif
unsigned long hasher(obj, n, d)
SCM obj;
unsigned long n;
sizet d;
{
switch (7 & PTR2INT(obj)) {
case 2: case 6: /* INUMP(obj) */
return INUM(obj) % n;
case 4:
if (ICHRP(obj))
return (unsigned)(downcase[ICHR(obj)]) % n;
switch ((int) obj) {
#ifndef SICP
case (int) EOL: d = 256; break;
#endif
case (int) BOOL_T: d = 257; break;
case (int) BOOL_F: d = 258; break;
case (int) EOF_VAL: d = 259; break;
default: d = 263; /* perhaps should be error */
}
return d % n;
default: return 263 % n; /* perhaps should be error */
case 0:
switch TYP7(obj) {
default: return 263 % n;
case tc7_smob:
switch TYP16(obj) {
case tcs_bignums:
bighash: return INUM(modulo(obj, MAKINUM(n)));
default: return 263 % n;
#ifdef FLOATS
case tc16_flo:
if (REALP(obj)) {
double r = REALPART(obj);
if (floor(r)==r) {
obj = in2ex(obj);
if (IMP(obj)) return INUM(obj) % n;
goto bighash;
}
}
obj = number2string(obj, MAKINUM(10));
#endif
}
case tcs_symbols: case tc7_string:
return strhash(UCHARS(obj), (sizet) LENGTH(obj), n);
case tc7_vector: {
sizet len = LENGTH(obj);
SCM *data = VELTS(obj);
if (len>5) {
sizet i = d/2;
unsigned long h = 1;
while (i--) h = ((h<<8) + (hasher(data[h % len], n, 2))) % n;
return h;
}
else {
sizet i = len;
unsigned long h = (n)-1;
while (i--) h = ((h<<8) + (hasher(data[i], n, d/len))) % n;
return h;
}
}
case tcs_cons_imcar: case tcs_cons_nimcar:
if (d) return (hasher(CAR(obj), n, d/2)+hasher(CDR(obj), n, d/2)) % n;
else return 1;
case tc7_port:
return ((RDNG & CAR(obj)) ? 260 : 261) % n;
case tcs_closures: case tc7_contin: case tcs_subrs:
return 262 % n;
}
}
}
static char s_hashv[] = "hashv", s_hashq[] = "hashq";
extern char s_obunhash[];
#define s_hash (&s_obunhash[9])
SCM hash(obj, n)
SCM obj;
SCM n;
{
ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hash);
return MAKINUM(hasher(obj, INUM(n), 10));
}
SCM hashv(obj, n)
SCM obj;
SCM n;
{
ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hashv);
if (ICHRP(obj)) return MAKINUM((unsigned)(downcase[ICHR(obj)]) % INUM(n));
if (NIMP(obj) && NUMP(obj)) return MAKINUM(hasher(obj, INUM(n), 10));
else return MAKINUM(obj % INUM(n));
}
SCM hashq(obj, n)
SCM obj;
SCM n;
{
ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hashq);
return MAKINUM((((unsigned) obj) >> 1) % INUM(n));
}
static iproc subr1s[] = {
{"number?", numberp},
{s_inexactp, inexactp},
#ifdef FLOATS
{"complex?", scm_complex_p},
{"real?", realp},
{"rational?", scm_rationalp},
{"integer?", intp},
{s_real_part, real_part},
{s_imag_part, imag_part},
{s_magnitude, scm_magnitude},
{s_angle, angle},
{s_in2ex, in2ex},
{s_ex2in, ex2in},
{s_abs, scm_abs},
# ifdef BIGDIG
{s_dfloat_parts, scm_dfloat_parts},
# endif
#else
{"complex?", numberp},
{"real?", numberp},
{"rational?", numberp},
{"integer?", exactp},
{"floor", numident},
{"ceiling", numident},
{s_trunc, numident},
{"round", numident},
{s_abs, scm_iabs},
#endif
{s_zerop, zerop},
{s_positivep, positivep},
{s_negativep, negativep},
{s_str2list, string2list},
{"list->string", string},
{s_st_copy, string_copy},
{"list->vector", vector},
{s_vect2list, vector2list},
{0, 0}};
static iproc asubrs[] = {
{s_difference, difference},
{s_divide, divide},
{s_max, lmax},
{s_min, lmin},
{s_sum, sum},
{s_product, product},
{0, 0}};
static iproc subr2s[] = {
#ifdef FLOATS
{s_makrect, makrect},
{s_makpolar, makpolar},
{s_atan2, latan2},
{s_expt, expt},
# ifdef BIGDIG
{s_make_dfloat, scm_make_dfloat},
{s_next_dfloat, scm_next_dfloat},
# endif
#endif
#ifdef INUMS_ONLY
{s_memv, memq},
{s_assv, assq},
#else
{s_memv, memv},
{s_assv, assv},
#endif
{s_intexpt, scm_intexpt},
{s_list_tail, list_tail},
{s_ve_fill, vector_fill},
{s_st_fill, string_fill},
{s_hash, hash},
{s_hashv, hashv},
{s_hashq, hashq},
{0, 0}};
static iproc subr2os[] = {
{s_str2number, string2number},
{s_number2string, number2string},
{0, 0}};
static iproc rpsubrs[] = {
#ifdef INUMS_ONLY
{"eqv?", eq},
#else
{"eqv?", eqv},
#endif
{s_eqp, eqp},
{s_lessp, lessp},
{s_grp, greaterp},
{s_leqp, leqp},
{s_greqp, greqp},
{0, 0}};
#ifdef FLOATS
static dblproc cxrs[] = {
{"floor", floor},
{"ceiling", ceil},
{"truncate", scm_truncate},
{"round", scm_round},
{"$abs", fabs},
{"real-sqrt", sqrt},
{"real-exp", exp},
{"real-ln", log},
{"real-log10", log10},
{"real-sin", sin},
{"real-cos", cos},
{"real-tan", tan},
{"real-asin", asin},
{"real-acos", acos},
{"real-atan", atan},
{"real-sinh", sinh},
{"real-cosh", cosh},
{"real-tanh", tanh},
{"real-asinh", asinh},
{"real-acosh", acosh},
{"real-atanh", atanh},
{0, 0}};
#endif
#ifdef FLOATS
static void safe_add_1(f, fsum)
double f, *fsum;
{
*fsum = f + 1.0;
}
#endif
void init_scl()
{
init_iprocs(subr1s, tc7_subr_1);
init_iprocs(subr2os, tc7_subr_2o);
init_iprocs(subr2s, tc7_subr_2);
init_iprocs(asubrs, tc7_asubr);
init_iprocs(rpsubrs, tc7_rpsubr);
#ifdef SICP
add_feature("sicp");
#endif
#ifdef FLOATS
init_iprocs((iproc *)cxrs, tc7_cxr);
# ifdef SINGLES
NEWCELL(flo0);
CAR(flo0) = tc_flo;
FLO(flo0) = 0.0;
# else
DEFER_INTS;
flo0 = must_malloc_cell(1L*sizeof(double), (SCM)tc_dblr, "real");
REAL(flo0) = 0.0;
ALLOW_INTS;
# endif
# ifndef _MSC_VER
DEFER_INTS;
scm_narn = must_malloc_cell(2L*sizeof(double), (SCM)tc_dblc, "complex");
REAL(scm_narn) = 0.0/0.0;
IMAG(scm_narn) = 0.0/0.0;
ALLOW_INTS;
# endif
# ifdef DBL_DIG
dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
# else
{ /* determine floating point precision */
double f = 0.1;
volatile double fsum = 1.0+f;
while (fsum != 1.0) {
f /= 10.0;
if (++dblprec > 20) break;
safe_add_1(f, &fsum);
}
dblprec = dblprec-1;
}
# endif /* DBL_DIG */
# ifdef DBL_MANT_DIG
dbl_mant_dig = DBL_MANT_DIG;
# else
{ /* means we #defined it. */
volatile double fsum = 0.0;
double eps = 1.0;
int i = 0;
while (fsum != 1.0) {
eps = 0.5 * eps;
safe_add_1(eps, &fsum);
i++;
}
dbl_mant_dig = i;
}
# endif /* DBL_MANT_DIG */
max_dbl_int = pow(2.0, dbl_mant_dig - 1.0);
max_dbl_int = max_dbl_int + (max_dbl_int - 1.0);
dbl_eps = ldexp(1.0, - dbl_mant_dig);
sysintern("double-float-mantissa-length", MAKINUM(dbl_mant_dig));
#endif
}
scm-5e5/continue.h 0000644 0017052 0001750 00000010500 10750222611 012017 0 ustar tb tb /* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 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
* .
*/
/* "continue.h" Scheme Continuations for C.
Author: Aubrey Jaffer. */
/* If stack is not longword aligned then */
/* #define SHORT_ALIGN */
#ifdef THINK_C
# define SHORT_ALIGN
#endif
#ifdef __MWERKS__
# ifdef __MC68K__
# define SHORT_ALIGN
# endif
#endif
#ifdef MSDOS
# ifndef _M_ARM
/* arm processors need DWORD aligned data access */
# define SHORT_ALIGN
# endif
#endif
#ifdef atarist
# define SHORT_ALIGN
#endif
#ifdef SHORT_ALIGN
typedef short STACKITEM;
#else
typedef long STACKITEM;
#endif
/* If stacks grow up then */
/* #define STACK_GROWS_UP */
#ifdef hp9000s800
# define STACK_GROWS_UP
#endif
#ifdef pyr
# define STACK_GROWS_UP
#endif
#ifdef nosve
# define STACK_GROWS_UP
#endif
#ifdef _UNICOS
# define STACK_GROWS_UP
#endif
/* James Clark came up with this neat one instruction fix for
continuations on the SPARC. It flushes the register windows so
that all the state of the process is contained in the stack. */
#ifdef sparc
# define FLUSH_REGISTER_WINDOWS asm("ta 3")
#else
# define FLUSH_REGISTER_WINDOWS /* empty */
#endif
#ifdef vax
# ifndef CHEAP_CONTINUATIONS
typedef int jump_buf[17];
extern int setjump(jump_buf env);
extern int longjump(jump_buf env, int ret);
# else
# include
# define jump_buf jmp_buf
# define setjump setjmp
# define longjump longjmp
# endif
#else /* ndef vax */
# ifdef _CRAY1
typedef int jump_buf[112];
extern int setjump(jump_buf env);
extern int longjump(jump_buf env, int ret);
# else /* ndef _CRAY1 */
# ifndef PLAN9
# include
# include
# endif
# ifdef SIG_UNBLOCK
# define jump_buf sigjmp_buf
# define setjump(buf) sigsetjmp((buf), !0)
# define longjump siglongjmp
# else
# define jump_buf jmp_buf
# define setjump setjmp
# define longjump longjmp
# endif /* ndef SIG_UNBLOCK */
# endif /* ndef _CRAY1 */
#endif /* ndef vax */
/* `other' is a CONTINUATION slot for miscellaneous data of type
CONTINUATION_OTHER. */
#ifndef CONTINUATION_OTHER
# define CONTINUATION_OTHER int
#endif
struct Continuation {jump_buf jmpbuf;
long thrwval;
long length;
STACKITEM *stkbse;
#ifdef __ia64__
long *bspbse;
long bsplength;
long rnat;
#endif
CONTINUATION_OTHER other;
struct Continuation *parent;
};
typedef struct Continuation CONTINUATION;
#ifndef P
# ifdef USE_ANSI_PROTOTYPES
# define P(s) s
# else
# define P(s) ()
# endif
#endif
extern long thrown_value;
long stack_size P((STACKITEM *start));
CONTINUATION *make_root_continuation P((STACKITEM *stack_base));
CONTINUATION *make_continuation P((CONTINUATION *parent_cont));
void free_continuation P((CONTINUATION *cont));
void dynthrow P((long *a));
void grow_throw P((long *a));
void throw_to_continuation P((CONTINUATION *cont, long val,
CONTINUATION *root_cont));
/* how to get the local definition for malloc */
#ifndef STDC_HEADERS
# ifndef malloc
char *malloc P((sizet size));
# endif
char *realloc P((char *ptr, sizet size));
#endif
/* PTR_LT defines how to compare two addresses (which may not be in
the same array). */
#if defined(__TURBOC__) && !defined(__TOS__)
# ifdef PROT386
# define PTR_LT(x, y) (((long)(x)) < ((long)(y)))
# else
# define PTR_LT(x, y) ((x) < (y))
# endif
#else /* not __TURBOC__ */
# ifdef nosve
# define PTR_MASK 0xffffffffffff
# define PTR_LT(x, y) (((int)(x)&PTR_MASK) < ((int)(y)&PTR_MASK))
# else
# define PTR_LT(x, y) ((x) < (y))
# endif
#endif
#define PTR_GT(x, y) PTR_LT(y, x)
#define PTR_LE(x, y) (!PTR_GT(x, y))
#define PTR_GE(x, y) (!PTR_LT(x, y))
scm-5e5/findexec.c 0000644 0017052 0001750 00000012775 10750241111 011767 0 ustar tb tb /* "findexec.c" was part of DLD, a dynamic link/unlink editor for C.
* Copyright (C) 1990 by 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 */
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 */
getcwd(tbuf, MAXPATHLEN);
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)
getcwd(tbuf, MAXPATHLEN); /* was getwd(tbuf); */
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-5e5/x.h 0000644 0017052 0001750 00000010012 07673755441 010466 0 ustar tb tb /* x.c */
SCM make_xwindow(SCM display, int screen_number, Drawable win, int pxmp, int rootp);
SCM make_xcolormap(SCM sdpy, Colormap cmp);
SCM make_xdisplay(Display *d);
SCM make_xgcontext(SCM d, int screen_number, GC gc, int rootp);
SCM make_xcursor(SCM display, Cursor cursor);
SCM make_xfont(SCM display, Font font, SCM name);
SCM make_xvisual(XVisualInfo *vsl);
SCM CCC2SCM_P(XcmsCCC ccc);
SCM CCC2SCM(XcmsCCC ccc);
SCM make_xevent(XEvent *e);
size_t x_free_xevent(CELLPTR ptr);
void scm2XPoint(int signp, SCM dat, XPoint *ipr, char *pos, char *s_caller);
int scm2XColor(SCM s_dat, XColor *xclr);
int scm2xpointslen(SCM sara, char *s_caller);
void scm2display_screen(SCM dat, SCM optidx, struct display_screen *dspscn, char *s_caller);
SCM thevalue(SCM obj);
Pixmap thepxmap(SCM obj, char *s_caller);
Font thefont(SCM obj, char *s_caller);
Colormap thecmap(SCM obj, char *s_caller);
Cursor thecsr(SCM obj, char *s_caller);
int thebool(SCM obj, char *s_caller);
int theint(SCM obj, char *s_caller);
int theuint(SCM obj, char *s_caller);
SCM x_open_display(SCM dpy_name);
SCM x_display_debug(SCM sd, SCM si);
SCM x_default_screen(SCM sdpy);
SCM x_create_window(SCM swin, SCM spos, SCM sargs);
SCM x_create_pixmap(SCM obj, SCM s_size, SCM s_depth);
SCM x_window_ref(SCM oargs);
SCM x_window_set(SCM args);
SCM x_window_geometry(SCM swin);
SCM x_window_geometry_set(SCM args);
SCM x_close(SCM obj);
SCM x_flush(SCM sd, SCM si);
SCM x_create_colormap(SCM swin, SCM s_vis, SCM s_alloc);
SCM x_recreate_colormap(SCM s_cm);
SCM x_install_colormap(SCM s_cm, SCM s_flg);
SCM x_alloc_color_cells(SCM scmap, SCM spxls, SCM sargs);
SCM x_free_color_cells(SCM scmap, SCM spxls, SCM sargs);
SCM x_find_color(SCM scmap, SCM dat);
SCM x_color_set(SCM scmap, SCM s_pix, SCM dat);
SCM x_color_ref(SCM scmap, SCM sidx);
SCM x_map_window(SCM swin);
SCM x_map_subwindows(SCM swin);
SCM x_unmap_window(SCM swin);
SCM x_unmap_subwindows(SCM swin);
SCM x_create_gc(SCM args);
SCM x_gc_set(SCM args);
SCM x_copy_gc(SCM dst, SCM src, SCM args);
SCM x_gc_ref(SCM oargs);
SCM x_create_cursor(SCM sdpy, SCM scsr, SCM sargs);
SCM x_load_font(SCM sdpy, SCM fntnam);
SCM x_protocol_version(SCM sd, SCM si);
SCM x_server_vendor(SCM sd, SCM si);
SCM x_vendor_release(SCM sd, SCM si);
int x_scm_error_handler(Display *display, XErrorEvent *xee);
SCM x_q_length(SCM sd, SCM si);
SCM x_pending(SCM sd, SCM si);
SCM x_events_queued(SCM sd, SCM si);
SCM x_next_event(SCM sd, SCM si);
SCM x_peek_event(SCM sd, SCM si);
SCM x_screen_count(SCM sd, SCM si);
SCM x_screen_cells(SCM sd, SCM si);
SCM x_screen_depth(SCM sd, SCM si);
SCM x_screen_depths(SCM sd, SCM si);
SCM x_screen_size(SCM sd, SCM si);
SCM x_screen_dimm(SCM sd, SCM si);
SCM x_screen_black(SCM sd, SCM si);
SCM x_screen_white(SCM sd, SCM si);
XVisualInfo *visual2visualinfo(Display *dsp, Visual *vis);
SCM x_make_visual(SCM sd, SCM sdepth, SCM sclass);
SCM x_visual_geometry(SCM svsl);
SCM x_visual_class(SCM svsl);
SCM x_root_window(SCM sdpy, SCM sscr);
SCM x_default_colormap(SCM sdpy, SCM sscr);
SCM x_default_gcontext(SCM sdpy, SCM sscr);
SCM x_default_visual(SCM sdpy, SCM sscr);
SCM x_default_ccc(SCM sdpy, SCM sscr);
SCM x_propdata2scm(Atom type, int format, unsigned long nitems, unsigned char *data);
SCM x_get_window_property(SCM swin, SCM sprop, SCM sargs);
SCM x_list_properties(SCM swin);
SCM x_clear_area(SCM swin, SCM spos, SCM sargs);
SCM x_fill_rectangle(SCM swin, SCM sgc, SCM sargs);
void xldraw_string(SCM sdbl, SCM sgc, SCM sargs, int (*proc)(void), char *s_caller);
SCM x_draw_string(SCM sdbl, SCM sgc, SCM sargs);
SCM x_image_string(SCM sdbl, SCM sgc, SCM sargs);
SCM x_draw_points(SCM sdbl, SCM sgc, SCM sargs);
SCM xldraw_lines(SCM sdbl, SCM sgc, SCM sargs, int funcod, char *s_caller);
SCM x_draw_segments(SCM sdbl, SCM sgc, SCM sargs);
SCM x_draw_lines(SCM sdbl, SCM sgc, SCM sargs);
SCM x_fill_poly(SCM sdbl, SCM sgc, SCM sargs);
SCM x_read_bitmap_file(SCM sdbl, SCM sfname);
SCM x_make_bool(int f);
SCM x_event_ref(SCM sevent, SCM sfield);
SCM x_event_keysym(SCM sevent);
char *xvisualclass2name(int class);
void x_scm_final(void);
void init_x(void);
scm-5e5/ramap.c 0000644 0017052 0001750 00000143030 10750224160 011274 0 ustar tb tb /* "ramap.c" Array mapping functions for APL-Scheme.
* Copyright (C) 1994, 1995, 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: Radey Shouman */
#include "scm.h"
SCM sc2array P((SCM s, SCM ra, SCM prot));
typedef struct {
char *name;
SCM sproc;
int (* vproc)();
} ra_iproc;
# define BVE_REF(a, i) ((VELTS(a)[(i)/LONG_BIT] & (1L<<((i)%LONG_BIT))) ? 1 : 0)
# define BVE_SET(a, i) (VELTS(a)[(i)/LONG_BIT] |= (1L<<((i)%LONG_BIT)))
# define BVE_CLR(a, i) (VELTS(a)[(i)/LONG_BIT] &= ~(1L<<((i)%LONG_BIT)))
/* Fast, recycling vector ref */
# define RVREF(ra, i, e) (e = cvref(ra, i, e))
/* #define RVREF(ra, i, e) (cvref(ra, i, UNDEFINED)) to turn off */
/* IVDEP means "ignore vector dependencies", meaning we guarantee that
elements of vector operands are not aliased */
# ifdef _UNICOS
# define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
# else
# define IVDEP(test, line) line
# endif
static sizet cind(ra, inds)
SCM ra;
long *inds;
{
sizet i;
int k;
if (!ARRAYP(ra)) return *inds;
i = ARRAY_BASE(ra);
for (k = 0; k < ARRAY_NDIM(ra); k++)
i += (inds[k] - ARRAY_DIMS(ra)[k].lbnd)*ARRAY_DIMS(ra)[k].inc;
return i;
}
/* Checker for array mapping functions:
return values: 4 --> shapes, increments, and bases are the same;
3 --> shapes and increments are the same;
2 --> shapes are the same;
1 --> ras are at least as big as ra0;
0 --> no match.
*/
int ra_matchp(ra0, ras)
SCM ra0, ras;
{
SCM ra1;
array_dim dims;
array_dim *s0 = &dims;
array_dim *s1;
sizet bas0 = 0;
int i, ndim = 1;
int exact = 2 /* 4 */; /* Don't care about values >2 (yet?) */
if (IMP(ra0)) return 0;
switch TYP7(ra0) {
default: return 0;
case tc7_vector:
case tcs_uves:
s0->lbnd = 0;
s0->inc = 1;
s0->ubnd = (long)LENGTH(ra0) - 1;
break;
case tc7_smob:
if (!ARRAYP(ra0)) return 0;
ndim = ARRAY_NDIM(ra0);
s0 = ARRAY_DIMS(ra0);
bas0 = ARRAY_BASE(ra0);
break;
}
while NIMP(ras) {
ra1 = CAR(ras);
switch (IMP(ra1) ? 0 : TYP7(ra1)) {
default: scalar:
CAR(ras) = sc2array(ra1, ra0, EOL); break;
case tc7_vector:
case tcs_uves:
if (1 != ndim) return 0;
switch (exact) {
case 4: if (0 != bas0) exact = 3;
case 3: if (1 != s0->inc) exact = 2;
case 2: if ((0==s0->lbnd) && (s0->ubnd==LENGTH(ra1) - 1)) break;
exact = 1;
case 1: if (s0->lbnd < 0 || s0->ubnd >= LENGTH(ra1))
if (s0->lbnd <= s0->ubnd) return 0;
}
break;
case tc7_smob:
if (!ARRAYP(ra1)) goto scalar;
if (ndim != ARRAY_NDIM(ra1)) {
if (0==ARRAY_NDIM(ra1))
goto scalar;
else
return 0;
}
s1 = ARRAY_DIMS(ra1);
if (bas0 != ARRAY_BASE(ra1)) exact = 3;
for (i = 0; i < ndim; i++)
switch (exact) {
case 4: case 3:
if (s0[i].inc != s1[i].inc)
exact = 2;
case 2:
if (s0[i].lbnd==s1[i].lbnd && s0[i].ubnd==s1[i].ubnd)
break;
exact = 1;
default:
if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
if (s0[i].lbnd <= s0[i].ubnd) return 0;
}
break;
}
ras = CDR(ras);
}
return exact;
}
static char s_ra_mismatch[] = "array shape mismatch";
int ramapc(cproc, data, ra0, lra, what)
int (*cproc)();
SCM data, ra0, lra;
const char *what;
{
SCM z, vra0, ra1, vra1;
SCM lvra, *plvra;
int k, kmax = (ARRAYP(ra0) ? ARRAY_NDIM(ra0) - 1 : 0);
switch (ra_matchp(ra0, lra)) {
default:
case 0: wta(ra0, s_ra_mismatch, what);
case 2: case 3: case 4: /* Try unrolling arrays */
if (kmax < 0) goto gencase;
vra0 = (0==kmax ? ra0 : array_contents(ra0, UNDEFINED));
if (IMP(vra0)) goto gencase;
if (!ARRAYP(vra0)) {
vra1 = make_ra(1);
ARRAY_BASE(vra1) = 0;
ARRAY_DIMS(vra1)->lbnd = 0;
ARRAY_DIMS(vra1)->ubnd = LENGTH(vra0) - 1;
ARRAY_DIMS(vra1)->inc = 1;
ARRAY_V(vra1) = vra0;
vra0 = vra1;
}
lvra = EOL;
plvra = &lvra;
for (z = lra; NIMP(z); z = CDR(z)) {
vra1 = ra1 = (0==kmax ? CAR(z) : array_contents(CAR(z), UNDEFINED));
if (FALSEP(ra1)) goto gencase;
if (!ARRAYP(ra1)) {
vra1 = make_ra(1);
ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd;
ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd;
ARRAY_BASE(vra1) = 0;
ARRAY_DIMS(vra1)->inc = 1;
ARRAY_V(vra1) = ra1;
}
*plvra = cons(vra1, EOL);
plvra = &CDR(*plvra);
}
return (UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
case 1: gencase: /* Have to loop over all dimensions. */
{
SCM hp_indv;
long auto_indv[5];
long *indv = &auto_indv[0];
if (ARRAY_NDIM(ra0) >= 5) {
scm_protect_temp(&hp_indv);
hp_indv = make_uve(ARRAY_NDIM(ra0)+0L, MAKINUM(-32L));
indv = (long *)VELTS(hp_indv);
}
vra0 = make_ra(1);
if (ARRAYP(ra0)) {
if (kmax < 0) {
ARRAY_DIMS(vra0)->lbnd = 0;
ARRAY_DIMS(vra0)->ubnd = 0;
ARRAY_DIMS(vra0)->inc = 1;
}
else {
ARRAY_DIMS(vra0)->lbnd = ARRAY_DIMS(ra0)[kmax].lbnd;
ARRAY_DIMS(vra0)->ubnd = ARRAY_DIMS(ra0)[kmax].ubnd;
ARRAY_DIMS(vra0)->inc = ARRAY_DIMS(ra0)[kmax].inc;
}
ARRAY_BASE(vra0) = ARRAY_BASE(ra0);
ARRAY_V(vra0) = ARRAY_V(ra0);
}
else {
ARRAY_DIMS(vra0)->lbnd = 0;
ARRAY_DIMS(vra0)->ubnd = LENGTH(ra0) - 1;
ARRAY_DIMS(vra0)->inc = 1;
ARRAY_BASE(vra0) = 0;
ARRAY_V(vra0) = ra0;
ra0 = vra0;
}
lvra = EOL;
plvra = &lvra;
for (z = lra; NIMP(z); z = CDR(z)) {
ra1 = CAR(z);
vra1 = make_ra(1);
ARRAY_DIMS(vra1)->lbnd = ARRAY_DIMS(vra0)->lbnd;
ARRAY_DIMS(vra1)->ubnd = ARRAY_DIMS(vra0)->ubnd;
if (ARRAYP(ra1)) {
if (kmax >= 0)
ARRAY_DIMS(vra1)->inc = ARRAY_DIMS(ra1)[kmax].inc;
ARRAY_V(vra1) = ARRAY_V(ra1);
}
else {
ARRAY_DIMS(vra1)->inc = 1;
ARRAY_V(vra1) = ra1;
}
*plvra = cons(vra1, EOL);
plvra = &CDR(*plvra);
}
for (k = 0; k <= kmax; k++)
indv[k] = ARRAY_DIMS(ra0)[k].lbnd;
k = kmax;
do {
if (k==kmax) {
SCM y = lra;
ARRAY_BASE(vra0) = cind(ra0, indv);
for (z = lvra; NIMP(z); z = CDR(z), y = CDR(y))
ARRAY_BASE(CAR(z)) = cind(CAR(y), indv);
if (0==(UNBNDP(data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
return 0;
k--;
continue;
}
if (indv[k] < ARRAY_DIMS(ra0)[k].ubnd) {
indv[k]++;
k++;
continue;
}
indv[k] = ARRAY_DIMS(ra0)[k].lbnd - 1;
k--;
} while (k >= 0);
return 1;
}
}
}
SCM array_fill(ra, fill)
SCM ra, fill;
{
ramapc(rafill, fill, ra, EOL, s_array_fill);
return UNSPECIFIED;
}
static char s_sarray_copy[] = "serial-array:copy!";
static char s_array_copy[] = "array:copy!";
static int racp(src, dst)
SCM dst, src;
{
long n = (ARRAY_DIMS(src)->ubnd - ARRAY_DIMS(src)->lbnd + 1);
long inc_d, inc_s = ARRAY_DIMS(src)->inc;
sizet i_d, i_s = ARRAY_BASE(src);
dst = CAR(dst);
inc_d = ARRAY_DIMS(dst)->inc;
i_d = ARRAY_BASE(dst);
src = ARRAY_V(src);
dst = ARRAY_V(dst);
switch TYP7(dst) {
default: gencase: case tc7_vector:
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
aset(dst, cvref(src, i_s, UNDEFINED), MAKINUM(i_d));
break;
case tc7_string: if (tc7_string != TYP7(src)) goto gencase;
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
CHARS(dst)[i_d] = CHARS(src)[i_s];
break;
case tc7_Vbool: if (tc7_Vbool != TYP7(src)) goto gencase;
if (1==inc_d && 1==inc_s && i_s%LONG_BIT==i_d%LONG_BIT && n>=LONG_BIT) {
long *sv = (long *)VELTS(src);
long *dv = (long *)VELTS(dst);
sv += i_s/LONG_BIT;
dv += i_d/LONG_BIT;
if (i_s % LONG_BIT) { /* leading partial word */
*dv = (*dv & ~(~0L<<(i_s%LONG_BIT))) | (*sv & (~0L<<(i_s%LONG_BIT)));
dv++;
sv++;
n -= LONG_BIT - (i_s % LONG_BIT);
}
IVDEP(src != dst,
for (; n >= LONG_BIT; n -= LONG_BIT, sv++, dv++)
*dv = *sv;)
if (n) /* trailing partial word */
*dv = (*dv & (~0L< 0; i_s += inc_s, i_d += inc_d)
if (VELTS(src)[i_s/LONG_BIT] & (1L << (i_s%LONG_BIT)))
VELTS(dst)[i_d/LONG_BIT] |= (1L << (i_d%LONG_BIT));
else
VELTS(dst)[i_d/LONG_BIT] &= ~(1L << (i_d%LONG_BIT));
}
break;
case tc7_VfixN32:
case tc7_VfixZ32: {
long *d = (long *)VELTS(dst), *s = (long *)VELTS(src);
if (TYP7(src)==TYP7(dst)) {
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = s[i_s];)
}
else if (tc7_VfixZ32==TYP7(dst))
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = num2long(cvref(src, i_s, UNDEFINED),
(char *)ARG2, s_array_copy);
else
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = num2ulong(cvref(src, i_s, UNDEFINED),
(char *)ARG2, s_array_copy);
break;
}
# ifdef FLOATS
case tc7_VfloR32: {
float *d = (float *)VELTS(dst);
float *s = (float *)VELTS(src);
switch TYP7(src) {
default: goto gencase;
case tc7_VfixZ32: case tc7_VfixN32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = ((long *)s)[i_s]; )
break;
case tc7_VfloR32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = s[i_s]; )
break;
case tc7_VfloR64:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = ((double *)s)[i_s]; )
break;
}
break;
}
case tc7_VfloR64: {
double *d = (double *)VELTS(dst);
double *s = (double *)VELTS(src);
switch TYP7(src) {
default: goto gencase;
case tc7_VfixZ32: case tc7_VfixN32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = ((long *)s)[i_s]; )
break;
case tc7_VfloR32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = ((float *)s)[i_s];)
break;
case tc7_VfloR64:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = s[i_s];)
break;
}
break;
}
case tc7_VfloC32: {
float (*d)[2] = (float (*)[2])VELTS(dst);
float (*s)[2] = (float (*)[2])VELTS(src);
switch TYP7(src) {
default: goto gencase;
case tc7_VfixZ32: case tc7_VfixN32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = ((long *)s)[i_s];
d[i_d][1] = 0.0;
})
break;
case tc7_VfloR32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = ((float *)s)[i_s];
d[i_d][1] = 0.0;
})
break;
case tc7_VfloR64:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = ((double *)s)[i_s];
d[i_d][1] = 0.0;
})
break;
case tc7_VfloC32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = s[i_s][0];
d[i_d][1] = s[i_s][1];
})
break;
case tc7_VfloC64:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = ((double (*)[2])s)[i_s][0];
d[i_d][1] = ((double (*)[2])s)[i_s][1];
})
break;
}
}
case tc7_VfloC64: {
double (*d)[2] = (double (*)[2])VELTS(dst);
double (*s)[2] = (double (*)[2])VELTS(src);
switch TYP7(src) {
default: goto gencase;
case tc7_VfixZ32: case tc7_VfixN32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = ((long *)s)[i_s];
d[i_d][1] = 0.0;
})
break;
case tc7_VfloR32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = ((float *)s)[i_s];
d[i_d][1] = 0.0;
})
break;
case tc7_VfloR64:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = ((double *)s)[i_s];
d[i_d][1] = 0.0;
})
break;
case tc7_VfloC32:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = ((float (*)[2])s)[i_s][0];
d[i_d][1] = ((float (*)[2])s)[i_s][1];
})
break;
case tc7_VfloC64:
IVDEP(src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) {
d[i_d][0] = s[i_s][0];
d[i_d][1] = s[i_s][1];
})
break;
}
}
# endif /* FLOATS */
}
return 1;
}
SCM array_copy(dst, src)
SCM dst;
SCM src;
{
#ifndef RECKLESS
if (INUM0==array_rank(dst))
ASRTER(NIMP(dst) && ARRAYP(dst) && INUM0==array_rank(src),
dst, ARG2, s_array_copy);
#endif
ramapc(racp, UNDEFINED, src, cons(dst, EOL), s_array_copy);
return UNSPECIFIED;
}
SCM ra2contig(ra, copy)
SCM ra;
int copy;
{
SCM ret;
long inc = 1;
sizet k, len = 1;
for (k = ARRAY_NDIM(ra); k--;)
len *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
k = ARRAY_NDIM(ra);
if (ARRAY_CONTP(ra) && ((0==k) || (1==ARRAY_DIMS(ra)[k-1].inc))) {
if (tc7_Vbool != TYP7(ARRAY_V(ra)))
return ra;
if ((len==LENGTH(ARRAY_V(ra)) &&
0==ARRAY_BASE(ra) % LONG_BIT &&
0==len % LONG_BIT))
return ra;
}
ret = make_ra(k);
ARRAY_BASE(ret) = 0;
while (k--) {
ARRAY_DIMS(ret)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd;
ARRAY_DIMS(ret)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd;
ARRAY_DIMS(ret)[k].inc = inc;
inc *= ARRAY_DIMS(ra)[k].ubnd - ARRAY_DIMS(ra)[k].lbnd + 1;
}
CAR(ret) |= ARRAY_CONTIGUOUS;
ARRAY_V(ret) = make_uve(inc+0L, array_prot(ra));
if (copy) array_copy(ret, ra);
return ret;
}
static char s_ura_rd[] = "uniform-array-read!";
SCM ura_read(ra, port)
SCM ra, port;
{
SCM ret, cra;
if (NIMP(ra) && ARRAYP(ra)) {
cra = ra2contig(ra, 0);
ret = uve_read(cra, port);
if (cra != ra) array_copy(ra, cra);
return ret;
}
else return uve_read(ra, port);
}
static char s_ura_wr[] = "uniform-array-write";
SCM ura_write(ra, port)
SCM ra, port;
{
if (NIMP(ra) && ARRAYP(ra))
return uve_write(ra2contig(ra, 1), port);
else
return uve_write(ra, port);
}
static char s_sc2array[] = "scalar->array";
SCM sc2array(s, ra, prot)
SCM s, ra, prot;
{
SCM res;
ASRTER(NIMP(ra), ra, ARG2, s_sc2array);
if (ARRAYP(ra)) {
int k = ARRAY_NDIM(ra);
res = make_ra(k);
while (k--) {
ARRAY_DIMS(res)[k].ubnd = ARRAY_DIMS(ra)[k].ubnd;
ARRAY_DIMS(res)[k].lbnd = ARRAY_DIMS(ra)[k].lbnd;
ARRAY_DIMS(res)[k].inc = 0;
}
ra = ARRAY_V(ra);
}
else {
ASRTER(BOOL_T==arrayp(ra, UNDEFINED), ra, ARG2, s_sc2array);
res = make_ra(1);
ARRAY_DIMS(res)->ubnd = LENGTH(ra) - 1;
ARRAY_DIMS(res)->lbnd = 0;
ARRAY_DIMS(res)->inc = 0;
}
if (NIMP(s) && ARRAYP(s) && 0==ARRAY_NDIM(s)) {
ARRAY_BASE(res) = ARRAY_BASE(s);
ARRAY_V(res) = ARRAY_V(s);
return res;
}
ARRAY_BASE(res) = 0;
ARRAY_V(res) = make_uve(1L, NULLP(prot) ? array_prot(ra) : CAR(prot));
switch TYP7(ARRAY_V(res)) {
case tc7_vector:
break;
case tc7_Vbool:
if (BOOL_T==s || BOOL_F==s) break;
goto mismatch;
case tc7_string:
if (ICHRP(s)) break;
goto mismatch;
case tc7_VfixN32:
if (INUMP(s) && INUM(s)>=0) break;
#ifdef BIGDIG
if (NIMP(s) && tc16_bigpos==TYP16(s) && NUMDIGS(s)<=DIGSPERLONG) break;
#endif
goto mismatch;
case tc7_VfixZ32:
if (INUMP(s)) break;
#ifdef BIGDIG
if (NIMP(s) && BIGP(s) && NUMDIGS(s)<=DIGSPERLONG) break;
#endif
goto mismatch;
#ifdef FLOATS
case tc7_VfloR32:
case tc7_VfloR64:
if (NUMBERP(s) && !(NIMP(s) && CPLXP(s))) break;
goto mismatch;
case tc7_VfloC32:
case tc7_VfloC64:
if (NUMBERP(s)) break;
goto mismatch;
#endif
mismatch: ARRAY_V(res) = make_vector(MAKINUM(1), s);
return res;
}
aset(ARRAY_V(res), s, INUM0);
return res;
}
/* Functions callable by ARRAY-MAP! */
int ra_eqp(ra0, ras)
SCM ra0, ras;
{
SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras));
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
long inc0 = ARRAY_DIMS(ra0)->inc;
long inc1 = ARRAY_DIMS(ra1)->inc;
long inc2 = ARRAY_DIMS(ra2)->inc;
ra0 = ARRAY_V(ra0);
ra1 = ARRAY_V(ra1);
ra2 = ARRAY_V(ra2);
switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) {
default: {
SCM e1 = UNDEFINED, e2 = UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (FALSEP(eqp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))))
BVE_CLR(ra0, i0);
break;
}
case tc7_VfixN32:
case tc7_VfixZ32:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (VELTS(ra1)[i1] != VELTS(ra2)[i2]) BVE_CLR(ra0, i0);
break;
# ifdef FLOATS
case tc7_VfloR32:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (((float *)VELTS(ra1))[i1] != ((float *)VELTS(ra2))[i2])
BVE_CLR(ra0, i0);
break;
case tc7_VfloR64:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (((double *)VELTS(ra1))[i1] != ((double *)VELTS(ra2))[i2])
BVE_CLR(ra0, i0);
break;
case tc7_VfloC32:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (((float *)VELTS(ra1))[2*i1] != ((float *)VELTS(ra2))[2*i2] ||
((float *)VELTS(ra1))[2*i1+1] != ((float *)VELTS(ra2))[2*i2+1])
BVE_CLR(ra0, i0);
break;
case tc7_VfloC64:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (((double *)VELTS(ra1))[2*i1] != ((double *)VELTS(ra2))[2*i2] ||
((double *)VELTS(ra1))[2*i1+1] != ((double *)VELTS(ra2))[2*i2+1])
BVE_CLR(ra0, i0);
break;
# endif /*FLOATS*/
}
return 1;
}
/* opt 0 means <, nonzero means >= */
static int ra_compare(ra0, ra1, ra2, opt)
SCM ra0, ra1, ra2;
int opt;
{
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
long inc0 = ARRAY_DIMS(ra0)->inc;
long inc1 = ARRAY_DIMS(ra1)->inc;
long inc2 = ARRAY_DIMS(ra2)->inc;
ra0 = ARRAY_V(ra0);
ra1 = ARRAY_V(ra1);
ra2 = ARRAY_V(ra2);
switch (TYP7(ra1)==TYP7(ra2) ? TYP7(ra1) : 0) {
default: {
SCM e1 = UNDEFINED, e2 = UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (opt ?
NFALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) :
FALSEP(lessp(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))) )
BVE_CLR(ra0, i0);
break;
}
case tc7_VfixN32:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) {
if (BVE_REF(ra0, i0))
if (opt ?
((unsigned long*)VELTS(ra1))[i1] < ((unsigned long*)VELTS(ra2))[i2] :
((unsigned long*)VELTS(ra1))[i1] >= ((unsigned long*)VELTS(ra2))[i2])
BVE_CLR(ra0, i0);
}
break;
case tc7_VfixZ32:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) {
if (BVE_REF(ra0, i0))
if (opt ?
VELTS(ra1)[i1] < VELTS(ra2)[i2] :
VELTS(ra1)[i1] >= VELTS(ra2)[i2])
BVE_CLR(ra0, i0);
}
break;
# ifdef FLOATS
case tc7_VfloR32:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (opt ?
((float *)VELTS(ra1))[i1] < ((float *)VELTS(ra2))[i2] :
((float *)VELTS(ra1))[i1] >= ((float *)VELTS(ra2))[i2])
BVE_CLR(ra0, i0);
break;
case tc7_VfloR64:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (opt ?
((double *)VELTS(ra1))[i1] < ((double *)VELTS(ra2))[i2] :
((double *)VELTS(ra1))[i1] >= ((double *)VELTS(ra2))[i2])
BVE_CLR(ra0, i0);
break;
# endif /*FLOATS*/
}
return 1;
}
int ra_lessp(ra0, ras)
SCM ra0, ras;
{
return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 0);
}
int ra_leqp(ra0, ras)
SCM ra0, ras;
{
return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 1);
}
int ra_grp(ra0, ras)
SCM ra0, ras;
{
return ra_compare(ra0, CAR(CDR(ras)), CAR(ras), 0);
}
int ra_greqp(ra0, ras)
SCM ra0, ras;
{
return ra_compare(ra0, CAR(ras), CAR(CDR(ras)), 1);
}
int ra_sum(ra0, ras)
SCM ra0, ras;
{
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0);
long inc0 = ARRAY_DIMS(ra0)->inc;
ra0 = ARRAY_V(ra0);
if (NNULLP(ras)) {
SCM ra1 = CAR(ras);
sizet i1 = ARRAY_BASE(ra1);
long inc1 = ARRAY_DIMS(ra1)->inc;
ra1 = ARRAY_V(ra1);
switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
ovflow: wta(ra0, (char *)OVFLOW, "+");
default: {
SCM e0 = UNDEFINED, e1 = UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1)
aset(ra0, sum(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
MAKINUM(i0));
break;
}
case tc7_VfixN32: {
unsigned long r;
unsigned long *v0 = (unsigned long *)VELTS(ra0);
unsigned long *v1 = (unsigned long *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
r = v0[i0] + v1[i1];
ASRTGO(r >= v0[i0], ovflow); /* Will prevent vectorization */
v0[i0] = r;
} );
break;
}
case tc7_VfixZ32: {
long r, *v0 = (long *)VELTS(ra0), *v1 = (long *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
r = v0[i0] + v1[i1];
ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]<0 : r<=0 || v1[i1]>0), ovflow);
v0[i0] = r;
} );
break;
}
# ifdef FLOATS
case tc7_VfloR32: {
float *v0 = (float *)VELTS(ra0);
float *v1 = (float *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
v0[i0] += v1[i1]);
break;
}
case tc7_VfloR64: {
double *v0 = (double *)VELTS(ra0);
double *v1 = (double *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
v0[i0] += v1[i1]);
break;
}
case tc7_VfloC32: {
float (*v0)[2] = (float (*)[2])VELTS(ra0);
float (*v1)[2] = (float (*)[2])VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
v0[i0][0] += v1[i1][0];
v0[i0][1] += v1[i1][1];
});
break;
}
case tc7_VfloC64: {
double (*v0)[2] = (double (*)[2])VELTS(ra0);
double (*v1)[2] = (double (*)[2])VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
v0[i0][0] += v1[i1][0];
v0[i0][1] += v1[i1][1];
});
break;
}
# endif /* FLOATS */
}
}
return 1;
}
int ra_difference(ra0, ras)
SCM ra0, ras;
{
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0);
long inc0 = ARRAY_DIMS(ra0)->inc;
ra0 = ARRAY_V(ra0);
if (NULLP(ras)) {
switch TYP7(ra0) {
default: {
SCM e0 = UNDEFINED;
for (; n-- > 0; i0 += inc0)
aset(ra0, difference(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
break;
}
case tc7_VfixZ32: {
long *v0 = VELTS(ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = -v0[i0];
break;
}
# ifdef FLOATS
case tc7_VfloR32: {
float *v0 = (float *)VELTS(ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = -v0[i0];
break;
}
case tc7_VfloR64: {
double *v0 = (double *)VELTS(ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = -v0[i0];
break;
}
case tc7_VfloC32: {
float (*v0)[2] = (float (*)[2])VELTS(ra0);
for (; n-- > 0; i0 += inc0) {
v0[i0][0] = -v0[i0][0];
v0[i0][1] = -v0[i0][1];
}
break;
}
case tc7_VfloC64: {
double (*v0)[2] = (double (*)[2])VELTS(ra0);
for (; n-- > 0; i0 += inc0) {
v0[i0][0] = -v0[i0][0];
v0[i0][1] = -v0[i0][1];
}
break;
}
# endif /* FLOATS */
}
}
else {
SCM ra1 = CAR(ras);
sizet i1 = ARRAY_BASE(ra1);
long inc1 = ARRAY_DIMS(ra1)->inc;
ra1 = ARRAY_V(ra1);
switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
ovflow: wta(ra0, (char *)OVFLOW, "-");
default: {
SCM e0 = UNDEFINED, e1 = UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1)
aset(ra0, difference(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0));
break;
}
case tc7_VfixN32: {
unsigned long r;
unsigned long *v0 = (unsigned long *)VELTS(ra0);
unsigned long *v1 = (unsigned long*)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
r = v0[i0] - v1[i1];
ASRTGO(r <= v0[i0], ovflow);
v0[i0] = r;
} );
break;
}
case tc7_VfixZ32: {
long r, *v0 = VELTS(ra0), *v1 = VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
r = v0[i0] - v1[i1];
ASRTGO((v0[i0]>0 ? r>=0 || v1[i1]>0 : r<=0 || v1[i1]<0), ovflow);
v0[i0] = r;
} );
break;
}
# ifdef FLOATS
case tc7_VfloR32: {
float *v0 = (float *)VELTS(ra0);
float *v1 = (float *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
v0[i0] -= v1[i1]);
break;
}
case tc7_VfloR64: {
double *v0 = (double *)VELTS(ra0);
double *v1 = (double *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
v0[i0] -= v1[i1]);
break;
}
case tc7_VfloC32: {
float (*v0)[2] = (float (*)[2])VELTS(ra0);
float (*v1)[2] = (float (*)[2])VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
v0[i0][0] -= v1[i1][0];
v0[i0][1] -= v1[i1][1];
})
break;
}
case tc7_VfloC64: {
double (*v0)[2] = (double (*)[2])VELTS(ra0);
double (*v1)[2] = (double (*)[2])VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
v0[i0][0] -= v1[i1][0];
v0[i0][1] -= v1[i1][1];
})
break;
}
# endif /* FLOATS */
}
}
return 1;
}
int ra_product(ra0, ras)
SCM ra0, ras;
{
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0);
long inc0 = ARRAY_DIMS(ra0)->inc;
ra0 = ARRAY_V(ra0);
if (NNULLP(ras)) {
SCM ra1 = CAR(ras);
sizet i1 = ARRAY_BASE(ra1);
long inc1 = ARRAY_DIMS(ra1)->inc;
ra1 = ARRAY_V(ra1);
switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
ovflow: wta(ra0, (char *)OVFLOW, "*");
default: {
SCM e0 = UNDEFINED, e1 = UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1)
aset(ra0, product(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
MAKINUM(i0));
break;
}
case tc7_VfixN32: {
unsigned long r;
unsigned long *v0 = (unsigned long *)VELTS(ra0);
unsigned long *v1 = (unsigned long *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
r = v0[i0] * v1[i1];
ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow);
v0[i0] = r;
} );
break;
}
case tc7_VfixZ32: {
long r, *v0 = VELTS(ra0), *v1 =VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
r = v0[i0] * v1[i1];
ASRTGO(0==v0[i0] || v1[i1]==r/v0[i0], ovflow);
v0[i0] = r;
} );
break;
}
# ifdef FLOATS
case tc7_VfloR32: {
float *v0 = (float *)VELTS(ra0);
float *v1 = (float *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
v0[i0] *= v1[i1]);
break;
}
case tc7_VfloR64: {
double *v0 = (double *)VELTS(ra0);
double *v1 = (double *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
v0[i0] *= v1[i1]);
break;
}
case tc7_VfloC32: {
float (*v0)[2] = (float (*)[2])VELTS(ra0);
register double r;
float (*v1)[2] = (float (*)[2])VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
r = v0[i0][0]*v1[i1][0] - v0[i0][1]*v1[i1][1];
v0[i0][1] = v0[i0][0]*v1[i1][1] + v0[i0][1]*v1[i1][0];
v0[i0][0] = r;
});
break;
}
case tc7_VfloC64: {
double (*v0)[2] = (double (*)[2])VELTS(ra0);
register double r;
double (*v1)[2] = (double (*)[2])VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
r = v0[i0][0]*v1[i1][0] - v0[i0][1]*v1[i1][1];
v0[i0][1] = v0[i0][0]*v1[i1][1] + v0[i0][1]*v1[i1][0];
v0[i0][0] = r;
});
break;
}
# endif /* FLOATS */
}
}
return 1;
}
int ra_divide(ra0, ras)
SCM ra0, ras;
{
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0);
long inc0 = ARRAY_DIMS(ra0)->inc;
ra0 = ARRAY_V(ra0);
if (NULLP(ras)) {
switch TYP7(ra0) {
default: {
SCM e0 = UNDEFINED;
for (; n-- > 0; i0 += inc0)
aset(ra0, divide(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
break;
}
# ifdef FLOATS
case tc7_VfloR32: {
float *v0 = (float *)VELTS(ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = 1.0/v0[i0];
break;
}
case tc7_VfloR64: {
double *v0 = (double *)VELTS(ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = 1.0/v0[i0];
break;
}
case tc7_VfloC32: {
register double d;
float (*v0)[2] = (float (*)[2])VELTS(ra0);
for (; n-- > 0; i0 += inc0) {
d = v0[i0][0]*v0[i0][0] + v0[i0][1]*v0[i0][1];
v0[i0][0] /= d;
v0[i0][1] /= -d;
}
break;
}
case tc7_VfloC64: {
register double d;
double (*v0)[2] = (double (*)[2])VELTS(ra0);
for (; n-- > 0; i0 += inc0) {
d = v0[i0][0]*v0[i0][0] + v0[i0][1]*v0[i0][1];
v0[i0][0] /= d;
v0[i0][1] /= -d;
}
break;
}
# endif /* FLOATS */
}
}
else {
SCM ra1 = CAR(ras);
sizet i1 = ARRAY_BASE(ra1);
long inc1 = ARRAY_DIMS(ra1)->inc;
ra1 = ARRAY_V(ra1);
switch (TYP7(ra0)==TYP7(ra1) ? TYP7(ra0) : 0) {
default: {
SCM e0 = UNDEFINED, e1 = UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1)
aset(ra0, divide(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)), MAKINUM(i0));
break;
}
# ifdef FLOATS
case tc7_VfloR32: {
float *v0 = (float *)VELTS(ra0);
float *v1 = (float *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
v0[i0] /= v1[i1]);
break;
}
case tc7_VfloR64: {
double *v0 = (double *)VELTS(ra0);
double *v1 = (double *)VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
v0[i0] /= v1[i1]);
break;
}
case tc7_VfloC32: {
register double d, r;
float (*v0)[2] = (float (*)[2])VELTS(ra0);
float (*v1)[2] = (float (*)[2])VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
d = v1[i1][0]*v1[i1][0] + v1[i1][1]*v1[i1][1];
r = (v0[i0][0]*v1[i1][0] + v0[i0][1]*v1[i1][1])/d;
v0[i0][1] = (v0[i0][1]*v1[i1][0] - v0[i0][0]*v1[i1][1])/d;
v0[i0][0] = r;
})
break;
}
case tc7_VfloC64: {
register double d, r;
double (*v0)[2] = (double (*)[2])VELTS(ra0);
double (*v1)[2] = (double (*)[2])VELTS(ra1);
IVDEP(ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1) {
d = v1[i1][0]*v1[i1][0] + v1[i1][1]*v1[i1][1];
r = (v0[i0][0]*v1[i1][0] + v0[i0][1]*v1[i1][1])/d;
v0[i0][1] = (v0[i0][1]*v1[i1][0] - v0[i0][0]*v1[i1][1])/d;
v0[i0][0] = r;
})
break;
}
# endif /* FLOATS */
}
}
return 1;
}
static int ra_identity(dst, src)
SCM src, dst;
{
return racp(CAR(src), cons(dst, EOL));
}
static int ramap(ra0, proc, ras)
SCM ra0, proc, ras;
{
SCM heap_ve, auto_rav[5], auto_argv[5];
SCM *rav = &auto_rav[0], *argv = &auto_argv[0];
long argc = ilength(ras);
long i, k, inc, n, base;
scm_protect_temp(&heap_ve);
if (argc >= 5) {
heap_ve = make_vector(MAKINUM(2*argc), BOOL_F);
rav = VELTS(heap_ve);
argv = &(rav[argc]);
}
for (k = 0; k < argc; k++) {
rav[k] = CAR(ras);
ras = CDR(ras);
}
i = ARRAY_DIMS(ra0)->lbnd;
inc = ARRAY_DIMS(ra0)->inc;
n = ARRAY_DIMS(ra0)->ubnd;
base = ARRAY_BASE(ra0) - i*inc;
ra0 = ARRAY_V(ra0);
for (; i <= n; i++) {
for (k = 0; k < argc; k++)
argv[k] = aref(rav[k], MAKINUM(i));
aset(ra0, scm_cvapply(proc, argc, argv), MAKINUM(i*inc + base));
}
return 1;
}
static int ramap_cxr(ra0, proc, ras)
SCM ra0, proc, ras;
{
SCM ra1 = CAR(ras);
SCM e1 = UNDEFINED;
sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra1)->lbnd + 1;
ra0 = ARRAY_V(ra0);
ra1 = ARRAY_V(ra1);
switch TYP7(ra0) {
default: gencase:
for (; n-- > 0; i0 += inc0, i1 += inc1) {
e1 = cvref(ra1, i1, e1);
aset(ra0, scm_cvapply(proc, 1L, &e1), MAKINUM(i0));
}
break;
# ifdef FLOATS
case tc7_VfloR32: {
float *dst = (float *)VELTS(ra0);
switch TYP7(ra1) {
default: goto gencase;
case tc7_VfloR32:
for (; n-- > 0; i0 += inc0, i1 += inc1)
dst[i0] = DSUBRF(proc)((double)((float *)VELTS(ra1))[i1]);
break;
case tc7_VfixN32:
case tc7_VfixZ32:
for (; n-- > 0; i0 += inc0, i1 += inc1)
dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]);
break;
}
break;
}
case tc7_VfloR64: {
double *dst = (double *)VELTS(ra0);
switch TYP7(ra1) {
default: goto gencase;
case tc7_VfloR64:
for (; n-- > 0; i0 += inc0, i1 += inc1)
dst[i0] = DSUBRF(proc)(((double *)VELTS(ra1))[i1]);
break;
case tc7_VfixN32:
case tc7_VfixZ32:
for (; n-- > 0; i0 += inc0, i1 += inc1)
dst[i0] = DSUBRF(proc)((double)VELTS(ra1)[i1]);
break;
}
break;
}
# endif /* FLOATS */
}
return 1;
}
static int ramap_rp(ra0, proc, ras)
SCM ra0, proc, ras;
{
SCM ra1 = CAR(ras), ra2 = CAR(CDR(ras));
SCM e1 = UNDEFINED, e2 = UNDEFINED;
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1), i2 = ARRAY_BASE(ra2);
long inc0 = ARRAY_DIMS(ra0)->inc;
long inc1 = ARRAY_DIMS(ra1)->inc;
long inc2 = ARRAY_DIMS(ra2)->inc;
ra0 = ARRAY_V(ra0);
ra1 = ARRAY_V(ra1);
ra2 = ARRAY_V(ra2);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0))
if (FALSEP(SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2))))
BVE_CLR(ra0, i0);
return 1;
}
static int ramap_1(ra0, proc, ras)
SCM ra0, proc, ras;
{
SCM ra1 = CAR(ras);
SCM e1 = UNDEFINED;
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
ra0 = ARRAY_V(ra0);
ra1 = ARRAY_V(ra1);
if (tc7_vector==TYP7(ra0))
for (; n-- > 0; i0 += inc0, i1 += inc1)
VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED));
else
for (; n-- > 0; i0 += inc0, i1 += inc1)
aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1)), MAKINUM(i0));
return 1;
}
static int ramap_2o(ra0, proc, ras)
SCM ra0, proc, ras;
{
SCM ra1 = CAR(ras);
SCM e1 = UNDEFINED;
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0), i1 = ARRAY_BASE(ra1);
long inc0 = ARRAY_DIMS(ra0)->inc, inc1 = ARRAY_DIMS(ra1)->inc;
ra0 = ARRAY_V(ra0);
ra1 = ARRAY_V(ra1);
ras = CDR(ras);
if (NULLP(ras)) {
if (tc7_vector==TYP7(ra0))
for (; n-- > 0; i0 += inc0, i1 += inc1)
VELTS(ra0)[i0] = SUBRF(proc)(cvref(ra1, i1, UNDEFINED), UNDEFINED);
else
for (; n-- > 0; i0 += inc0, i1 += inc1)
aset(ra0, SUBRF(proc)(RVREF(ra1, i1, e1), UNDEFINED),
MAKINUM(i0));
}
else {
SCM ra2 = CAR(ras);
SCM e2 = UNDEFINED;
sizet i2 = ARRAY_BASE(ra2);
long inc2 = ARRAY_DIMS(ra2)->inc;
ra2 = ARRAY_V(ra2);
if (tc7_vector==TYP7(ra0))
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
VELTS(ra0)[i0] =
SUBRF(proc)(cvref(ra1, i1, UNDEFINED), cvref(ra2, i2, UNDEFINED));
else
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
aset(ra0,
SUBRF(proc)(RVREF(ra1, i1, e1), RVREF(ra2, i2, e2)),
MAKINUM(i0));
}
return 1;
}
static int ramap_a(ra0, proc, ras)
SCM ra0, proc, ras;
{
SCM e0 = UNDEFINED, e1 = UNDEFINED;
long n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
sizet i0 = ARRAY_BASE(ra0);
long inc0 = ARRAY_DIMS(ra0)->inc;
ra0 = ARRAY_V(ra0);
if (NULLP(ras))
for (; n-- > 0; i0 += inc0)
aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), UNDEFINED), MAKINUM(i0));
else {
SCM ra1 = CAR(ras);
sizet i1 = ARRAY_BASE(ra1);
long inc1 = ARRAY_DIMS(ra1)->inc;
ra1 = ARRAY_V(ra1);
for (; n-- > 0; i0 += inc0, i1 += inc1)
aset(ra0, SUBRF(proc)(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1)),
MAKINUM(i0));
}
return 1;
}
/* These tables are a kluge that will not scale well when more
vectorized subrs are added. It is tempting to steal some bits from
the CAR of all subrs (like those selected by SMOBNUM) to hold an
offset into a table of vectorized subrs. */
static ra_iproc ra_rpsubrs[] = {
{"=", UNDEFINED, ra_eqp},
{"<", UNDEFINED, ra_lessp},
{"<=", UNDEFINED, ra_leqp},
{">", UNDEFINED, ra_grp},
{">=", UNDEFINED, ra_greqp},
{0, 0, 0}};
static ra_iproc ra_asubrs[] = {
{"+", UNDEFINED, ra_sum},
{"-", UNDEFINED, ra_difference},
{"*", UNDEFINED, ra_product},
{"/", UNDEFINED, ra_divide},
{0, 0, 0}};
static char s_sarray_map[] = "serial-array-map!";
# define s_array_map (s_sarray_map + 7)
SCM array_map(ra0, proc, lra)
SCM ra0, proc, lra;
{
long narg = ilength(lra);
tail:
#ifndef RECKLESS
scm_arity_check(proc, narg, s_array_map);
#endif
switch TYP7(proc) {
default: gencase:
ramapc(ramap, proc, ra0, lra, s_array_map);
return UNSPECIFIED;
case tc7_subr_1:
ramapc(ramap_1, proc, ra0, lra, s_array_map);
return UNSPECIFIED;
case tc7_subr_2:
case tc7_subr_2o:
ramapc(ramap_2o, proc, ra0, lra, s_array_map);
return UNSPECIFIED;
case tc7_cxr: if (! SUBRF(proc)) goto gencase;
ramapc(ramap_cxr, proc, ra0, lra, s_array_map);
return UNSPECIFIED;
case tc7_rpsubr: {
ra_iproc *p;
if (FALSEP(arrayp(ra0, BOOL_T))) goto gencase;
array_fill(ra0, BOOL_T);
for (p = ra_rpsubrs; p->name; p++)
if (proc==p->sproc) {
while (NNULLP(lra) && NNULLP(CDR(lra))) {
ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map);
lra = CDR(lra);
}
return UNSPECIFIED;
}
while (NNULLP(lra) && NNULLP(CDR(lra))) {
ramapc(ramap_rp, proc, ra0, lra, s_array_map);
lra = CDR(lra);
}
return UNSPECIFIED;
}
case tc7_asubr:
if (NULLP(lra)) {
SCM prot, fill = SUBRF(proc)(UNDEFINED, UNDEFINED);
if (INUMP(fill)) {
prot = array_prot(ra0);
# ifdef FLOATS
if (NIMP(prot) && INEXP(prot))
fill = makdbl((double)INUM(fill), 0.0);
# endif
}
array_fill(ra0, fill);
}
else {
SCM tail, ra1 = CAR(lra);
SCM v0 = (NIMP(ra0) && ARRAYP(ra0) ? ARRAY_V(ra0) : ra0);
ra_iproc *p;
/* Check to see if order might matter.
This might be an argument for a separate
SERIAL-ARRAY-MAP! */
if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1)))
if (ra0 != ra1 || (ARRAYP(ra0) && !ARRAY_CONTP(ra0)))
goto gencase;
for (tail = CDR(lra); NNULLP(tail); tail = CDR(tail)) {
ra1 = CAR(tail);
if (v0==ra1 || (NIMP(ra1) && ARRAYP(ra1) && v0==ARRAY_V(ra1)))
goto gencase;
}
for (p = ra_asubrs; p->name; p++)
if (proc==p->sproc) {
if (ra0 != CAR(lra))
ramapc(ra_identity, UNDEFINED, ra0, cons(CAR(lra), EOL), s_array_map);
lra = CDR(lra);
while (1) {
ramapc(p->vproc, UNDEFINED, ra0, lra, s_array_map);
if (IMP(lra) || IMP(CDR(lra))) return UNSPECIFIED;
lra = CDR(lra);
}
}
ramapc(ramap_2o, proc, ra0, lra, s_array_map);
lra = CDR(lra);
if (NIMP(lra))
for (lra = CDR(lra); NIMP(lra); lra = CDR(lra))
ramapc(ramap_a, proc, ra0, lra, s_array_map);
}
return UNSPECIFIED;
#if 1 /* def CCLO */
case tc7_specfun:
if (tc16_cclo==TYP16(proc)) {
lra = cons(sc2array(proc, ra0, EOL), lra);
proc = CCLO_SUBR(proc);
narg++;
goto tail;
}
goto gencase;
#endif
}
}
static int rafe(ra0, proc, ras)
SCM ra0, proc, ras;
{
SCM heap_ve, auto_rav[5], auto_argv[5];
SCM *rav = &auto_rav[0], *argv = &auto_argv[0];
long argc = ilength(ras) + 1;
long i, k, n;
scm_protect_temp(&heap_ve);
if (argc >= 5) {
heap_ve = make_vector(MAKINUM(2*argc), BOOL_F);
rav = VELTS(heap_ve);
argv = &(rav[argc]);
}
rav[0] = ra0;
for (k = 1; k < argc; k++) {
rav[k] = CAR(ras);
ras = CDR(ras);
}
i = ARRAY_DIMS(ra0)->lbnd;
n = ARRAY_DIMS(ra0)->ubnd;
for (; i <= n; i++) {
for (k = 0; k < argc; k++)
argv[k] = aref(rav[k], MAKINUM(i));
scm_cvapply(proc, argc, argv);
}
return 1;
}
static char s_array_for_each[] = "array-for-each";
SCM array_for_each(proc, ra0, lra)
SCM proc, ra0, lra;
{
long narg = ilength(lra) + 1;
tail:
#ifndef RECKLESS
scm_arity_check(proc, narg, s_array_for_each);
#endif
switch TYP7(proc) {
default: gencase:
ramapc(rafe, proc, ra0, lra, s_array_for_each);
return UNSPECIFIED;
#if 1 /* def CCLO */
case tc7_specfun:
if (tc16_cclo==TYP16(proc)) {
lra = cons(ra0, lra);
ra0 = sc2array(proc, ra0, EOL);
proc = CCLO_SUBR(proc);
narg++;
goto tail;
}
goto gencase;
#endif
}
}
static char s_array_index_for_each[] = "array-index-for-each";
SCM scm_array_index_for_each(ra, proc)
SCM ra, proc;
{
SCM hp_av, hp_indv, auto_av[5];
SCM *av = &auto_av[0];
long auto_indv[5];
long *indv = &auto_indv[0];
sizet i;
ASRTER(NIMP(ra), ra, ARG1, s_array_index_for_each);
i = INUM(array_rank(ra));
#ifndef RECKLESS
scm_arity_check(proc, i+0L, s_array_index_for_each);
#endif
if (i >= 5) {
scm_protect_temp(&hp_av);
scm_protect_temp(&hp_indv);
hp_av = make_vector(MAKINUM(i), BOOL_F);
av = VELTS(hp_av);
hp_indv = make_uve(i+0L, MAKINUM(-32L));
indv = (long *)VELTS(hp_indv);
}
switch TYP7(ra) {
default: badarg: wta(ra, (char *)ARG1, s_array_index_for_each);
case tc7_vector: {
for (i = 0; i < LENGTH(ra); i++) {
av[0] = MAKINUM(i);
scm_cvapply(proc, 1L, av);
}
return UNSPECIFIED;
}
case tcs_uves:
for (i = 0; i < LENGTH(ra); i++) {
av[0] = MAKINUM(i);
scm_cvapply(proc, 1L, auto_av);
}
return UNSPECIFIED;
case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
{
int j, k, kmax = ARRAY_NDIM(ra) - 1;
if (kmax < 0)
return apply(proc, EOL, EOL);
for (k = 0; k <= kmax; k++)
indv[k] = ARRAY_DIMS(ra)[k].lbnd;
k = kmax;
do {
if (k==kmax) {
indv[k] = ARRAY_DIMS(ra)[k].lbnd;
i = cind(ra, indv);
for (; indv[k] <= ARRAY_DIMS(ra)[k].ubnd; indv[k]++) {
for (j = kmax+1; j--;)
av[j] = MAKINUM(indv[j]);
scm_cvapply(proc, kmax+1L, av);
i += ARRAY_DIMS(ra)[k].inc;
}
k--;
continue;
}
if (indv[k] < ARRAY_DIMS(ra)[k].ubnd) {
indv[k]++;
k++;
continue;
}
indv[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
k--;
} while (k >= 0);
return UNSPECIFIED;
}
}
}
static char s_array_imap[] = "array-index-map!";
SCM array_imap(ra, proc)
SCM ra, proc;
{
SCM hp_av, hp_indv, auto_av[5];
SCM *av = &auto_av[0];
long auto_indv[5];
long *indv = &auto_indv[0];
sizet i;
ASRTER(NIMP(ra), ra, ARG1, s_array_imap);
i = INUM(array_rank(ra));
#ifndef RECKLESS
scm_arity_check(proc, i+0L, s_array_imap);
#endif
if (i >= 5) {
scm_protect_temp(&hp_av);
scm_protect_temp(&hp_indv);
hp_av = make_vector(MAKINUM(i), BOOL_F);
av = VELTS(hp_av);
hp_indv = make_uve(i+0L, MAKINUM(-32L));
indv = (long *)VELTS(hp_indv);
}
switch TYP7(ra) {
default: badarg: wta(ra, (char *)ARG1, s_array_imap);
case tc7_vector: {
SCM *ve = VELTS(ra);
for (i = 0; i < LENGTH(ra); i++) {
av[0] = MAKINUM(i);
ve[i] = scm_cvapply(proc, 1L, av);
}
return UNSPECIFIED;
}
case tcs_uves:
for (i = 0; i < LENGTH(ra); i++) {
av[0] = MAKINUM(i);
aset(ra, scm_cvapply(proc, 1L, auto_av), MAKINUM(i));
}
return UNSPECIFIED;
case tc7_smob: ASRTGO(ARRAYP(ra), badarg);
{
int j, k, kmax = ARRAY_NDIM(ra) - 1;
if (kmax < 0)
return aset(ra, apply(proc, EOL, EOL), EOL);
for (k = 0; k <= kmax; k++)
indv[k] = ARRAY_DIMS(ra)[k].lbnd;
k = kmax;
do {
if (k==kmax) {
indv[k] = ARRAY_DIMS(ra)[k].lbnd;
i = cind(ra, indv);
for (; indv[k] <= ARRAY_DIMS(ra)[k].ubnd; indv[k]++) {
for (j = kmax+1; j--;)
av[j] = MAKINUM(indv[j]);
aset(ARRAY_V(ra), scm_cvapply(proc, kmax+1L, av), MAKINUM(i));
i += ARRAY_DIMS(ra)[k].inc;
}
k--;
continue;
}
if (indv[k] < ARRAY_DIMS(ra)[k].ubnd) {
indv[k]++;
k++;
continue;
}
indv[k] = ARRAY_DIMS(ra)[k].lbnd - 1;
k--;
} while (k >= 0);
return UNSPECIFIED;
}
}
}
SCM array_equal P((SCM ra0, SCM ra1));
static int raeql_1(ra0, as_equal, ra1)
SCM ra0, as_equal, ra1;
{
SCM e0 = UNDEFINED, e1 = UNDEFINED;
sizet i0 = 0, i1 = 0;
long inc0 = 1, inc1 = 1;
sizet n = LENGTH(ra0);
ra1 = CAR(ra1);
if (ARRAYP(ra0)) {
n = ARRAY_DIMS(ra0)->ubnd - ARRAY_DIMS(ra0)->lbnd + 1;
i0 = ARRAY_BASE(ra0);
inc0 = ARRAY_DIMS(ra0)->inc;
ra0 = ARRAY_V(ra0);
}
if (ARRAYP(ra1)) {
i1 = ARRAY_BASE(ra1);
inc1 = ARRAY_DIMS(ra1)->inc;
ra1 = ARRAY_V(ra1);
}
switch TYP7(ra0) {
case tc7_vector: default:
for (; n--; i0+=inc0, i1+=inc1) {
if (FALSEP(as_equal)) {
if (FALSEP(array_equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1))))
return 0;
}
else
if (FALSEP(equal(RVREF(ra0, i0, e0), RVREF(ra1, i1, e1))))
return 0;
}
return 1;
case tc7_string: {
char *v0 = CHARS(ra0) + i0;
char *v1 = CHARS(ra1) + i1;
for (; n--; v0 += inc0, v1 += inc1)
if (*v0 != *v1) return 0;
return 1;
}
case tc7_Vbool:
for (; n--; i0 += inc0, i1 += inc1)
if (BVE_REF(ra0, i0) != BVE_REF(ra1, i1)) return 0;
return 1;
case tc7_VfixN32: case tc7_VfixZ32: {
long *v0 = (long *)VELTS(ra0) + i0;
long *v1 = (long *)VELTS(ra1) + i1;
for (; n--; v0 += inc0, v1 += inc1)
if (*v0 != *v1) return 0;
return 1;
}
# ifdef FLOATS
case tc7_VfloR32: {
float *v0 = (float *)VELTS(ra0) + i0;
float *v1 = (float *)VELTS(ra1) + i1;
for (; n--; v0 += inc0, v1 += inc1)
if (*v0 != *v1) return 0;
return 1;
}
case tc7_VfloR64: {
double *v0 = (double *)VELTS(ra0) + i0;
double *v1 = (double *)VELTS(ra1) + i1;
for (; n--; v0 += inc0, v1 += inc1)
if (*v0 != *v1) return 0;
return 1;
}
case tc7_VfloC32: {
float (*v0)[2]= (float (*)[2])VELTS(ra0) + i0;
float (*v1)[2] = (float (*)[2])VELTS(ra1) + i1;
for (; n--; v0 += inc0, v1 += inc1) {
if ((*v0)[0] != (*v1)[0]) return 0;
if ((*v0)[1] != (*v1)[1]) return 0;
}
return 1;
}
case tc7_VfloC64: {
double (*v0)[2]= (double (*)[2])VELTS(ra0) + i0;
double (*v1)[2] = (double (*)[2])VELTS(ra1) + i1;
for (; n--; v0 += inc0, v1 += inc1) {
if ((*v0)[0] != (*v1)[0]) return 0;
if ((*v0)[1] != (*v1)[1]) return 0;
}
return 1;
}
# endif /* FLOATS */
}
}
static int raeql(ra0, as_equal, ra1)
SCM ra0, as_equal, ra1;
{
SCM v0 = ra0, v1 = ra1;
array_dim dim0, dim1;
array_dim *s0 = &dim0, *s1 = &dim1;
sizet bas0 = 0, bas1 = 0;
int k, unroll = 1, ndim = 1;
if (ARRAYP(ra0)) {
ndim = ARRAY_NDIM(ra0);
s0 = ARRAY_DIMS(ra0);
bas0 = ARRAY_BASE(ra0);
v0 = ARRAY_V(ra0);
}
else {
s0->inc = 1; s0->lbnd = 0; s0->ubnd = LENGTH(v0) - 1;
}
if (ARRAYP(ra1)) {
if (ndim != ARRAY_NDIM(ra1)) return 0;
s1 = ARRAY_DIMS(ra1);
bas1 = ARRAY_BASE(ra1);
v1 = ARRAY_V(ra1);
}
else {
if (1 != ndim) return BOOL_F;
s1->inc = 1; s1->lbnd = 0; s1->ubnd = LENGTH(v1) - 1;
}
if (TYP7(v0) != TYP7(v1)) return 0;
unroll = (bas0==bas1);
for (k = ndim; k--;) {
if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd) return 0;
if (unroll) unroll = (s0[k].inc==s1[k].inc);
}
if (unroll && v0==v1) return BOOL_T;
return ramapc(raeql_1, as_equal, ra0, cons(ra1, EOL), "");
}
SCM raequal(ra0, ra1)
SCM ra0, ra1;
{
return (raeql(ra0, BOOL_T, ra1) ? BOOL_T : BOOL_F);
}
static char s_array_equalp[] = "array-equal?";
SCM array_equal(ra0, ra1)
SCM ra0, ra1;
{
if (IMP(ra0) || IMP(ra1))
callequal: return equal(ra0, ra1);
switch TYP7(ra0) {
default: goto callequal;
case tc7_vector:
case tcs_uves: break;
case tc7_smob: if (!ARRAYP(ra0)) goto callequal;
}
switch TYP7(ra1) {
default: goto callequal;
case tc7_vector:
case tcs_uves: break;
case tc7_smob: if (!ARRAYP(ra1)) goto callequal;
}
return (raeql(ra0, BOOL_F, ra1) ? BOOL_T : BOOL_F);
}
static iproc subr2os[] = {
{s_ura_rd, ura_read},
{s_ura_wr, ura_write},
{0, 0}};
/* MinGW complains during a dll build that the string members are not
constants, since they are defined in another dll. These functions
individually initialized below.
static iproc subr2s[] = {
{s_array_fill, array_fill},
{s_array_copy, array_copy},
{s_sarray_copy, array_copy},
{0, 0}};
*/
static iproc lsubr2s[] = {
{s_sc2array, sc2array},
{s_array_map, array_map},
{s_sarray_map, array_map},
{s_array_for_each, array_for_each},
{s_array_imap, array_imap},
{s_array_index_for_each, scm_array_index_for_each},
{0, 0}};
static void init_raprocs(subra)
ra_iproc *subra;
{
for (; subra->name; subra++)
subra->sproc = CDR(sysintern(subra->name, UNDEFINED));
}
SCM_DLL_EXPORT void init_ramap P((void));
void init_ramap()
{
init_raprocs(ra_rpsubrs);
init_raprocs(ra_asubrs);
init_iprocs(subr2os, tc7_subr_2o);
/* init_iprocs(subr2s, tc7_subr_2); */
init_iprocs(lsubr2s, tc7_lsubr_2);
make_subr(s_array_fill, tc7_subr_2, array_fill);
make_subr(s_array_copy, tc7_subr_2, array_copy);
make_subr(s_sarray_copy, tc7_subr_2, array_copy);
make_subr(s_array_equalp, tc7_rpsubr, array_equal);
smobs[0x0ff & (tc16_array>>8)].equalp = raequal;
add_feature(s_array_for_each);
scm_ldstr("\n\
(define (array-indexes ra)\n\
(let ((ra0 (apply make-array '#() (array-shape ra))))\n\
(array-index-map! ra0 list)\n\
ra0))\n\
(define (array-map prototype proc ra1 . ras)\n\
(define nra (apply make-array prototype (array-shape ra1)))\n\
(apply array-map! nra proc ra1 ras)\n\
nra)\n\
");
}
scm-5e5/rgx.c 0000644 0017052 0001750 00000042574 10750240521 011006 0 ustar tb tb /* "rgx.c" regular expression matching using C regex library.
* Copyright (C) 1995, 1996, 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 */
#include "scm.h"
#ifdef __FreeBSD__
# include "gnuregex.h"
#else
# include "regex.h"
#endif
#include
/* added by Denys Duchier: for bcopy */
#ifdef sun
#include
#endif
static char rcsid[] =
"$Id: rgx.c,v 1.19 2008/01/31 03:32:33 jaffer Exp $";
#ifdef HAVE_ALLOCA
# include
# define ALLOCA_PROTECT typedef int foobazzz
# define ALLOCA alloca
#else
# define ALLOCA_PROTECT SCM alloca_protect=EOL
# define ALLOCA(size) \
(alloca_protect=cons(makstr((long)(size)), alloca_protect), \
(void *)CDR(CAR(alloca_protect)))
#endif
#ifdef _GNU_SOURCE
/* following two lines stolen from GNU regex.c */
# define CHAR_SET_SIZE 256
# define ISUPPER(c) (isascii (c) && isupper (c))
#endif
/* forward function defs */
SCM lregsearch();
SCM lregsearchv();
/* Posix regexp bindings. */
static char s_regex[] = "regex";
static char s_regcomp[] = "regcomp", s_regerror[] = "regerror";
static char s_regexec[] = "regexec", s_regmatp[] = "regmatch?";
static char s_regsearch[] = "regsearch", s_regmatch[] = "regmatch";
static char s_regsearchv[] = "regsearchv", s_regmatchv[] = "regmatchv";
static char s_stringsplit[] = "string-split";
static char s_stringsplitv[] = "string-splitv";
static char s_stringedit[] = "string-edit";
#define s_error &s_regerror[3]
#define RGX_INFO(obj) ((regex_info*)CDR(obj))
#define RGX_PATTERN(obj) (((regex_info*)CDR(obj))->pattern)
#define RGX(obj) (&((regex_info*)CDR(obj))->rgx)
#ifndef _GNU_SOURCE
# define RGX2(obj) (&((regex_info*)CDR(obj))->rgx_anchored)
#endif
#define FIXUP_REGEXP(prog) \
{ \
if (STRINGP(prog)) \
prog = lregcomp(prog, UNDEFINED); \
if (NIMP(prog) && CONSP(prog) && STRINGP(CAR(prog)) && \
NIMP(CDR(prog)) && CONSP(CDR(prog)) && STRINGP(CAR(CDR(prog)))) \
prog = lregcomp(CAR(prog), CAR(CDR(prog))); \
}
typedef struct regex_info {
SCM pattern; /* string we compiled to create our reg exp */
regex_t rgx;
#ifndef _GNU_SOURCE
int options; /* for anchored pattern when matching */
regex_t rgx_anchored;
#endif
} regex_info;
sizet fregex(ptr)
CELLPTR ptr;
{
regfree(RGX((SCM)ptr));
#ifndef _GNU_SOURCE
/* options are null => we compiled the anchored pattern */
if (RGX_INFO((SCM)ptr)->options==0)
regfree(RGX2((SCM)ptr));
#endif
must_free(CHARS((SCM)ptr), (sizet)LENGTH((SCM)ptr));
return 0;
}
int prinregex(exp, port, writing)
SCM exp; SCM port; int writing;
{
lputs("#', port);
return 1;
}
SCM markregex(ptr)
SCM ptr;
{
SETGC8MARK(RGX_PATTERN(ptr));
return BOOL_F;
}
int tc16_rgx;
static smobfuns rgxsmob = {markregex, fregex, prinregex};
SCM lregerror(scode)
SCM scode;
{
int code;
/* added by Denys Duchier: conditional declaration */
#ifdef __REGEXP_LIBRARY_H__
int len;
#endif
SCM str;
ASRTER(INUMP(scode), scode, ARG1, s_regerror);
code = INUM(scode);
if (code < 0)
return makfromstr("Invalid code", sizeof("Invalid code")-1);
/* XXX - is regerror posix or not? */
#ifdef __REGEXP_LIBRARY_H__
/* XXX - gnu regexp doesn't use the re parameter, so we will
ignore it in a very untidy way. */
len = regerror(code, 0L, 0L, 0);
str = makstr(len-1);
regerror(code, 0L, CHARS(str), len);
#else
str = makfromstr(s_error, (sizet)5);
#endif
return str;
}
SCM lregcomp(pattern, flags)
SCM pattern, flags;
{
SCM z;
int i, options;
regex_t *prog;
regex_info *info;
char *flagchars;
#ifdef _GNU_SOURCE
int fastmap = 0;
int ignore_case = 0;
char *err_msg;
#endif
ASRTER(NIMP(pattern) && STRINGP(pattern), pattern, ARG1, s_regcomp);
ASRTER(UNBNDP(flags) || (NIMP(flags) && STRINGP(flags)),
flags, ARG2, s_regcomp);
DEFER_INTS;
z = must_malloc_cell((long)sizeof(regex_info), (SCM)tc16_rgx, s_regex);
scm_protect_temp(&z);
info=(regex_info*)CHARS(z);
prog = &(info->rgx);
#ifdef __REGEXP_LIBRARY_H__
for (i=sizeof(regex_t);i--;((char *)prog)[i] = 0);
# ifndef _GNU_SOURCE
{
regex_t *prog2;
prog2 = &(info->rgx_anchored);
for (i=sizeof(regex_t);i--;((char *)prog2)[i] = 0);
}
# endif
#endif
ALLOW_INTS;
info->pattern = pattern;
#ifdef _GNU_SOURCE
options = RE_SYNTAX_POSIX_EXTENDED;
#else
options = REG_EXTENDED;
#endif
if (!UNBNDP(flags)) {
flagchars = CHARS(flags);
for (i=0; ifastmap = must_malloc(CHAR_SET_SIZE, s_regex);
else
prog->fastmap = 0;
if (ignore_case) {
prog->translate = must_malloc(CHAR_SET_SIZE, s_regex);
for (i = 0; i < CHAR_SET_SIZE; i++)
prog->translate[i] = ISUPPER (i) ? tolower (i) : i;
}
else
prog->translate = 0;
prog->buffer = 0;
prog->allocated = 0;
re_set_syntax(options);
err_msg = (char *)re_compile_pattern(CHARS(pattern), LENGTH(pattern), prog);
ALLOW_INTS;
prog->regs_allocated = REGS_FIXED;
/* if error, compile using regcomp to get the error number */
if (err_msg) {
int i;
char *tmppat;
SCM protect;
/* Fixup in case pattern has null characters */
tmppat = CHARS(protect=makstr(LENGTH(pattern)));
bcopy(CHARS(pattern), tmppat, LENGTH(pattern));
for (i=0; ioptions = options;
i = regcomp(prog, CHARS(pattern), options);
if (i) z = MAKINUM(i);
#endif
return z;
}
SCM lregexec(prog, str)
SCM prog, str;
{
ALLOCA_PROTECT;
FIXUP_REGEXP(prog);
ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regexec);
ASRTER(NIMP(str) && STRINGP(str), str, ARG2, s_regexec);
#ifdef _GNU_SOURCE
return lregsearchv(prog, str, EOL);
#else /* not _GNU_SOURCE */
{
size_t nsub;
SCM ans;
regmatch_t *pm;
int flags = 0; /* XXX - optional arg? */
nsub = RGX(prog)->re_nsub + 1; /* XXX - is this posix? */
pm = ALLOCA(nsub * sizeof(regmatch_t));
if (regexec(RGX(prog), CHARS(str), nsub, pm, flags) != 0)
ans = BOOL_F;
else {
ans = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L));
while (nsub--) {
VELTS(ans)[2*nsub+0] = MAKINUM(pm[nsub].rm_so);
VELTS(ans)[2*nsub+1] = MAKINUM(pm[nsub].rm_eo);
}
}
return ans;
}
#endif /* _GNU_SOURCE */
}
SCM lregmatp(prog, str)
SCM prog, str;
{
FIXUP_REGEXP(prog);
ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regmatp);
ASRTER(NIMP(str) && STRINGP(str), str, ARG2, s_regmatp);
#ifdef _GNU_SOURCE
return (lregsearch(prog, str, EOL)==BOOL_F)?BOOL_F:BOOL_T;
#else /* not _GNU_SOURCE */
{
int flags = 0; /* XXX - optional arg? */
flags = regexec(RGX(prog), CHARS(str), 0, 0, flags);
if (!flags) return BOOL_T;
if (REG_NOMATCH!=flags) wta(MAKINUM(flags), s_error, s_regmatp);
return BOOL_F;
}
#endif
}
#define SCALAR 0
#define VECTOR 1
#define MATCH 0
#define SEARCH 1
SCM lregsearchmatch(prog, str, args, search, vector)
SCM prog, str, args;
int vector, search;
{
int len = ilength(args);
int start, size, nsub;
SCM matches;
ALLOCA_PROTECT;
FIXUP_REGEXP(prog);
ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_regsearch);
ASRTER(NIMP(str) && STRINGP(str), str, ARG2, s_regsearch);
ASRTER(len<=2, args, WNA, s_regsearch);
ASRTER((len<1)||(INUMP(CAR(args))), CAR(args), ARG3, s_regsearch);
ASRTER((len<2)||(INUMP(CAR(CDR(args)))), CAR(CDR(args)), ARG4, s_regsearch);
start = (len>=1)?(INUM(CAR(args))):0;
size = (len>=2)?(INUM(CAR(CDR(args)))):LENGTH(str);
#ifdef _GNU_SOURCE
{
int ret, dir=1;
struct re_registers regs, *pregs=0;
if (search && start<0)
start *= -1, dir = -1;
if (vector) {
pregs = ®s;
nsub = RGX(prog)->re_nsub + 1;
regs.num_regs = nsub;
regs.start = ALLOCA(nsub * sizeof(regoff_t));
regs.end = ALLOCA(nsub * sizeof(regoff_t));
}
if (search)
ret = re_search(RGX(prog), CHARS(str), size, start, dir*size, pregs);
else
ret = re_match(RGX(prog), CHARS(str), size, start, pregs);
if (ret < 0)
return BOOL_F;
if (!vector)
return MAKINUM(ret);
matches = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L));
while (nsub--) {
VELTS(matches)[2*nsub+0] = MAKINUM(regs.start[nsub]);
VELTS(matches)[2*nsub+1] = MAKINUM(regs.end[nsub]);
}
return matches;
}
#else /* not _GNU_SOURCE */
{
regex_t *regexp;
regmatch_t *pm;
char *search_string;
if (size > LENGTH(str))
size = LENGTH(str);
if (start<0 || start >= size)
return BOOL_F;
if (size < LENGTH(str)) {
search_string = ALLOCA(size-start+1);
bcopy(CHARS(str)+start, search_string, size-start);
search_string[size-start] = 0;
} else
search_string = CHARS(str)+start;
nsub = RGX(prog)->re_nsub + 1;
pm = ALLOCA(nsub * sizeof(regmatch_t));
if (search)
regexp = RGX(prog);
else {
/* doing a match */
if (RGX_INFO(prog)->options) {
/* strlen & strcpy OK, posix patterns are null terminated */
char *pattern;
pattern = ALLOCA(strlen(CHARS(RGX_PATTERN(prog)))+2);
pattern[0] = '^';
strcpy(pattern+1, CHARS(RGX_PATTERN(prog)));
regcomp(RGX2(prog), pattern, RGX_INFO(prog)->options);
RGX_INFO(prog)->options = 0;
}
regexp = RGX2(prog);
}
if (regexec(regexp, search_string, nsub, pm, 0) != 0)
return BOOL_F;
if (vector) {
matches = make_vector(MAKINUM(2L * nsub), MAKINUM(-1L));
while (nsub--) {
VELTS(matches)[2*nsub+0] = MAKINUM(pm[nsub].rm_so + start);
VELTS(matches)[2*nsub+1] = MAKINUM(pm[nsub].rm_eo + start);
}
return matches;
}
if (search)
return MAKINUM(pm[0].rm_so + start);
else
return MAKINUM(pm[0].rm_eo - pm[0].rm_so);
}
#endif /* _GNU_SOURCE */
}
SCM lregsearch(prog, str, args)
SCM prog, str, args;
{
return lregsearchmatch(prog, str, args, SEARCH, SCALAR);
}
SCM lregsearchv(prog, str, args)
SCM prog, str, args;
{
return lregsearchmatch(prog, str, args, SEARCH, VECTOR);
}
SCM lregmatch(prog, str, args)
SCM prog, str, args;
{
return lregsearchmatch(prog, str, args, MATCH, SCALAR);
}
SCM lregmatchv(prog, str, args)
SCM prog, str, args;
{
return lregsearchmatch(prog, str, args, MATCH, VECTOR);
}
SCM stringsplitutil(prog, str, vector)
SCM prog, str;
int vector;
{
int anchor, match_start, match_end, num_substrings, num_elements;
int search_base;
SCM next_break, substrings, ret;
SCM st_start, st_end;
FIXUP_REGEXP(prog);
ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringsplit);
ASRTER(NIMP(str) && STRINGP(str), str, ARG2, s_stringsplit);
substrings = EOL;
anchor = 0;
search_base = 0;
num_substrings = 0;
next_break = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL));
while (next_break != BOOL_F) {
match_start = INUM(VELTS(next_break)[0]);
match_end = INUM(VELTS(next_break)[1]);
if (match_start < match_end) {
substrings=cons2(MAKINUM(anchor), MAKINUM(match_start), substrings);
anchor = match_end;
num_substrings++;
}
search_base = ((match_end>search_base)?match_end:(search_base+1));
next_break = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL));
}
/* get that tail bit */
if (anchor < LENGTH(str)) {
substrings = cons2(MAKINUM(anchor), MAKINUM(LENGTH(str)), substrings);
num_substrings++;
}
num_elements = vector?(2*num_substrings):num_substrings;
ret = make_vector(MAKINUM(num_elements), EOL);
while (num_substrings--) {
st_start = CAR(substrings);
st_end = CAR(CDR(substrings));
if (vector) {
VELTS(ret)[num_substrings*2+0] = st_start;
VELTS(ret)[num_substrings*2+1] = st_end;
} else
VELTS(ret)[num_substrings] = substring(str, st_start, st_end);
substrings = CDR(CDR(substrings));
}
return ret;
}
SCM lstringsplit(prog, str)
SCM prog, str;
{
return stringsplitutil(prog, str, SCALAR);
}
SCM lstringsplitv(prog, str)
SCM prog, str;
{
return stringsplitutil(prog, str, VECTOR);
}
typedef struct _item {
struct _item *next;
char *string;
int start;
int end;
} *editItem;
#define PUSH(list, string_parm, start_parm, end_parm) \
{ \
editItem item; \
\
item = ALLOCA(sizeof(*item)); \
item->next = list; \
list = item; \
item->string = string_parm; \
item->start = start_parm; \
item->end = end_parm; \
}
/* (string-edit []) */
SCM lstringedit(prog, editspec, args)
SCM prog, editspec, args;
{
int match_start, match_end, search_base, editcount;
int total_len;
int i, args_len, anchor, maxsubnum;
int backslash;
char *ptr;
editItem editlist, substrings, edit;
SCM str, count, next_edit;
SCM result;
ALLOCA_PROTECT;
args_len = ilength(args);
FIXUP_REGEXP(prog);
ASRTER(NIMP(prog) && tc16_rgx==CAR(prog), prog, ARG1, s_stringedit);
ASRTER(NIMP(editspec) && STRINGP(editspec), editspec, ARG2, s_stringedit);
ASRTER((args_len==1)||(args_len==2), args, WNA, s_stringedit);
str = CAR(args);
ASRTER(NIMP(str)&&STRINGP(str), str, ARG3, s_stringedit);
if (args_len==2) {
count = CAR(CDR(args));
ASRTER(INUMP(count)||(count==BOOL_T), count, ARG4, s_stringedit);
} else
count = MAKINUM(1);
/* process the editspec - break it into a list of dotted pairs
* of integers for substrings to be inserted and
* integers representing matched subexpressions that
* should be inserted.
*/
maxsubnum = RGX(prog)->re_nsub;
anchor = 0;
backslash = 0;
editlist = 0;
ptr = CHARS(editspec);
for (i=0; i='0') && (ptr[i] <='9') &&
((ptr[i]-'0')<=maxsubnum))
{
if ((i-1)>anchor)
PUSH(editlist, CHARS(editspec), anchor, i-1);
PUSH(editlist, CHARS(editspec), ptr[i]-'0', -1);
anchor = i+1;
}
backslash = (ptr[i] == '\\')?1:0;
}
if (anchor < LENGTH(editspec))
PUSH(editlist, CHARS(editspec), anchor, LENGTH(editspec));
/* now, reverse the list of edit items */
{
editItem prev, cur, next;
for (prev=0, cur=editlist; cur; prev=cur, cur=next) {
next = cur->next;
cur->next = prev;
}
editlist = prev;
}
anchor = 0;
search_base = 0;
editcount = 0;
substrings = 0;
next_edit = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL));
while (next_edit != BOOL_F) {
if (INUMP(count) && (editcount==INUM(count)))
break;
match_start = INUM(VELTS(next_edit)[0]);
match_end = INUM(VELTS(next_edit)[1]);
if (match_start < match_end) {
PUSH(substrings, CHARS(str), anchor, match_start);
anchor = match_end;
}
for (edit=editlist; edit; edit=edit->next) {
if (edit->end == -1) {
/* A backslash number in the original editspec */
PUSH(substrings, CHARS(str),
INUM(VELTS(next_edit)[edit->start*2+0]),
INUM(VELTS(next_edit)[edit->start*2+1]));
} else
/* normal string in the editspec */
PUSH(substrings, edit->string, edit->start, edit->end);
}
editcount++;
search_base = ((match_end>search_base)?match_end:(search_base+1));
next_edit = lregsearchv(prog, str, cons(MAKINUM(search_base), EOL));
}
/* get that tail bit */
if (anchor < LENGTH(str))
PUSH(substrings, CHARS(str), anchor, LENGTH(str));
/* assemble the result string */
for (edit=substrings, total_len=0; edit; edit=edit->next)
total_len += (edit->end - edit->start);
result = makstr(total_len);
ptr = CHARS(result) + total_len; /* point at the null at the end */
for (edit=substrings; edit; edit=edit->next) {
ptr -= (edit->end - edit->start);
bcopy(edit->string + edit->start, ptr, edit->end - edit->start);
}
return result;
}
#undef PUSH
void init_rgx()
{
tc16_rgx = newsmob(&rgxsmob);
make_subr(s_regcomp, tc7_subr_2o, lregcomp);
make_subr(s_regexec, tc7_subr_2, lregexec);
make_subr(s_regmatp, tc7_subr_2, lregmatp);
make_subr(s_regerror, tc7_subr_1, lregerror);
make_subr(s_regsearch, tc7_lsubr_2, lregsearch);
make_subr(s_regsearchv, tc7_lsubr_2, lregsearchv);
make_subr(s_regmatch, tc7_lsubr_2, lregmatch);
make_subr(s_regmatchv, tc7_lsubr_2, lregmatchv);
make_subr(s_stringsplit, tc7_subr_2, lstringsplit);
make_subr(s_stringsplitv, tc7_subr_2, lstringsplitv);
make_subr(s_stringedit, tc7_lsubr_2, lstringedit);
add_feature(s_regex);
}
scm-5e5/sys.c 0000644 0017052 0001750 00000234317 10750224475 011034 0 ustar tb tb /* "sys.c" opening and closing files, storage, and GC.
* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002, 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
* .
*/
#include
#include "scm.h"
#include "setjump.h"
#ifdef POCKETCONSOLE
# include
#endif
void igc P((const char *what, SCM basecont));
SCM *loc_open_file; /* for open-file callback */
SCM *loc_try_create_file;
/* ttyname() etc. should be defined in . But unistd.h is
missing on many systems. */
#ifndef STDC_HEADERS
char *ttyname P((int fd));
char *tmpnam P((char *s));
# ifdef sun
# ifndef __SVR4
int fputs P((char *s, FILE* stream));
int fputc P((char c, FILE* stream));
int fflush P((FILE* stream));
# endif
# else
sizet fwrite ();
# endif
int fgetc P((FILE* stream));
int fclose P((FILE* stream));
int pclose P((FILE* stream));
int unlink P((const char *pathname));
char *mktemp P((char *template));
#else
# ifdef linux
# include
# endif
# ifdef __NetBSD__
# include
# endif
# ifdef __OpenBSD__
# include
# endif
#endif
static void gc_sweep P((int contin_bad));
char s_nogrow[] = "could not grow", s_heap[] = "heap",
s_hplims[] = "hplims", s_try_create_file[] = "try-create-file";
static char s_segs[] = "segments", s_numheaps[] = "number of heaps";
static char s_input_portp[] = "input-port?",
s_output_portp[] = "output-port?";
static char s_port_closedp[] = "port-closed?";
static char s_try_open_file[] = "try-open-file";
#define s_open_file (&s_try_open_file[4])
char s_close_port[] = "close-port";
#ifdef __IBMC__
# include
# include
# define ttyname(x) "CON:"
#else
# ifndef MSDOS
# ifndef ultrix
# ifndef vms
# ifdef _DCC
# include
# define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0)
# else
# ifdef MWC
# include
# else
# ifndef macintosh
# ifndef ARM_ULIB
# ifndef PLAN9
# include
# endif
# endif
# endif
# endif
# endif
# endif
# endif
# endif
#endif /* __IBMC__ */
SCM i_setbuf0(port) /* should be called with DEFER_INTS active */
SCM port;
{
VERIFY_INTS("i_setbuf0", 0L);
#ifndef NOSETBUF
# ifndef MSDOS
# ifdef FIONREAD
# ifndef ultrix
SYSCALL(setbuf(STREAM(port), 0L););
# endif
# endif
# endif
#endif
return UNSPECIFIED;
}
/* The CRDY bit is overloaded to indicate that additional processing
is needed when reading or writing, such as updating line and column
numbers. Returns 0 if cmodes is non-null and modes string is not
valid. */
/* If nonnull, the CMODES argument receives a copy of all chars in MODES
which are allowed by ANSI C. */
long mode_bits(modes, cmodes)
char *modes, *cmodes;
{
int iout = 0;
long bits = OPN;
for (; *modes; modes++)
switch (*modes) {
case 'r': bits |= RDNG; goto outc;
case 'w': case 'a': bits |= WRTNG; goto outc;
case '+': bits |= (RDNG | WRTNG); goto outc;
case 'b': bits |= BINARY; goto outc;
case '0': bits |= BUF0; break;
case '?': bits |= (TRACKED | CRDY); break;
case 'x': bits |= EXCLUSIVE; break;
outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break;
}
if (!cmodes) return bits;
cmodes[iout] = 0;
switch (cmodes[0]) {
default: return 0;
case 'r': case 'w': case 'a': return bits;
}
}
SCM try_open_file(filename, modes)
SCM filename, modes;
{
register SCM port;
FILE *f;
char cmodes[4];
long flags;
ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file);
flags = mode_bits(CHARS(modes), cmodes);
ASRTER(flags, modes, ARG2, s_open_file);
if ((EXCLUSIVE & flags) && NIMP(*loc_try_create_file)) {
port = apply(*loc_try_create_file, filename, cons(modes, listofnull));
if (UNSPECIFIED != port) return port;
}
DEFER_INTS;
SCM_OPENCALL((f = fopen(CHARS(filename), cmodes)));
if (!f) {
ALLOW_INTS;
return BOOL_F;
}
port = scm_port_entry(f, tc16_fport, flags);
if (BUF0 & flags) i_setbuf0(port);
ALLOW_INTS;
SCM_PORTDATA(port) = filename;
return port;
}
/* Callback to Scheme */
SCM open_file(filename, modes)
SCM filename, modes;
{
return apply(*loc_open_file,
filename,
cons(modes, listofnull));
}
long tc16_clport;
SCM close_port(port)
SCM port;
{
sizet i;
SCM ret = UNSPECIFIED;
ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_close_port);
if (CLOSEDP(port)) return UNSPECIFIED;
i = PTOBNUM(port);
DEFER_INTS;
if (ptobs[i].fclose) {
int r;
SYSCALL(r = (ptobs[i].fclose)(STREAM(port)););
if (EOF == r)
ret = BOOL_F;
else
ret = MAKINUM(r);
}
CAR(port) &= ~OPN;
SCM_PORTFLAGS(port) &= ~OPN;
/* Bash the old ptobnum with the closed port ptobnum.
This allows catching some errors cheaply. */
SCM_SET_PTOBNUM(port, tc16_clport);
ALLOW_INTS;
return ret;
}
SCM input_portp(x)
SCM x;
{
if (IMP(x)) return BOOL_F;
return INPORTP(x) ? BOOL_T : BOOL_F;
}
SCM output_portp(x)
SCM x;
{
if (IMP(x)) return BOOL_F;
return OUTPORTP(x) ? BOOL_T : BOOL_F;
}
SCM port_closedp(port)
SCM port;
{
ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp);
if (CLOSEDP(port)) return BOOL_T;
return BOOL_F;
}
SCM scm_port_type(port)
SCM port;
{
int i;
if (NIMP(port) && PORTP(port)) {
i = PTOBNUM(port);
if (ptobs[i].name) return CAR(sysintern(ptobs[i].name, UNDEFINED));
return BOOL_T;
}
return BOOL_F;
}
#if (__TURBOC__==1)
# undef L_tmpnam /* Not supported in TURBOC V1.0 */
#endif
#ifdef GO32
# undef L_tmpnam /* Would put files in %TMPDIR% = %DJDIR%/tmp */
#endif
#ifdef MWC
# undef L_tmpnam
#endif
#ifdef L_tmpnam
SCM ltmpnam()
{
char name[L_tmpnam];
SYSCALL(tmpnam(name););
return makfrom0str(name);
}
#else
/* TEMPTEMPLATE is used only if mktemp() is being used instead of
tmpnam(). */
# ifdef AMIGA
# define TEMPTEMPLATE "T:SchemeaaaXXXXXX";
# else
# ifdef vms
# define TEMPTEMPLATE "sys$scratch:aaaXXXXXX";
# else /* vms */
# ifdef __MSDOS__
# ifdef GO32
# define TEMPTEMPLATE "\\tmp\\TMPaaaXXXXXX";
# else
# define TEMPTEMPLATE "TMPaaaXXXXXX";
# endif
# else /* __MSDOS__ */
# define TEMPTEMPLATE "/tmp/aaaXXXXXX";
# endif /* __MSDOS__ */
# endif /* vms */
# endif /* AMIGA */
char template[] = TEMPTEMPLATE;
# define TEMPLEN (sizeof template/sizeof(char) - 1)
SCM ltmpnam()
{
SCM name;
int temppos = TEMPLEN-9;
name = makfromstr(template, (sizet)TEMPLEN);
DEFER_INTS;
inclp:
template[temppos]++;
if (!isalpha(template[temppos])) {
template[temppos++] = 'a';
goto inclp;
}
# ifndef AMIGA
# ifndef __MSDOS__
SYSCALL(temppos = !*mktemp(CHARS(name)););
if (temppos) name = BOOL_F;
# endif
# endif
ALLOW_INTS;
return name;
}
#endif /* L_tmpnam */
#ifdef M_SYSV
# define remove unlink
#endif
static char s_del_fil[] = "delete-file";
SCM del_fil(str)
SCM str;
{
int ans;
ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil);
#ifdef STDC_HEADERS
SYSCALL(ans = remove(CHARS(str)););
#else
SYSCALL(ans = unlink(CHARS(str)););
#endif
return ans ? BOOL_F : BOOL_T;
}
void prinport(exp, port, type)
SCM exp; SCM port; char *type;
{
int filn = fileno(STREAM(exp));
lputs("#<", port);
if (CLOSEDP(exp)) lputs("closed-", port);
else {
if (RDNG & CAR(exp)) lputs("input-", port);
if (WRTNG & CAR(exp)) lputs("output-", port);
}
lputs(type, port);
lputc(' ', port);
#ifndef MSDOS
# ifndef __EMX__
# ifndef _DCC
# ifndef AMIGA
# ifndef macintosh
# ifndef PLAN9
if (OPENP(exp) && tc16_fport==TYP16(exp) && filn >= 0 && isatty(filn)) {
char *ttyn = ttyname(filn);
if (ttyn) lputs(ttyn, port);
else goto punt;
}
else
# endif
# endif
# endif
# endif
# endif
#endif
punt:
{
SCM s = PORTP(exp) ? SCM_PORTDATA(exp) : UNDEFINED;
if (NIMP(s) && STRINGP(s))
scm_iprin1(s, port, 1);
else if (OPFPORTP(exp))
scm_intprint((long)filn, 10, port);
else
scm_intprint(CDR(exp), -16, port);
if (TRACKED & SCM_PORTFLAGS(exp)) {
lputs(" L", port);
scm_intprint(scm_port_table[SCM_PORTNUM(exp)].line, 10, port);
lputs(" C", port);
scm_intprint(scm_port_table[SCM_PORTNUM(exp)].col+0L, 10, port);
}
}
lputc('>', port);
}
static int stputc(c, p)
int c; SCM p;
{
sizet ind = INUM(CAR(p));
if (ind >= LENGTH(CDR(p))) resizuve(CDR(p), MAKINUM(ind + (ind>>1)));
CHARS(CDR(p))[ind] = c;
CAR(p) = MAKINUM(ind + 1);
return c;
}
sizet stwrite(str, siz, num, p)
sizet siz, num;
char *str; SCM p;
{
sizet ind = INUM(CAR(p));
sizet len = siz * num;
char *dst;
if (ind + len >= LENGTH(CDR(p)))
resizuve(CDR(p), MAKINUM(ind + len + ((ind + len)>>1)));
dst = &(CHARS(CDR(p))[ind]);
while (len--) dst[len] = str[len];
CAR(p) = MAKINUM(ind + siz*num);
return num;
}
static int stputs(s, p)
char *s; SCM p;
{
stwrite(s, 1, strlen(s), p);
return 0;
}
static int stgetc(p)
SCM p;
{
sizet ind = INUM(CAR(p));
if (ind >= LENGTH(CDR(p))) return EOF;
CAR(p) = MAKINUM(ind + 1);
return UCHARS(CDR(p))[ind];
}
static int stclose(p)
SCM p;
{
SETCDR(p, nullstr);
return 0;
}
static int stungetc(c, p)
int c;
SCM p;
{
sizet ind;
p = CDR(p);
ind = INUM(CAR(p));
if (ind == 0) return EOF;
CAR(p) = MAKINUM(--ind);
ASRTER(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", "");
return c;
}
int noop0(stream)
FILE *stream;
{
return 0;
}
SCM mkstrport(pos, str, modes, caller)
SCM pos;
SCM str;
long modes;
char *caller;
{
SCM z;
ASRTER(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller);
ASRTER(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller);
str = cons(pos, str);
NEWCELL(z);
DEFER_INTS;
SETCHARS(z, str);
CAR(z) = (modes | tc16_strport); /* port table entry 0 is scratch. */
/* z = scm_port_entry((FILE *)str, tc16_strport, modes); */
ALLOW_INTS;
return z;
}
static char s_cwos[] = "call-with-output-string";
static char s_cwis[] = "call-with-input-string";
SCM cwos(proc)
SCM proc;
{
SCM p = mkstrport(INUM0, make_string(MAKINUM(30), UNDEFINED),
OPN | WRTNG,
s_cwos);
apply(proc, p, listofnull);
return resizuve(CDR(CDR(p)), CAR(CDR(p)));
}
SCM cwis(str, proc)
SCM str, proc;
{
SCM p = mkstrport(INUM0, str, OPN | RDNG, s_cwis);
return apply(proc, p, listofnull);
}
#ifdef vms
sizet pwrite(ptr, size, nitems, port)
char *ptr;
sizet size, nitems;
FILE* port;
{
sizet len = size * nitems;
sizet i = 0;
for (;i < len;i++) putc(ptr[i], port);
return len;
}
# define ffwrite pwrite
#else
# define ffwrite fwrite
#endif
static ptobfuns fptob = {
s_port_type,
mark0,
fclose,
0,
0,
fputc,
#ifdef __MWERKS__
(int (*)(char *, struct _FILE *))fputs,
(unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
#else
fputs,
ffwrite,
#endif
fflush,
fgetc,
fclose};
ptobfuns pipob = {
0,
mark0,
0, /* replaced by pclose in init_posix() */
0,
0,
fputc,
#ifdef __MWERKS__
(int (*)(char *, struct _FILE *))fputs,
(unsigned long (*)(char *, unsigned long, unsigned long, struct _FILE *))ffwrite,
#else
fputs,
ffwrite,
#endif
fflush,
fgetc};
static ptobfuns stptob = {
s_string,
markcdr,
noop0,
0,
0,
stputc,
stputs,
stwrite,
noop0,
stgetc,
stclose,
stungetc};
/* Soft ports */
/* fputc, fwrite, fputs, and fclose are called within a
SYSCALL. So we need to set errno to 0 before returning. fflush
may be called within a SYSCALL. So we need to set errno to 0
before returning. */
static int sfputc(c, p)
int c; SCM p;
{
SCM arg = MAKICHR(c);
scm_cvapply(VELTS(p)[0], 1L, &arg);
errno = 0;
return c;
}
sizet sfwrite(str, siz, num, p)
sizet siz, num;
char *str; SCM p;
{
SCM sstr;
sstr = makfromstr(str, siz * num);
scm_cvapply(VELTS(p)[1], 1L, &sstr);
errno = 0;
return num;
}
static int sfputs(s, p)
char *s; SCM p;
{
sfwrite(s, 1, strlen(s), p);
return 0;
}
int sfflush(stream)
SCM stream;
{
SCM f = VELTS(stream)[2];
if (BOOL_F==f) return 0;
f = apply(f, EOL, EOL);
errno = 0;
return BOOL_F==f ? EOF : 0;
}
static int sfgetc(p)
SCM p;
{
SCM ans;
ans = scm_cvapply(VELTS(p)[3], 0L, (SCM *)0);
errno = 0;
if (FALSEP(ans) || EOF_VAL==ans) return EOF;
ASRTER(ICHRP(ans), ans, ARG1, "getc");
return ICHR(ans);
}
static int sfclose(p)
SCM p;
{
SCM f = VELTS(p)[4];
if (BOOL_F==f) return 0;
f = apply(f, EOL, EOL);
errno = 0;
return BOOL_F==f ? EOF : 0;
}
static char s_mksfpt[] = "make-soft-port";
SCM mksfpt(pv, modes)
SCM pv, modes;
{
SCM z;
long flags;
static long arities[] = {1, 1, 0, 0, 0};
#ifndef RECKLESS
int i;
if (! (NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv)))
badarg: wta(pv, (char *)ARG1, s_mksfpt);
for (i = 0; i < 5; i++) {
ASRTGO(FALSEP(VELTS(pv)[i]) ||
scm_arity_check(VELTS(pv)[i], arities[i], (char *)0),
badarg);
}
#endif
ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt);
flags = mode_bits(CHARS(modes), (char *)0);
ASRTER(flags, modes, ARG2, s_mksfpt);
DEFER_INTS;
z = scm_port_entry((FILE *)pv, tc16_sfport, flags);
ALLOW_INTS;
return z;
}
static ptobfuns sfptob = {
"soft",
markcdr,
noop0,
0,
0,
sfputc,
sfputs,
sfwrite,
sfflush,
sfgetc,
sfclose};
/* Closed ports, just return an error code and let
the caller complain. */
static int clputc(c, p)
int c; FILE *p;
{
return EOF;
}
static sizet clwrite(str, siz, num, p)
sizet siz, num;
char *str; FILE *p;
{
return 0;
}
static int clputs(s, p)
char *s; FILE *p;
{
return EOF;
}
static int clgetc(p)
FILE *p;
{
return EOF;
}
static ptobfuns clptob = {
s_port_type,
mark0,
noop0,
0,
0,
clputc,
clputs,
clwrite,
clgetc,
clgetc,
0};
/* The following ptob is for printing system messages in an interrupt-safe
way. Writing to sys_errp while interrupts are disabled will never enable
interrupts, do any actual i/o, or any allocation. Messages will be
written to cur_errp as soon as interrupts are enabled. There will only
ever be one of these. */
int output_deferred = 0;
static int tc16_sysport;
#define SYS_ERRP_SIZE 480
static char errbuf[SYS_ERRP_SIZE];
static sizet errbuf_end = 0;
static sizet syswrite(str, siz, num, p)
sizet siz, num;
char *str; FILE *p;
{
sizet src, dst = errbuf_end;
sizet n = siz*num;
if (ints_disabled) {
deferred_proc = process_signals;
output_deferred = !0;
for (src = 0; src < n; src++, dst++)
errbuf[dst % SYS_ERRP_SIZE] = str[src];
errbuf_end = dst;
}
else {
/* if (NIMP(cur_errp) && OPOUTPORTP(cur_errp)) lfflush(cur_errp); */
if (errbuf_end > 0) {
if (errbuf_end > SYS_ERRP_SIZE) {
scm_warn("output buffer", " overflowed", UNDEFINED);
scm_intprint((long)errbuf_end, 10, cur_errp);
lputs(" chars needed\n", cur_errp);
errbuf_end = errbuf_end % SYS_ERRP_SIZE;
lfwrite(&errbuf[errbuf_end], 1,
SYS_ERRP_SIZE - errbuf_end, cur_errp);
}
lfwrite(errbuf, sizeof(char), errbuf_end, cur_errp);
errbuf_end = 0;
}
num = lfwrite(str, siz, num, cur_errp);
/* if (NIMP(cur_errp) && OPOUTPORTP(cur_errp)) lfflush(cur_errp); */
}
errno = 0;
return num;
}
static int sysputs(s, p)
char *s; FILE *p;
{
syswrite(s, 1, strlen(s), p);
return 0;
}
static int sysputc(c, p)
int c; FILE *p;
{
char cc = c;
syswrite(&cc, 1, 1, p);
return c;
}
static ptobfuns sysptob = {
0,
mark0,
noop0,
0,
0,
sysputc,
sysputs,
syswrite,
noop0,
noop0,
noop0};
/* A `safeport' is used for writing objects as part of an error response.
Since these objects may be very large or circular, the safeport will
output only a fixed number of characters before exiting via longjmp.
A setjmp must be done before each use of the safeport. */
static char s_msp[] = "mksafeport";
int tc16_safeport;
SCM mksafeport(maxlen, port)
int maxlen;
SCM port;
{
SCM z;
if (UNBNDP(port)) port = cur_errp;
ASRTER(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
z = must_malloc_cell(sizeof(safeport)+0L,
tc16_safeport | OPN | WRTNG,
s_msp);
((safeport *)STREAM(z))->ccnt = maxlen;
((safeport *)STREAM(z))->port = port;
return z;
}
int reset_safeport(sfp, maxlen, port)
int maxlen;
SCM sfp, port;
{
if (NIMP(sfp) && tc16_safeport==TYP16(sfp)) {
((safeport *)STREAM(sfp))->ccnt = maxlen;
if (NIMP(port))
((safeport *)STREAM(sfp))->port = port;
return !0;
}
return 0;
}
static sizet safewrite(str, siz, num, p)
sizet siz, num;
char *str; safeport *p;
{
int count = p->ccnt;
sizet n = siz*num;
if (n < count) {
p->ccnt = count - n;
lfwrite(str, siz, num, p->port);
}
else if (count) {
num = count / siz;
p->ccnt = 0;
lfwrite(str, siz, num, p->port);
lputs(" ...", p->port);
longjmp(p->jmpbuf, !0); /* The usual C longjmp, not SCM's longjump */
}
return num;
}
static int safeputs(s, p)
char *s; safeport *p;
{
safewrite(s, 1, strlen(s), p);
return 0;
}
static int safeputc(c, p)
int c; safeport *p;
{
char cc = c;
safewrite(&cc, 1, 1, p);
return c;
}
static int safeflush(p)
safeport *p;
{
if (p && NIMP(p->port) && OPOUTPORTP(p->port)) lfflush(p->port);
return 0;
}
static SCM marksafep(ptr)
SCM ptr;
{
return ((safeport *)STREAM(ptr))->port;
}
static int freesafep(ptr)
FILE *ptr;
{
must_free((char *)ptr, sizeof(safeport));
return 0;
}
static ptobfuns safeptob = {
0,
marksafep,
freesafep,
0,
0,
safeputc,
safeputs,
safewrite,
safeflush,
noop0,
noop0};
static int freeprint(exp, port, writing)
SCM exp; SCM port; int writing;
{
if (tc_broken_heart==CAR(exp)) {
lputs("#", port);
scm_iprin1(CDR(exp), port, writing);
}
else {
if (NIMP(CDR(exp)) && tc7_smob==CAR(CDR(exp))) {
lputs("#', port);
return !0;
}
static smobfuns freecell = {
mark0,
free0,
freeprint,
0};
static smobfuns flob = {
mark0,
/*flofree*/0,
floprint,
#ifdef FLOATS
floequal
#else
0
#endif
};
static smobfuns bigob = {
mark0,
/*bigfree*/0,
bigprint,
#ifdef BIGDIG
bigequal
#else
0
#endif
};
scm_gra finals_gra;
static char s_final[] = "final";
/* statically allocated ports for diagnostic messages */
static cell tmp_errpbuf[3];
static SCM tmp_errp;
extern sizet num_protects; /* sys_protects now in scl.c */
void init_types()
{
sizet j = num_protects;
while(j) sys_protects[--j] = UNDEFINED;
/* We need to set up tmp_errp before any errors may be
thrown, the port_table index will be zero, usable by
all ports that don't care about their table entries. */
tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
CAR(tmp_errp) = tc16_fport | OPN | WRTNG;
/* CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG); */
SETSTREAM(tmp_errp, stderr);
cur_errp = def_errp = sys_safep = tmp_errp;
/* subrs_gra is trimmed to actual used by scm_init_extensions() */
scm_init_gra(&subrs_gra, sizeof(subr_info), 420 , 0, "subrs");
scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 8, 255, "ptobs");
/* These newptob calls must be done in this order */
/* tc16_fport = */ newptob(&fptob);
/* tc16_pipe = */ newptob(&pipob);
/* tc16_strport = */ newptob(&stptob);
/* tc16_sfport = */ newptob(&sfptob);
tc16_clport = newptob(&clptob);
tc16_sysport = newptob(&sysptob);
tc16_safeport = newptob(&safeptob);
scm_init_gra(&smobs_gra, sizeof(smobfuns), 16, 255, "smobs");
/* These newsmob calls must be done in this order */
newsmob(&freecell);
newsmob(&flob);
newsmob(&bigob);
newsmob(&bigob);
scm_init_gra(&finals_gra, sizeof(void (*)()), 4, 0, s_final);
}
#ifdef TEST_FINAL
void test_final()
{
fputs("test_final ok\n", stderr);
}
#endif
void add_final(final)
void (* final)();
{
scm_grow_gra(&finals_gra, (char *)&final);
}
static SCM gc_finalizers = EOL, gc_finalizers_pending = EOL;
static char s_add_finalizer[] = "add-finalizer";
SCM scm_add_finalizer(value, finalizer)
SCM value, finalizer;
{
SCM z;
ASRTER(NIMP(value), value, ARG1, s_add_finalizer);
#ifndef RECKLESS
scm_arity_check(finalizer, 0L, s_add_finalizer);
#endif
z = acons(value, finalizer, EOL);
DEFER_INTS;
CDR(z) = gc_finalizers;
gc_finalizers = z;
ALLOW_INTS;
return UNSPECIFIED;
}
static char s_estk[] = "environment stack";
static cell ecache_v[ECACHE_SIZE];
SCM scm_egc_roots[ECACHE_SIZE/20];
CELLPTR scm_ecache;
VOLATILE long scm_ecache_index, scm_ecache_len, scm_egc_root_index;
SCM scm_estk = UNDEFINED, *scm_estk_ptr;
static SCM estk_pool = EOL;
long scm_estk_size;
static SCM make_stk_seg(size, contents)
sizet size;
SCM contents;
{
SCM seg = BOOL_F, *src, *dst;
sizet i;
VERIFY_INTS("make_stk_seg", 0L);
while NIMP(estk_pool) {
if (size==LENGTH(estk_pool)) {
seg = estk_pool;
estk_pool = SCM_ESTK_PARENT(seg);
break;
}
estk_pool = SCM_ESTK_PARENT(estk_pool);
}
if (IMP(seg)) seg = must_malloc_cell((long)size*sizeof(SCM),
MAKE_LENGTH(size, tc7_vector), s_estk);
dst = VELTS(seg);
if (NIMP(contents)) {
src = VELTS(contents);
for (i = size; i--;) dst[i] = src[i];
}
else {
for (i = size; i--;) dst[i] = UNSPECIFIED;
SCM_ESTK_PARENT(seg) = BOOL_F;
SCM_ESTK_PARENT_INDEX(seg) = INUM0;
dst[SCM_ESTK_BASE - 1] = UNDEFINED; /* underflow sentinel */
}
dst[size - 1] = UNDEFINED; /* overflow sentinel */
return seg;
}
/* size is a number of SCM elements, or zero for a default size.
If nonzero, size must be SCM_ESTK_BASE + N * SCM_ESTK_FRLEN + 1
for some reasonable number of stackframes N */
void scm_estk_reset(size)
sizet size;
{
VERIFY_INTS("scm_estk_reset", 0L);
if (!size) size = SCM_ESTK_BASE + 20*SCM_ESTK_FRLEN + 1;
scm_estk = make_stk_seg(size, UNDEFINED);
scm_estk_ptr = &(VELTS(scm_estk)[SCM_ESTK_BASE]);
scm_estk_size = size + 0L;
}
void scm_estk_grow()
{
/* 40 and 10 below are adjustable parameters: the number of frames
in a stack segment, and the number of frames to overlap between
stack segments. */
sizet size = 40 * SCM_ESTK_FRLEN + SCM_ESTK_BASE + 1;
sizet overlap = 10*SCM_ESTK_FRLEN;
SCM estk = make_stk_seg(size, UNDEFINED);
SCM *newv, *oldv;
sizet i, j;
newv = VELTS(estk);
oldv = VELTS(scm_estk);
j = scm_estk_ptr - oldv + SCM_ESTK_FRLEN - overlap;
SCM_ESTK_PARENT(estk) = scm_estk;
SCM_ESTK_PARENT_WRITABLEP(estk) = BOOL_T;
SCM_ESTK_PARENT_INDEX(estk) = MAKINUM(j - SCM_ESTK_FRLEN);
for (i = SCM_ESTK_BASE; i < SCM_ESTK_BASE + overlap; i++, j++) {
newv[i] = oldv[j];
oldv[j] = BOOL_F;
}
scm_estk = estk;
scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]);
scm_estk_size += size + 0L;
/* growth_mon(s_estk, scm_estk_size, "locations", !0); */
}
void scm_estk_shrink()
{
SCM parent;
sizet i;
parent = SCM_ESTK_PARENT(scm_estk);
i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk));
if (IMP(parent)) wta(UNDEFINED, "underflow", s_estk);
if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk)) {
parent = make_stk_seg((sizet)LENGTH(parent), parent);
SCM_ESTK_PARENT_WRITABLEP(parent) = BOOL_F;
}
SCM_ESTK_PARENT(scm_estk) = estk_pool;
estk_pool = scm_estk;
scm_estk_size -= LENGTH(scm_estk);
scm_estk = parent;
scm_estk_ptr = &(VELTS(parent)[i]);
/* growth_mon(s_estk, scm_estk_size, "locations", 0); */
}
void scm_env_cons(x, y)
SCM x, y;
{
register SCM z;
register int i;
DEFER_INTS_EGC;
i = scm_ecache_index;
if (1>i) {
scm_egc();
i = scm_ecache_index;
}
z = PTR2SCM(&(scm_ecache[--i]));
CAR(z) = x;
CDR(z) = y;
scm_env_tmp = z;
scm_ecache_index = i;
}
void scm_env_cons2(w, x, y)
SCM w, x, y;
{
SCM z1, z2;
register int i;
DEFER_INTS_EGC;
i = scm_ecache_index;
if (2>i) {
scm_egc();
i = scm_ecache_index;
}
z1 = PTR2SCM(&(scm_ecache[--i]));
CAR(z1) = x;
CDR(z1) = y;
z2 = PTR2SCM(&(scm_ecache[--i]));
CAR(z2) = w;
CDR(z2) = z1;
scm_env_tmp = z2;
scm_ecache_index = i;
}
void scm_env_cons3(v, w, x, y)
SCM v, w, x, y;
{
SCM z1, z2;
register int i;
DEFER_INTS_EGC;
i = scm_ecache_index;
if (3>i) {
scm_egc();
i = scm_ecache_index;
}
z1 = PTR2SCM(&(scm_ecache[--i]));
CAR(z1) = x;
CDR(z1) = y;
z2 = PTR2SCM(&(scm_ecache[--i]));
CAR(z2) = w;
CDR(z2) = z1;
z1 = PTR2SCM(&(scm_ecache[--i]));
CAR(z1) = v;
CDR(z1) = z2;
scm_env_tmp = z1;
scm_ecache_index = i;
}
void scm_env_v2lst(argc, argv)
long argc;
SCM *argv;
{
SCM z1, z2;
register int i;
DEFER_INTS_EGC;
i = scm_ecache_index;
if (argc>i) {
scm_egc();
i = scm_ecache_index;
}
z1 = z2 = scm_env_tmp; /* set z1 just in case argc is zero */
while (argc--) {
z1 = PTR2SCM(&(scm_ecache[--i]));
CAR(z1) = argv[argc];
CDR(z1) = z2;
z2 = z1;
}
scm_env_tmp = z1;
scm_ecache_index = i;
}
/* scm_env = acons(names, scm_env_tmp, scm_env) */
void scm_extend_env()
{
SCM z;
register int i;
DEFER_INTS_EGC;
i = scm_ecache_index;
if (1>i) {
scm_egc();
i = scm_ecache_index;
}
z = PTR2SCM(&(scm_ecache[--i]));
CAR(z) = scm_env_tmp;
CDR(z) = scm_env;
scm_env = z;
scm_ecache_index = i;
}
void old_scm_extend_env(names)
SCM names;
{
SCM z1, z2;
register int i;
DEFER_INTS_EGC;
i = scm_ecache_index;
if (2>i) {
scm_egc();
i = scm_ecache_index;
}
z1 = PTR2SCM(&(scm_ecache[--i]));
CAR(z1) = names;
CDR(z1) = scm_env_tmp;
z2 = PTR2SCM(&(scm_ecache[--i]));
CAR(z2) = z1;
CDR(z2) = scm_env;
scm_env = z2;
scm_ecache_index = i;
}
char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc";
char s_recursive[] = "recursive";
#define s_gc (s_cache_gc+6)
static iproc subr0s[] = {
{"tmpnam", ltmpnam},
{"open-ports", scm_open_ports},
{0, 0}};
static iproc subr1s[] = {
{s_input_portp, input_portp},
{s_output_portp, output_portp},
{s_port_closedp, port_closedp},
{s_close_port, close_port},
{"eof-object?", eof_objectp},
{"port-type", scm_port_type},
{s_cwos, cwos},
{"object-hash", obhash},
{s_obunhash, obunhash},
{s_del_fil, del_fil},
{0, 0}};
static iproc subr2s[] = {
{s_try_open_file, try_open_file},
{s_cwis, cwis},
{s_mksfpt, mksfpt},
{s_add_finalizer, scm_add_finalizer},
{0, 0}};
SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3));
void init_io()
{
make_subr("dynamic-wind", tc7_subr_3, dynwind);
make_subr(s_gc, tc7_subr_1o, gc);
init_iprocs(subr0s, tc7_subr_0);
init_iprocs(subr1s, tc7_subr_1);
init_iprocs(subr2s, tc7_subr_2);
loc_open_file =
&CDR(sysintern(s_open_file,
CDR(sysintern(s_try_open_file, UNDEFINED))));
loc_try_create_file = &CDR(sysintern(s_try_create_file, UNDEFINED));
#ifndef CHEAP_CONTINUATIONS
add_feature("full-continuation");
#endif
#ifdef TEST_FINAL
add_final(test_final);
#endif
}
void grew_lim(nm)
long nm;
{
growth_mon(s_limit, nm, "bytes", !0);
}
int expmem = 0;
sizet hplim_ind = 0;
long heap_cells = 0;
CELLPTR *hplims, heap_org;
VOLATILE SCM freelist = EOL;
long mltrigger, mtrigger = INIT_MALLOC_LIMIT;
int gc_hook_pending = 0, gc_hook_active = 0;
/* Ints should be deferred when calling igc_for_alloc. */
static char *igc_for_alloc(where, olen, size, what)
char *where;
long olen;
sizet size;
const char *what;
{
char *ptr;
long nm;
/* Check to see that heap is initialized */
ASRTER(heap_cells > 0, MAKINUM(size), NALLOC, what);
/* printf("igc_for_alloc(%lx, %lu, %u, %s)\n", where, olen, size, what); fflush(stdout); */
igc(what, rootcont);
nm = mallocated + size - olen;
if (nm > mltrigger) {
if (nm > mtrigger) grew_lim(nm + nm/2);
else grew_lim(mtrigger + mtrigger/2);
}
if (where) SYSCALL(ptr = (char *)realloc(where, size););
else SYSCALL(ptr = (char *)malloc(size););
ASRTER(ptr, MAKINUM(size), NALLOC, what);
if (nm > mltrigger) {
if (nm > mtrigger) mtrigger = nm + nm/2;
else mtrigger += mtrigger/2;
mltrigger = mtrigger - MIN_MALLOC_YIELD;
}
mallocated = nm;
return ptr;
}
char *must_malloc(len, what)
long len;
const char *what;
{
char *ptr;
sizet size = len;
long nm = mallocated + size;
VERIFY_INTS("must_malloc", what);
#ifdef SHORT_SIZET
ASRTER(len==size, MAKINUM(len), NALLOC, what);
#endif
if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
else ptr = 0;
if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what);
else mallocated = nm;
/* printf("must_malloc(%lu, %s) => %lx\n", len, what, ptr); fflush(stdout); */
return ptr;
}
SCM must_malloc_cell(len, c, what)
long len;
SCM c;
const char *what;
{
SCM z;
char *ptr;
sizet size = len;
long nm = mallocated + size;
VERIFY_INTS("must_malloc_cell", what);
#ifdef SHORT_SIZET
ASRTER(len==size, MAKINUM(len), NALLOC, what);
#endif
NEWCELL(z);
if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size););
else ptr = 0;
if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what);
else mallocated = nm;
/* printf("must_malloc_cell(%lu, %lx, %s) => %lx\n", len, c, what, ptr); fflush(stdout); */
SETCHARS(z, ptr);
CAR(z) = c;
return z;
}
char *must_realloc(where, olen, len, what)
char *where;
long olen, len;
const char *what;
{
char *ptr;
sizet size = len;
long nm = mallocated + size - olen;
VERIFY_INTS("must_realloc", what);
#ifdef SHORT_SIZET
ASRTER(len==size, MAKINUM(len), NALLOC, what);
#endif
ASRTER(!errjmp_bad, MAKINUM(len), NALLOC, what);
/* printf("must_realloc(%lx, %lu, %lu, %s)\n", where, olen, len, what); fflush(stdout);
printf("nm = %ld <= mtrigger = %ld: %d; size = %u\n", nm, mtrigger, (nm <= mtrigger), size); fflush(stdout); */
if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
else ptr = 0;
if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
else mallocated = nm;
return ptr;
}
void must_realloc_cell(z, olen, len, what)
SCM z;
long olen, len;
const char *what;
{
char *ptr, *where = CHARS(z);
sizet size = len;
long nm = mallocated + size - olen;
VERIFY_INTS("must_realloc_cell", what);
#ifdef SHORT_SIZET
ASRTER(len==size, MAKINUM(len), NALLOC, what);
#endif
ASRTER(!errjmp_bad, MAKINUM(len), NALLOC, what);
/* printf("must_realloc_cell(%lx, %lu, %lu, %s)\n", z, olen, len, what); fflush(stdout); */
if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size););
else ptr = 0;
if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
else mallocated = nm;
SETCHARS(z, ptr);
}
void must_free(obj, len)
char *obj;
sizet len;
{
if (obj) {
#ifdef CAREFUL_INTS
while (len--) obj[len] = '#';
#endif
/* printf("free(%lx)\n", obj); fflush(stdout); */
free(obj);
mallocated = mallocated - len;
}
else wta(INUM0, "already free", "");
}
SCM symhash; /* This used to be a sys_protect, but
Radey Shouman
added GC for unused, UNDEFINED
symbols.*/
int symhash_dim = NUM_HASH_BUCKETS;
/* sym2vcell looks up the symbol in the symhash table. */
SCM sym2vcell(sym)
SCM sym;
{
SCM lsym, z;
sizet hash = strhash(UCHARS(sym), (sizet)LENGTH(sym),
(unsigned long)symhash_dim);
for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
z = CAR(lsym);
if (CAR(z)==sym) return z;
}
wta(sym, "uninterned symbol? ", "");
}
/* intern() and sysintern() return a pair;
CAR is the symbol, CDR is the value. */
SCM intern(name, len)
char *name;
sizet len;
{
SCM lsym, z;
register sizet i = len;
register unsigned char *tmp = (unsigned char *)name;
sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
/* printf("intern %s len=%d\n",name,len); fflush(stdout); */
DEFER_INTS;
for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
z = CAR(lsym);
z = CAR(z);
tmp = UCHARS(z);
if (LENGTH(z) != len) goto trynext;
for (i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
ALLOW_INTS;
return CAR(lsym);
trynext: ;
}
/* lsym = makfromstr(name, len); */
lsym = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_msymbol), s_string);
i = len;
CHARS(lsym)[len] = 0;
while (i--) CHARS(lsym)[i] = name[i];
z = acons(lsym, UNDEFINED, UNDEFINED);
CDR(z) = VELTS(symhash)[hash];
VELTS(symhash)[hash] = z;
z = CAR(z);
ALLOW_INTS;
return z;
}
SCM sysintern(name, val)
const char *name;
SCM val;
{
SCM lsym, z;
sizet len = strlen(name);
register sizet i = len;
register unsigned char *tmp = (unsigned char *)name;
sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
for (lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
z = CAR(lsym);
z = CAR(z);
tmp = UCHARS(z);
if (LENGTH(z) != len) goto trynext;
for (i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
lsym = CAR(lsym);
if (!UNBNDP(val)) CDR(lsym) = val;
else if (UNBNDP(CDR(lsym)) && tc7_msymbol==TYP7(CAR(lsym)))
scm_gc_protect(lsym);
return lsym;
trynext: ;
}
NEWCELL(lsym);
SETLENGTH(lsym, len, tc7_ssymbol);
SETCHARS(lsym, name);
lsym = cons(lsym, val);
z = cons(lsym, UNDEFINED);
CDR(z) = VELTS(symhash)[hash];
VELTS(symhash)[hash] = z;
return lsym;
}
SCM cons(x, y)
SCM x, y;
{
register SCM z;
NEWCELL(z);
CAR(z) = x;
CDR(z) = y;
return z;
}
SCM cons2(w, x, y)
SCM w, x, y;
{
register SCM z;
NEWCELL(z);
CAR(z) = x;
CDR(z) = y;
x = z;
NEWCELL(z);
CAR(z) = w;
CDR(z) = x;
return z;
}
SCM acons(w, x, y)
SCM w, x, y;
{
register SCM z;
NEWCELL(z);
CAR(z) = w;
CDR(z) = x;
x = z;
NEWCELL(z);
CAR(z) = x;
CDR(z) = y;
return z;
}
SCM makstr(len)
long len;
{
SCM s;
#ifndef SHORT_SIZET
ASRTER(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string);
#endif
DEFER_INTS;
s = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_string), s_string);
CHARS(s)[len] = 0;
ALLOW_INTS;
return s;
}
char s_redefining[] = "redefining ";
scm_gra subrs_gra;
SCM scm_maksubr(name, type, fcn)
const char *name;
int type;
SCM (*fcn)();
{
subr_info info;
int isubr;
register SCM z;
info.name = name;
for (isubr = subrs_gra.len; 0 < isubr--;) {
if (0==strcmp(((char **)subrs_gra.elts)[isubr], name)) {
scm_warn(s_redefining, (char *)name, UNDEFINED);
goto foundit;
}
}
isubr = scm_grow_gra(&subrs_gra, (char *)&info);
foundit:
NEWCELL(z);
if (!fcn && tc7_cxr==type) {
const char *p = name;
int code = 0;
while (*++p != 'r')
switch (*p) {
default: wta(UNDEFINED, "bad cxr name", (char *)name);
case 'a': code = (code<<2) + 1; continue;
case 'd': code = (code<<2) + 2; continue;
}
type += (code << 8);
}
CAR(z) = (isubr<<16) + type;
SUBRF(z) = fcn;
return z;
}
SCM make_subr(name, type, fcn)
const char *name;
int type;
SCM (*fcn)();
{
return CDR(sysintern(name, scm_maksubr(name, type, fcn)));
}
#ifdef CCLO
char s_comp_clo[] = "compiled-closure";
SCM makcclo(proc, len)
SCM proc;
long len;
{
SCM s;
# ifndef SHORT_SIZET
ASRTER(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo);
# endif
DEFER_INTS;
s = must_malloc_cell(len*sizeof(SCM), MAKE_NUMDIGS(len, tc16_cclo),
s_comp_clo);
while (--len) VELTS(s)[len] = UNSPECIFIED;
CCLO_SUBR(s) = proc;
ALLOW_INTS;
return s;
}
#endif
void stack_check()
{
STACKITEM *start = CONT(rootcont)->stkbse;
STACKITEM stack;
#ifdef STACK_GROWS_UP
if (&stack - start > STACK_LIMIT/sizeof(STACKITEM))
#else
if (start - &stack > STACK_LIMIT/sizeof(STACKITEM))
#endif /* def STACK_GROWS_UP */
{
stack_report();
wta(UNDEFINED, (char *)SEGV_SIGNAL, "stack");
}
}
void stack_report()
{
STACKITEM stack;
lputs(";; stack: 0x", cur_errp);
scm_intprint((long)CONT(rootcont)->stkbse, -16, cur_errp);
lputs(" - 0x", cur_errp);
scm_intprint((long)&stack, -16, cur_errp);
lputs("; ", cur_errp);
scm_intprint(stack_size(CONT(rootcont)->stkbse)*sizeof(STACKITEM), 10, cur_errp);
lputs(" bytes\n", cur_errp);
}
SCM dynwind(thunk1, thunk2, thunk3)
SCM thunk1, thunk2, thunk3;
{
SCM ans;
apply(thunk1, EOL, EOL);
dynwinds = acons(thunk1, thunk3, dynwinds);
ans = apply(thunk2, EOL, EOL);
dynwinds = CDR(dynwinds);
apply(thunk3, EOL, EOL);
return ans;
}
void downd(to, delta)
SCM to;
long delta;
{
tail:
if (dynwinds==to);
else if (0 > delta) {
downd(CDR(to), 1+delta);
apply(CAR(CAR(to)), EOL, EOL);
dynwinds = to;
}
else {
SCM from = CDR(CAR(dynwinds));
dynwinds = CDR(dynwinds);
apply(from, EOL, EOL);
delta--; goto tail; /* downd(to, delta-1); */
}
}
void dowinds(to)
SCM to;
{
downd(to, ilength(dynwinds) - ilength(to));
}
/* Remember that setjump needs to be called after scm_make_cont */
SCM scm_make_cont()
{
SCM cont, estk, *from;
CONTINUATION *ncont;
sizet n;
VERIFY_INTS("scm_make_cont", 0L);
NEWCELL(cont);
from = VELTS(scm_estk);
n = scm_estk_ptr - from + SCM_ESTK_FRLEN;
#ifdef CHEAP_CONTINUATIONS
estk = scm_estk;
#else
from[1] = BOOL_F; /* Can't write to parent stack */
estk = must_malloc_cell((long)n*sizeof(SCM),
MAKE_LENGTH(n, tc7_vector), s_cont);
{
SCM *to = VELTS(estk);
while(n--) to[n] = from[n];
}
#endif
ncont = make_continuation(CONT(rootcont));
if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont);
ncont->other.parent = rootcont;
SETCONT(cont, ncont);
SETLENGTH(cont, ncont->length, tc7_contin);
ncont->other.dynenv = dynwinds;
ncont->other.stkframe[0] = scm_env;
ncont->other.stkframe[1] = scm_env_tmp;
ncont->other.estk = estk;
#ifdef CHEAP_CONTINUATIONS
ncont->other.estk_ptr = scm_estk_ptr;
#else
ncont->other.estk_ptr = (SCM *)0;
#endif
#ifndef RECKLESS
ncont->other.stkframe[2] = scm_trace_env;
ncont->other.stkframe[3] = scm_trace;
#endif
return cont;
}
static char s_sstale[] = "strangely stale";
void scm_dynthrow(tocont, arg1, arg2, rest)
SCM tocont;
SCM arg1, arg2, rest;
{
CONTINUATION *cont = CONT(tocont);
if (cont->stkbse != CONT(rootcont)->stkbse)
wta(tocont, &s_sstale[10], s_cont);
dowinds(cont->other.dynenv);
{
DEFER_INTS;
#ifdef CHEAP_CONTINUATIONS
scm_estk = cont->other.estk;
scm_estk_ptr = cont->other.estk_ptr;
#else
{
SCM *to, *from = VELTS(cont->other.estk);
sizet n = LENGTH(cont->other.estk);
if (LENGTH(scm_estk) < n) scm_estk_reset(n);
to = VELTS(scm_estk);
scm_estk_ptr = &(to[n - SCM_ESTK_FRLEN]);
while(n--) to[n] = from[n];
}
#endif
scm_env = cont->other.stkframe[0];
scm_env_tmp = cont->other.stkframe[1];
#ifndef RECKLESS
scm_trace_env = cont->other.stkframe[2];
scm_trace = cont->other.stkframe[3];
#endif
if (!UNBNDP(arg2) && IM_VALUES_TOKEN == scm_env_tmp) {
scm_env_cons(arg2, rest);
arg2 = UNDEFINED;
}
ALLOW_INTS;
}
if (!UNBNDP(arg2)) return; /* eval will signal wrong number of args */
throw_to_continuation(cont, arg1, CONT(rootcont));
wta(tocont, s_sstale, s_cont);
}
SCM obhash(obj)
SCM obj;
{
#ifdef BIGDIG
long n = SRS(obj, 1);
if (!FIXABLE(n)) return long2big(n);
#endif
return (obj<<1)+2L;
}
SCM obunhash(obj)
SCM obj;
{
#ifdef BIGDIG
if (NIMP(obj) && BIGP(obj)) {
sizet i = NUMDIGS(obj);
BIGDIG *ds = BDIGITS(obj);
if (TYP16(obj)==tc16_bigpos) {
obj = 0;
while (i--) obj = BIGUP(obj) + ds[i];
}
else {
obj = 0;
while (i--) obj = BIGUP(obj) - ds[i];
}
obj <<= 1;
goto comm;
}
#endif
ASRTER(INUMP(obj), obj, ARG1, s_obunhash);
obj = SRS(obj, 1) & ~1L;
comm:
if (IMP(obj)) return obj;
if (NCELLP(obj)) return BOOL_F;
{
/* This code is adapted from mark_locations() in "sys.c" and
scm_cell_p() in "rope.c", which means that changes to these
routines must be coordinated. */
register CELLPTR ptr = (CELLPTR)SCM2PTR(obj);
register sizet i = 0, j = hplim_ind;
do {
if (PTR_GT(hplims[i++], ptr)) break;
if (PTR_LE(hplims[--j], ptr)) break;
if ((i != j)
&& PTR_LE(hplims[i++], ptr)
&& PTR_GT(hplims[--j], ptr)) continue;
if (NFREEP(obj)) return obj;
break;
} while(i5)
{
sizet i = 5;
unsigned long h = 264 % n;
while (i--) h = ((h<<8) + ((unsigned)(downcase[str[h % len]]))) % n;
return h;
}
else {
sizet i = len;
unsigned long h = 0;
while (i) h = ((h<<8) + ((unsigned)(downcase[str[--i]]))) % n;
return h;
}
}
static void fixconfig(s1, s2, s)
char *s1, *s2;
int s;
{
fputs(s1, stderr);
fputs(s2, stderr);
fputs("\nin ", stderr);
fputs(s ? "setjump" : "scmfig", stderr);
fputs(".h and recompile scm\n", stderr);
quit(MAKINUM(1L));
}
void heap_report()
{
sizet i = 0;
if (hplim_ind) lputs("; heap segments:", sys_errp);
while(i < hplim_ind) {
{
long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]);
lputs("\n; 0x", sys_errp);
scm_intprint((long)hplims[i++], -16, sys_errp);
lputs(" - 0x", sys_errp);
scm_intprint((long)hplims[i++], -16, sys_errp);
lputs("; ", sys_errp);
scm_intprint(seg_cells, 10, sys_errp);
lputs(" cells; ", sys_errp);
scm_intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp);
lputs(".kiB", sys_errp);
}}
}
sizet init_heap_seg(seg_org, size)
CELLPTR seg_org;
sizet size;
{
register CELLPTR ptr = seg_org;
#ifdef POINTERS_MUNGED
register SCM scmptr;
#else
# define scmptr ptr
#endif
CELLPTR seg_end = CELL_DN((char *)ptr + size);
sizet i = hplim_ind, ni = 0;
if (ptr==NULL) return 0;
while((ni < hplim_ind) && PTR_LE(hplims[ni], seg_org)) ni++;
while(i-- > ni) hplims[i+2] = hplims[i];
hplim_ind += 2;
hplims[ni++] = ptr; /* same as seg_org here */
hplims[ni++] = seg_end;
ptr = CELL_UP(ptr);
ni = seg_end - ptr;
/* printf("ni = %u; hplim_ind = %u\n", ni, hplim_ind); */
/* printf("ptr = %lx\n", ptr); */
for (i = ni;i--;ptr++) {
#ifdef POINTERS_MUNGED
scmptr = PTR2SCM(ptr);
#endif
CAR(scmptr) = (SCM)tc_free_cell;
CDR(scmptr) = PTR2SCM(ptr+1);
}
/* CDR(scmptr) = freelist; */
CDR(PTR2SCM(--ptr)) = freelist;
freelist = PTR2SCM(CELL_UP(seg_org));
heap_cells += ni;
return size;
#ifdef scmptr
# undef scmptr
#endif
}
static void alloc_some_heap()
{
CELLPTR ptr, *tmplims;
sizet len = (2+hplim_ind)*sizeof(CELLPTR);
ASRTGO(len==(2+hplim_ind)*sizeof(CELLPTR), badhplims);
if (errjmp_bad) wta(UNDEFINED, "need larger initial", s_heap);
tmplims = (CELLPTR *)must_realloc((char *)hplims,
len-2L*sizeof(CELLPTR), (long)len,
s_heap);
/* SYSCALL(tmplims = (CELLPTR *)realloc((char *)hplims, len);); */
if (!tmplims)
badhplims:
wta(UNDEFINED, s_nogrow, s_hplims);
else hplims = tmplims;
/* hplim_ind gets incremented in init_heap_seg() */
if (expmem) {
len = (sizet)(EXPHEAP(heap_cells)*sizeof(cell));
if ((sizet)(EXPHEAP(heap_cells)*sizeof(cell)) != len) len = 0;
}
else len = HEAP_SEG_SIZE;
while (len >= MIN_HEAP_SEG_SIZE) {
SYSCALL(ptr = (CELLPTR) malloc(len););
if (ptr) {
init_heap_seg(ptr, len);
return;
}
len /= 2;
}
wta(UNDEFINED, s_nogrow, s_heap);
}
/* Initialize a Growable arRAy, of initial size LEN, growing to at most
MAXLEN elements of size ELTSIZE */
void scm_init_gra(gra, eltsize, len, maxlen, what)
scm_gra *gra;
sizet eltsize, len, maxlen;
const char *what;
{
char *nelts;
/* DEFER_INTS; */
/* Can't call must_malloc, because heap may not be initialized yet. */
/* SYSCALL(nelts = malloc(len*eltsize););
if (!nelts) wta(MAKINUM(len*eltsize), (char *)NALLOC, what);
mallocated += len*eltsize;
*/
nelts = must_malloc((long)len*eltsize, what);
gra->eltsize = eltsize;
gra->len = 0;
gra->elts = nelts;
gra->alloclen = len;
gra->maxlen = maxlen;
gra->what = what;
/* ALLOW_INTS; */
}
/* Returns the index into the elt array */
int scm_grow_gra(gra, elt)
scm_gra *gra;
char *elt;
{
int i;
char *tmp;
if (gra->alloclen <= gra->len) {
sizet inc = gra->len / 5 + 1;
sizet nlen = gra->len + inc;
if (gra->maxlen && nlen > gra->maxlen)
/* growerr: */ wta(MAKINUM(nlen), (char *)NALLOC, gra->what);
/*
SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize););
if (!tmp) goto growerr;
mallocated += (nlen - gra->alloclen)*gra->eltsize;
*/
tmp = must_realloc(gra->elts, (long)gra->alloclen*gra->eltsize,
(long)nlen*gra->eltsize, gra->what);
gra->elts = tmp;
gra->alloclen = nlen;
}
tmp = &gra->elts[gra->len*gra->eltsize];
gra->len += 1;
for (i = 0; i < gra->eltsize; i++)
tmp[i] = elt[i];
return gra->len - 1;
}
void scm_trim_gra(gra)
scm_gra *gra;
{
char *tmp;
long curlen = gra->len;
if (0L==curlen) curlen = 1L;
if (curlen==(long)gra->alloclen) return;
tmp = must_realloc(gra->elts,
(long)gra->alloclen * gra->eltsize,
curlen * gra->eltsize,
gra->what);
gra->elts = tmp;
gra->alloclen = curlen;
}
void scm_free_gra(gra)
scm_gra *gra;
{
free(gra->elts);
gra->elts = 0;
mallocated -= gra->maxlen*gra->eltsize;
}
void gra_report1(gra)
scm_gra *gra;
{
scm_intprint((long)gra->len, -10, cur_errp);
lputs(" (of ", cur_errp);
scm_intprint((long)gra->alloclen, -10, cur_errp);
lputs(") ", cur_errp);
lputs(gra->what, cur_errp);
lputs("; ", cur_errp);
}
void gra_report()
{
lputs(";; gra: ", cur_errp);
gra_report1(&ptobs_gra);
gra_report1(&smobs_gra);
gra_report1(&finals_gra);
gra_report1(&subrs_gra);
lputs("\n", cur_errp);
}
scm_gra smobs_gra;
long newsmob(smob)
smobfuns *smob;
{
return tc7_smob + 256*scm_grow_gra(&smobs_gra, (char *)smob);
}
scm_gra ptobs_gra;
long newptob(ptob)
ptobfuns *ptob;
{
return tc7_port + 256*scm_grow_gra(&ptobs_gra, (char *)ptob);
}
port_info *scm_port_table = 0;
static sizet scm_port_table_len = 0;
static char s_port_table[] = "port table";
SCM scm_port_entry(stream, ptype, flags)
FILE *stream;
long ptype, flags;
{
SCM z;
sizet nlen;
int i, j;
VERIFY_INTS("scm_port_entry", 0L);
flags = flags | (ptype & ~0xffffL);
ASRTER(flags, INUM0, ARG1, "scm_port_entry");
for (i = 1; i < scm_port_table_len; i++)
if (0L==scm_port_table[i].flags) goto ret;
if (scm_port_table_len <= SCM_PORTNUM_MAX) {
nlen = scm_port_table_len + (scm_port_table_len / 2);
if (nlen >= SCM_PORTNUM_MAX) nlen = (sizet)SCM_PORTNUM_MAX + 1;
scm_port_table = (port_info *)
must_realloc((char *)scm_port_table,
(long)scm_port_table_len * sizeof(port_info),
(long)nlen * sizeof(port_info),
s_port_table);
scm_port_table_len = nlen;
growth_mon(s_port_table, nlen + 0L, "entries", !0);
for (j = i; j < scm_port_table_len; j++) {
scm_port_table[j].flags = 0L;
scm_port_table[j].data = UNDEFINED;
scm_port_table[j].port = UNDEFINED;
}
}
else {
igc(s_port_table, rootcont);
for (i = 0; i < scm_port_table_len; i++)
if (0L==scm_port_table[i].flags) goto ret;
wta(UNDEFINED, s_nogrow, s_port_table);
}
ret:
NEWCELL(z);
SETSTREAM(z, stream);
CAR(z) = (((long)i)<<20) | (flags & 0x0f0000) | ptype;
scm_port_table[i].unread = EOF;
scm_port_table[i].flags = flags;
scm_port_table[i].line = 1L; /* should both be one-based? */
scm_port_table[i].col = 1;
scm_port_table[i].data = UNSPECIFIED;
scm_port_table[i].port = z;
return z;
}
SCM scm_open_ports()
{
SCM p, res = EOL;
int k;
for (k = scm_port_table_len - 1; k > 0; k--) {
p = scm_port_table[k].port;
if (NIMP(p) && OPPORTP(p))
res = cons(p, res);
}
return res;
}
SCM markcdr(ptr)
SCM ptr;
{
return CDR(ptr);
}
sizet free0(ptr)
CELLPTR ptr;
{
return 0;
}
SCM equal0(ptr1, ptr2)
SCM ptr1, ptr2;
{
return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F;
}
static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ",
rdmsg[] = "reduce";
void init_storage(stack_start_ptr, init_heap_size)
STACKITEM *stack_start_ptr;
long init_heap_size;
{
sizet j;
/* Because not all protects may get initialized */
freelist = EOL;
expmem = 0;
estk_pool = EOL;
scm_estk = BOOL_F;
scm_port_table = 0;
scm_port_table_len = 0;
#ifdef SHORT_SIZET
if (sizeof(sizet) >= sizeof(long))
fixconfig(remsg, "SHORT_SIZET", 0);
#else
if (sizeof(sizet) < sizeof(long))
fixconfig(addmsg, "SHORT_SIZET", 0);
#endif
#ifdef SHORT_INT
if (sizeof(int) >= sizeof(long))
fixconfig(remsg, "SHORT_INT", 0);
#else
if (sizeof(int) < sizeof(long))
fixconfig(addmsg, "SHORT_INT", 0);
#endif
#ifdef CDR_DOUBLES
if (sizeof(double) != sizeof(long))
fixconfig(remsg, "CDR_DOUBLES", 0);
#else
# ifdef SINGLES
if (sizeof(float) != sizeof(long)) {
if (sizeof(double) == sizeof(long))
fixconfig(addmsg, "CDR_DOUBLES", 0);
else
fixconfig(remsg, "SINGLES", 0);
}
# endif
#endif
#ifdef BIGDIG
if (2*BITSPERDIG/CHAR_BIT > sizeof(long))
fixconfig(remsg, "BIGDIG", 0);
# ifndef DIGSTOOBIG
if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long))
fixconfig(addmsg, "DIGSTOOBIG", 0);
# endif
if (NUMDIGS_MAX > (((unsigned long)-1L)>>16))
fixconfig(rdmsg, "NUMDIGS_MAX", 0);
#endif
#ifdef STACK_GROWS_UP
if (((STACKITEM *)&j - stack_start_ptr) < 0)
fixconfig(remsg, "STACK_GROWS_UP", 1);
#else
if ((stack_start_ptr - (STACKITEM *)&j) < 0)
fixconfig(addmsg, "STACK_GROWS_UP", 1);
#endif
j = HEAP_SEG_SIZE;
if (HEAP_SEG_SIZE != j)
fixconfig(rdmsg, "size of HEAP_SEG_SIZE", 0);
mtrigger = INIT_MALLOC_LIMIT;
mltrigger = mtrigger - MIN_MALLOC_YIELD;
hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims);
if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE;
j = init_heap_size;
/* printf("j = %u; init_heap_size = %lu\n", j, init_heap_size); */
if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) {
j = HEAP_SEG_SIZE;
/* printf("j = %u; HEAP_SEG_SIZE = %lu\n", j, HEAP_SEG_SIZE); */
if (!init_heap_seg((CELLPTR) malloc(j), j))
wta(MAKINUM(j), (char *)NALLOC, s_heap);
}
else expmem = 1;
heap_org = CELL_UP(hplims[0]);
/* hplims[0] can change. do not remove heap_org */
scm_port_table_len = 16;
scm_port_table = (port_info *)
must_malloc((long)scm_port_table_len * sizeof(port_info), s_port_table);
for (j = 0; j < scm_port_table_len; j++) {
scm_port_table[j].flags = 0L;
scm_port_table[j].data = UNDEFINED;
scm_port_table[j].port = UNDEFINED;
}
nullstr = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_string), s_string);
CHARS(nullstr)[0] = 0;
nullvect = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_vector), s_vector);
{
long i = symhash_dim;
SCM *velts;
symhash = must_malloc_cell(i * sizeof(SCM),
MAKE_LENGTH(i, tc7_vector),
s_vector);
velts = VELTS(symhash);
while(--i >= 0) (velts)[i] = EOL;
}
/* Now that symhash is setup, we can sysintern() */
sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM));
sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM));
#ifdef BIGDIG
sysintern("bignum-radix", MAKINUM(BIGRAD));
#endif
def_inp = scm_port_entry(stdin, tc16_fport, OPN|RDNG);
SCM_PORTDATA(def_inp) = CAR(sysintern("stdin", UNDEFINED));
def_outp = scm_port_entry(stdout, tc16_fport, OPN|WRTNG|TRACKED);
SCM_PORTDATA(def_outp) = CAR(sysintern("stdout", UNDEFINED));
NEWCELL(def_errp);
CAR(def_errp) = (tc16_fport|OPN|WRTNG);
SETSTREAM(def_errp, stderr);
cur_inp = def_inp;
cur_outp = def_outp;
cur_errp = def_errp;
NEWCELL(sys_errp);
CAR(sys_errp) = (tc16_sysport|OPN|WRTNG);
SETSTREAM(sys_errp, 0);
sys_safep = mksafeport(0, def_errp);
dynwinds = EOL;
NEWCELL(rootcont);
SETCONT(rootcont, make_root_continuation(stack_start_ptr));
CAR(rootcont) = tc7_contin;
CONT(rootcont)->other.dynenv = EOL;
CONT(rootcont)->other.parent = BOOL_F;
listofnull = cons(EOL, EOL);
undefineds = cons(UNDEFINED, EOL);
CDR(undefineds) = undefineds;
/* flo0 is now setup in scl.c */
/* Set up environment cache */
scm_ecache_len = sizeof(ecache_v)/sizeof(cell);
scm_ecache = CELL_UP(ecache_v);
scm_ecache_len = CELL_DN(ecache_v + scm_ecache_len - 1) - scm_ecache + 1;
scm_ecache_index = scm_ecache_len;
scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
scm_estk = BOOL_F;
scm_estk_reset(0);
}
/* The way of garbage collecting which allows use of the cstack is due to */
/* Scheme In One Defun, but in C this time.
* 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
Paradigm Associates Inc Phone: 617-492-6079
29 Putnam Ave, Suite 6
Cambridge, MA 02138
*/
char s_cells[] = "cells";
SCM gc_for_newcell()
{
SCM fl;
int oints = ints_disabled; /* Temporary expedient */
if (!oints) ints_disabled = 1;
igc(s_cells, rootcont);
if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
alloc_some_heap();
growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
growth_mon(s_heap, heap_cells, s_cells, !0);
}
++cells_allocated;
fl = freelist;
freelist = CDR(fl);
ints_disabled = oints;
return fl;
}
void gc_for_open_files()
{
igc("open files", rootcont);
}
void scm_fill_freelist()
{
while IMP(freelist) {
igc(s_cells, rootcont);
if ((gc_cells_collected < MIN_GC_YIELD) || IMP(freelist)) {
alloc_some_heap();
growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, !0);
growth_mon(s_heap, heap_cells, s_cells, !0);
}
}
}
static char s_bad_type[] = "unknown type in ";
void mark_locations P((STACKITEM x[], sizet n));
static void mark_syms P((SCM v));
static void mark_sym_values P((SCM v));
static void mark_subrs P((void));
static void sweep_symhash P((SCM v));
static void mark_finalizers P((SCM *live, SCM *dead));
static void mark_port_table P((SCM port));
static void sweep_port_table P((void));
static void egc_mark P((void));
static void egc_sweep P((void));
SCM gc(arg)
SCM arg;
{
DEFER_INTS;
if (UNBNDP(arg))
igc("call", rootcont);
else
scm_egc();
ALLOW_INTS;
return UNSPECIFIED;
}
void scm_run_finalizers(exiting)
int exiting;
{
SCM f;
if (exiting) { /* run all finalizers, we're going home. */
DEFER_INTS;
while NIMP(gc_finalizers) {
f = CAR(gc_finalizers);
CAR(f) = CDR(f);
CDR(f) = gc_finalizers_pending;
gc_finalizers_pending = f;
gc_finalizers = CDR(gc_finalizers);
}
ALLOW_INTS;
}
while (!0) {
DEFER_INTS;
if (NIMP(gc_finalizers_pending)) {
f = CAR(gc_finalizers_pending);
gc_finalizers_pending = CDR(gc_finalizers_pending);
}
else f = BOOL_F;
ALLOW_INTS;
if (IMP(f)) break;
apply(f, EOL, EOL);
}
}
static SCM *loc_gc_hook = 0;
void scm_gc_hook ()
{
if (gc_hook_active) {
scm_warn("gc-hook thrashing?\n", "", UNDEFINED);
return;
}
gc_hook_active = !0;
if (! loc_gc_hook) loc_gc_hook = &CDR(sysintern("gc-hook", UNDEFINED));
if (NIMP(*loc_gc_hook)) apply(*loc_gc_hook, EOL, EOL);
scm_run_finalizers(0);
gc_hook_active = 0;
}
void igc(what, basecont)
const char *what;
SCM basecont;
{
int j = num_protects;
long oheap_cells = heap_cells;
STACKITEM * stackbase = IMP(basecont) ? 0 : CONT(basecont)->stkbse;
#ifdef DEBUG_GMALLOC
int err = check_frag_blocks();
if (err) wta(MAKINUM(err), "malloc corrupted", what);
#endif
gc_start(what);
if (errjmp_bad) wta(UNDEFINED, s_recursive, s_gc);
errjmp_bad = s_gc;
#ifdef NO_SYM_GC
gc_mark(symhash);
#else
/* By marking symhash first, we provide the best immunity from
accidental references. In order to accidentally protect a
symbol, a pointer will have to point directly at the symbol (as
opposed to the vector or bucket lists). */
mark_syms(symhash);
/* mark_sym_values() can be called anytime after mark_syms. */
mark_sym_values(symhash);
#endif
mark_subrs();
egc_mark();
if (stackbase) {
#ifdef __ia64__
mark_regs_ia64(CONT(basecont));
#else
jump_buf save_regs_gc_mark;
FLUSH_REGISTER_WINDOWS;
/* This assumes that all registers are saved into the jump_buf */
setjump(save_regs_gc_mark);
mark_locations((STACKITEM *) save_regs_gc_mark,
(sizet) (sizeof(STACKITEM) - 1 + sizeof save_regs_gc_mark) /
sizeof(STACKITEM));
{
/* stack_len is long rather than sizet in order to guarantee that
&stack_len is long aligned */
# ifdef STACK_GROWS_UP
# ifdef nosve
long stack_len = (STACKITEM *)(&stack_len) - stackbase;
# else
long stack_len = stack_size(stackbase);
# endif
mark_locations(stackbase, (sizet)stack_len);
# else
# ifdef nosve
long stack_len = stackbase - (STACKITEM *)(&stack_len);
# else
long stack_len = stack_size(stackbase);
# endif
mark_locations((stackbase - stack_len), (sizet)stack_len);
# endif
}
#endif
}
while(j--)
gc_mark(sys_protects[j]);
mark_finalizers(&gc_finalizers, &gc_finalizers_pending);
#ifndef NO_SYM_GC
sweep_symhash(symhash);
#endif
gc_sweep(!stackbase);
sweep_port_table();
egc_sweep();
estk_pool = EOL;
errjmp_bad = (char *)0;
gc_end();
if (oheap_cells != heap_cells) {
int grewp = heap_cells > oheap_cells;
growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp);
growth_mon(s_heap, heap_cells, s_cells, grewp);
}
gc_hook_pending = !0;
deferred_proc = process_signals;
}
static char s_not_free[] = "not freed";
void free_storage()
{
DEFER_INTS;
loc_gc_hook = (SCM *)0;
gc_start("free");
errjmp_bad = "free_storage";
cur_inp = BOOL_F; cur_outp = BOOL_F;
cur_errp = tmp_errp; sys_errp = tmp_errp;
gc_mark(def_inp); /* don't want to close stdin */
gc_mark(def_outp); /* don't want to close stdout */
gc_mark(def_errp); /* don't want to close stderr */
gc_sweep(0);
rootcont = BOOL_F;
while (hplim_ind) { /* free heap segments */
hplim_ind -= 2;
{
CELLPTR ptr = CELL_UP(hplims[hplim_ind]);
sizet seg_cells = CELL_DN(hplims[hplim_ind+1]) - ptr;
heap_cells -= seg_cells;
free((char *)hplims[hplim_ind]);
hplims[hplim_ind] = 0;
growth_mon(s_heap, heap_cells, s_cells, 0); fflush(stderr);
}}
if (heap_cells) wta(MAKINUM(heap_cells), s_not_free, s_heap);
if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims);
/* Not all cells get freed (see gc_mark() calls above). */
/* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */
/* either there is a small memory leak or I am counting wrong. */
must_free((char *)hplims, 0);
/* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */
hplims = 0;
scm_free_gra(&finals_gra);
scm_free_gra(&smobs_gra);
scm_free_gra(&subrs_gra);
gc_end();
ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
exit_report();
lfflush(sys_errp);
scm_free_gra(&ptobs_gra);
lmallocated = mallocated = 0;
/* Can't do gc_end() here because it uses ptobs which have been freed */
fflush(stdout); /* in lieu of close */
fflush(stderr); /* in lieu of close */
}
#define HUGE_LENGTH(x) (LENGTH_MAX==LENGTH(x) ? *((long *)VELTS(x)) : LENGTH(x))
/* This is used to force allocation of SCM temporaries on the stack,
it should be called with any SCM variables used for malloc headers
and entirely local to a C procedure. */
void scm_protect_temp(ptr)
SCM *ptr;
{
return;
}
static char s_gc_sym[] = "mark_syms", s_wrong_length[] = "wrong length";
void gc_mark(p)
SCM p;
{
register long i;
register SCM ptr = p;
CHECK_STACK;
gc_mark_loop:
if (IMP(ptr)) return;
gc_mark_nimp:
if (NCELLP(ptr)
/* #ifndef RECKLESS */
/* || PTR_GT(hplims[0], (CELLPTR)ptr) */
/* || PTR_GE((CELLPTR)ptr, hplims[hplim_ind-1]) */
/* #endif */
) wta(ptr, "rogue pointer in ", s_heap);
switch TYP7(ptr) {
case tcs_cons_nimcar:
if (GCMARKP(ptr)) break;
SETGCMARK(ptr);
if (IMP(CDR(ptr))) { /* IMP works even with a GC mark */
ptr = CAR(ptr);
goto gc_mark_nimp;
}
gc_mark(CAR(ptr));
ptr = GCCDR(ptr);
goto gc_mark_nimp;
case tcs_cons_imcar:
case tcs_cons_gloc:
if (GCMARKP(ptr)) break;
SETGCMARK(ptr);
ptr = GCCDR(ptr);
goto gc_mark_loop;
case tcs_closures:
if (GCMARKP(ptr)) break;
SETGCMARK(ptr);
if (IMP(GCENV(ptr))) {
ptr = CODE(ptr);
goto gc_mark_nimp;
}
gc_mark(CODE(ptr));
ptr = GCENV(ptr);
goto gc_mark_nimp;
case tc7_specfun:
if (GC8MARKP(ptr)) break;
SETGC8MARK(ptr);
#ifdef CCLO
if (tc16_cclo==GCTYP16(ptr)) {
i = CCLO_LENGTH(ptr);
if (i==0) break;
while(--i>0) if (NIMP(VELTS(ptr)[i])) gc_mark(VELTS(ptr)[i]);
ptr = VELTS(ptr)[0];
}
else
#endif
ptr = CDR(ptr);
goto gc_mark_loop;
case tc7_vector:
if (GC8MARKP(ptr)) break;
SETGC8MARK(ptr);
i = LENGTH(ptr);
if (i==0) break;
while(--i>0) if (NIMP(VELTS(ptr)[i])) gc_mark(VELTS(ptr)[i]);
ptr = VELTS(ptr)[0];
goto gc_mark_loop;
case tc7_contin:
if (GC8MARKP(ptr)) break;
SETGC8MARK(ptr);
mark_locations((STACKITEM *)VELTS(ptr),
(sizet)(LENGTH(ptr) +
(sizeof(STACKITEM) - 1 + sizeof(CONTINUATION)) /
sizeof(STACKITEM)));
break;
case tc7_string:
case tc7_msymbol:
if (GC8MARKP(ptr)) break;
ASRTER(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)),
s_wrong_length, s_gc);
case tc7_ssymbol:
case tc7_Vbool:
case tc7_VfixZ32: case tc7_VfixN32:
case tc7_VfixZ16: case tc7_VfixN16:
case tc7_VfixN8: case tc7_VfixZ8:
case tc7_VfloR32: case tc7_VfloC32:
case tc7_VfloR64: case tc7_VfloC64:
SETGC8MARK(ptr);
case tcs_subrs:
break;
case tc7_port:
if (GC8MARKP(ptr)) break;
SETGC8MARK(ptr);
i = PTOBNUM(ptr);
if (!(i < numptob)) goto def;
mark_port_table(ptr);
if (!ptobs[i].mark) break;
ptr = (ptobs[i].mark)(ptr);
goto gc_mark_loop;
case tc7_smob:
if (GC8MARKP(ptr)) break;
SETGC8MARK(ptr);
switch TYP16(ptr) { /* should be faster than going through smobs */
case tc_free_cell:
/* printf("found free_cell %X ", ptr); fflush(stdout); */
ASRTER(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc);
/* CDR(ptr) = UNDEFINED */;
break;
#ifdef BIGDIG
case tcs_bignums:
break;
#endif
#ifdef FLOATS
case tc16_flo:
break;
#endif
default:
i = SMOBNUM(ptr);
if (!(i < numsmob)) goto def;
SETGC8MARK(ptr);
if (!smobs[i].mark) break;
ptr = (smobs[i].mark)(ptr);
goto gc_mark_loop;
}
break;
default: def: wta(ptr, s_bad_type, "gc_mark");
}
}
/* mark_locations() marks a location pointed to by x[0:n] only if
`x[m]' is cell-aligned and points into a valid heap segment. This
code is duplicated by obunhash() in "sys.c" and scm_cell_p() in
"rope.c", which means that changes to these routines must be
coordinated. */
void mark_locations(x, n)
STACKITEM x[];
sizet n;
{
register long m = n;
register int i, j;
register CELLPTR ptr;
while(0 <= --m) if (CELLP(*(SCM **)&x[m])) {
ptr = (CELLPTR)SCM2PTR((SCM)(*(SCM **)&x[m]));
i = 0;
j = hplim_ind;
do {
if (PTR_GT(hplims[i++], ptr)) break;
if (PTR_LE(hplims[--j], ptr)) break;
if ((i != j)
&& PTR_LE(hplims[i++], ptr)
&& PTR_GT(hplims[--j], ptr)) continue;
/* if (NFREEP(*(SCM **)&x[m])) */ gc_mark(*(SCM *)&x[m]);
break;
} while(ilength)
scm_warn("uncollected ", "", scmptr);
goto c8mrkcontinue;
}
minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
mallocated = mallocated - minc;
free_continuation(CONT(scmptr)); break; /* goto freechars; */
case tc7_ssymbol:
if (GC8MARKP(scmptr)) goto c8mrkcontinue;
/* Do not free storage because tc7_ssymbol means scmptr's
storage was not created by a call to malloc(). */
break;
case tcs_subrs:
continue;
case tc7_port:
if (GC8MARKP(scmptr)) goto c8mrkcontinue;
if (OPENP(scmptr)) {
int k = PTOBNUM(scmptr);
if (!(k < numptob)) goto sweeperr;
/* Yes, I really do mean ptobs[k].free */
/* rather than ptobs[k].close. .close */
/* is for explicit CLOSE-PORT by user */
(ptobs[k].free)(STREAM(scmptr));
gc_ports_collected++;
SETSTREAM(scmptr, 0);
CAR(scmptr) &= ~OPN;
}
break;
case tc7_smob:
switch GCTYP16(scmptr) {
case tc_free_cell:
if (GC8MARKP(scmptr)) goto c8mrkcontinue;
break;
#ifdef BIGDIG
case tcs_bignums:
if (GC8MARKP(scmptr)) goto c8mrkcontinue;
minc = (NUMDIGS(scmptr)*sizeof(BIGDIG));
goto freechars;
#endif /* def BIGDIG */
#ifdef FLOATS
case tc16_flo:
if (GC8MARKP(scmptr)) goto c8mrkcontinue;
switch ((int)(CAR(scmptr)>>16)) {
case (IMAG_PART | REAL_PART)>>16:
minc = 2*sizeof(double);
goto freechars;
case REAL_PART>>16:
case IMAG_PART>>16:
minc = sizeof(double);
goto freechars;
case 0:
break;
default:
goto sweeperr;
}
break;
#endif /* def FLOATS */
default:
if (GC8MARKP(scmptr)) goto c8mrkcontinue;
{
int k = SMOBNUM(scmptr);
if (!(k < numsmob)) goto sweeperr;
minc = (smobs[k].free)((CELLPTR)scmptr);
}
}
break;
default: sweeperr: wta(scmptr, s_bad_type, "gc_sweep");
}
++n;
CAR(scmptr) = (SCM)tc_free_cell;
CDR(scmptr) = nfreelist;
nfreelist = scmptr;
continue;
c8mrkcontinue:
CLRGC8MARK(scmptr);
continue;
cmrkcontinue:
CLRGCMARK(scmptr);
}
#ifdef GC_FREE_SEGMENTS
if (n==seg_cells) {
heap_cells -= seg_cells;
n = 0;
free((char *)hplims[i-2]);
/* must_free((char *)hplims[i-2],
sizeof(cell) * (hplims[i-1] - hplims[i-2])); */
hplims[i-2] = 0;
for (j = i;j < hplim_ind;j++) hplims[j-2] = hplims[j];
hplim_ind -= 2;
i -= 2; /* need to scan segment just moved. */
nfreelist = freelist;
}
else
#endif /* ifdef GC_FREE_SEGMENTS */
freelist = nfreelist;
gc_cells_collected += n;
n = 0;
}
lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated);
cells_allocated = (heap_cells - gc_cells_collected);
gc_malloc_collected = (pre_m - mallocated);
lmallocated = lmallocated - gc_malloc_collected;
}
#ifndef NO_SYM_GC
/* mark_syms marks those symbols of hash table V which have
non-UNDEFINED values. */
static void mark_syms(v)
SCM v;
{
SCM x, al;
int k = LENGTH(v);
while (k--)
for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
/* If this bucket has already been marked, then something is wrong. */
ASRTER(!GCMARKP(al), al, s_bad_type, s_gc_sym);
x = CAR(al);
SETGCMARK(al); /* Do mark bucket list */
# ifdef CAREFUL_INTS
ASRTER(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym);
ASRTER(!GC8MARKP(CAR(x)) && !(CHARS(CAR(x))[LENGTH(CAR(x))]),
CAR(x), s_wrong_length, s_gc_sym);
ASRTER(strhash(UCHARS(CAR(x)), (sizet)LENGTH(CAR(x)),
(unsigned long)symhash_dim)==k,
CAR(x), "bad hash", s_gc_sym);
# endif
if (UNDEFINED==CDR(x) && tc7_msymbol==TYP7(CAR(x)))
goto used; /* Don't mark symbol. */
SETGC8MARK(CAR(x));
used:
/* SETGCMARK(x) */; /* Don't mark value cell. */
/* We used to mark the value cell, but value cells get returned
by calls to intern(). This caused a rare GC leak which only
showed up in large programs. */
}
SETGC8MARK(v); /* Mark bucket vector. */
}
/* mark_symhash marks the values of hash table V. */
static void mark_sym_values(v)
SCM v;
{
SCM x, al;
int k = LENGTH(v);
/* SETGC8MARK(v); */ /* already set by mark_syms */
while (k--)
for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) {
x = GCCDR(CAR(al));
if (IMP(x)) continue;
gc_mark(x);
}
}
/* Splice any unused valueless symbols out of the hash buckets. */
static void sweep_symhash(v)
SCM v;
{
SCM al, x, *lloc;
int k = LENGTH(v);
while (k--) {
lloc = &(VELTS(v)[k]);
while NIMP(al = (*lloc & ~1L)) {
x = CAR(al);
if (GC8MARKP(CAR(x))) {
lloc = &(CDR(al));
SETGCMARK(x);
}
else {
*lloc = CDR(al);
CLRGCMARK(al); /* bucket pair to be collected by gc_sweep */
CLRGCMARK(x); /* value cell to be collected by gc_sweep */
gc_syms_collected++;
}
}
VELTS(v)[k] &= ~1L; /* We may have deleted the first cell */
}
}
#endif
/* This function should be called after all other marking is done. */
static void mark_finalizers(finalizers, pending)
SCM *finalizers, *pending;
{
SCM lst, elt, v;
SCM live = EOL, undead = *finalizers;
int more_to_do = !0;
gc_mark(*pending);
while NIMP(*pending) pending = &CDR(*pending);
while (more_to_do) {
more_to_do = 0;
lst = undead;
undead = EOL;
while (NIMP(lst)) {
elt = CAR(lst);
v = CAR(elt);
switch (TYP3(v)) {
default:
if (GCMARKP(v)) goto marked;
goto unmarked;
case tc3_tc7_types:
if (GC8MARKP(v)) {
marked:
gc_mark(CDR(elt));
more_to_do = !0;
v = lst;
lst = CDR(lst);
CDR(v) = live;
live = v;
}
else {
unmarked:
v = lst;
lst = CDR(lst);
CDR(v) = undead;
undead = v;
}
break;
}
}
}
gc_mark(live);
for (lst = undead; NIMP(lst); lst = CDR(lst))
CAR(lst) = CDR(CAR(lst));
gc_mark(undead);
*finalizers = live;
*pending = undead;
}
static void mark_subrs()
{
/* subr_info *table = subrs; */
/* int k = subrs_gra.len; */
/* while (k--) { } */
}
static void mark_port_table(port)
SCM port;
{
int i = SCM_PORTNUM(port);
ASRTER(i>=0 && i 0; k--) {
if (scm_port_table[k].flags & 1)
scm_port_table[k].flags &= (~1L);
else {
scm_port_table[k].flags = 0L;
scm_port_table[k].data = UNDEFINED;
scm_port_table[k].port = UNDEFINED;
}
}
}
/* Environment cache GC routines */
/* This is called during a non-cache gc. We only mark those stack frames
that are in use. */
static void egc_mark()
{
SCM *v;
int i;
gc_mark(scm_env);
gc_mark(scm_env_tmp);
if (IMP(scm_estk)) return; /* Can happen when moving estk. */
if (GC8MARKP(scm_estk)) return;
v = VELTS(scm_estk);
SETGC8MARK(scm_estk);
i = scm_estk_ptr - v + SCM_ESTK_FRLEN;
while(--i >= 0)
if (NIMP(v[i]))
gc_mark(v[i]);
}
static void egc_sweep()
{
SCM z;
int i;
for (i = scm_ecache_index; i < scm_ecache_len; i++) {
z = PTR2SCM(&(scm_ecache[i]));
if (CONSP(z)) {
CLRGCMARK(z);
}
else {
CLRGC8MARK(z);
}
}
/* Under some circumstances I don't fully understand, continuations may
point to dead ecache cells. This prevents gc marked cells from causing
errors during ecache gc. */
for (i = scm_ecache_index; i--;) {
scm_ecache[i].car = UNSPECIFIED;
scm_ecache[i].cdr = UNSPECIFIED;
}
}
#define ECACHEP(x) (PTR_LE((CELLPTR)(ecache_v), (CELLPTR)SCM2PTR(x)) && \
PTR_GT((CELLPTR)(ecache_v) + ECACHE_SIZE, (CELLPTR)SCM2PTR(x)))
static void egc_copy(px)
SCM *px;
{
SCM z, x = *px;
do {
if (tc_broken_heart==CAR(x)) {
*px = CDR(x);
return;
}
if (IMP(freelist)) wta(freelist, "empty freelist", "ecache gc");
z = freelist;
freelist = CDR(freelist);
++cells_allocated;
CAR(z) = CAR(x);
CDR(z) = CDR(x);
CAR(x) = (SCM)tc_broken_heart;
CDR(x) = z;
*px = z;
x = CAR(z);
if (NIMP(x) && ECACHEP(x))
egc_copy(&(CAR(z)));
px = &(CDR(z));
x = *px;
} while (NIMP(x) && ECACHEP(x));
}
static void egc_copy_locations(ve, len)
SCM *ve;
sizet len;
{
SCM x;
while (len--) {
x = ve[len];
if (NIMP(x) && ECACHEP(x)) {
if (tc_broken_heart==CAR(x))
ve[len] = CDR(x);
else
egc_copy(&(ve[len]));
}
}
}
static void egc_copy_stack(stk, len)
SCM stk;
sizet len;
{
while (!0) {
egc_copy_locations(VELTS(stk), len);
len = INUM(SCM_ESTK_PARENT_INDEX(stk)) + SCM_ESTK_FRLEN;
stk =SCM_ESTK_PARENT(stk);
if (IMP(stk)) return;
/* len = LENGTH(stk); */
}
}
extern long tc16_env, tc16_promise;
static void egc_copy_roots()
{
SCM *roots = &(scm_egc_roots[scm_egc_root_index]);
SCM e, x;
int len = sizeof(scm_egc_roots)/sizeof(SCM) - scm_egc_root_index ;
if (!(len>=0 && len <= sizeof(scm_egc_roots)/sizeof(SCM)))
wta(MAKINUM(scm_egc_root_index), "egc-root-index", "corrupted");
while (len--) {
x = roots[len];
if (IMP(x)) continue;
switch TYP3(x) {
clo:
case tc3_closure:
e = ENV(x);
if (NIMP(e) && ECACHEP(e)) {
egc_copy(&e);
CDR(x) = (6L & CDR(x)) | e;
}
break;
case tc3_cons_imcar:
case tc3_cons_nimcar: /* These are environment frames that have
been destructively altered by DEFINE or
LETREC. This is only a problem if a
non-cache cell was made to point into the
cache. */
if (ECACHEP(x)) break;
e = CAR(x);
if (NIMP(e) && ECACHEP(e))
egc_copy(&(CAR(x)));
break;
default:
if (tc7_contin==TYP7(x)) {
egc_copy_locations(CONT(x)->other.stkframe, 2);
#ifndef CHEAP_CONTINUATIONS
x = CONT(x)->other.estk;
egc_copy_stack(x, LENGTH(x));
#endif
break;
}
if (tc16_env==CAR(x)) {
e = CDR(x);
if (NIMP(e) && ECACHEP(e))
egc_copy(&(CDR(x)));
break;
}
if (tc16_promise==CAR(x)) {
x = CDR(x);
goto clo;
}
}
}
scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
}
extern long scm_stk_moved, scm_clo_moved, scm_env_work;
static int egc_need_gc()
{
SCM fl = freelist;
int n;
if (heap_cells - cells_allocated <= scm_ecache_len)
return 1;
/* Interrupting a NEWCELL could leave cells_allocated inconsistent with
freelist, see handle_it() in repl.c */
for (n = 4; n; n--) {
if (IMP(fl)) return 1;
fl = CDR(fl);
}
return 0;
}
void scm_egc()
{
VERIFY_INTS("scm_egc", 0L);
/* We need to make sure there are enough cells available to migrate
the entire environment cache, gc does not work properly during ecache gc */
while (egc_need_gc()) {
igc("ecache", rootcont);
if ((gc_cells_collected < MIN_GC_YIELD) ||
(heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
alloc_some_heap();
growth_mon("number of heaps", (long)(hplim_ind/2), "segments", !0);
growth_mon(s_heap, heap_cells, s_cells, !0);
}
}
if (errjmp_bad)
wta(UNDEFINED, s_recursive, s_cache_gc);
{
SCM stkframe[2];
long lcells = cells_allocated;
sizet nstk = (scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN);
ASRTER(nstk<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", s_cache_gc);
scm_egc_start();
stkframe[0] = scm_env;
stkframe[1] = scm_env_tmp;
egc_copy_roots();
scm_clo_moved += cells_allocated - lcells;
lcells = cells_allocated;
egc_copy_locations(stkframe, sizeof(stkframe)/sizeof(SCM));
egc_copy_stack(scm_estk, nstk);
scm_env = stkframe[0];
scm_env_tmp = stkframe[1];
scm_stk_moved += cells_allocated - lcells;
scm_ecache_index = scm_ecache_len;
scm_env_work += scm_ecache_len;
scm_egc_end();
}
errjmp_bad = (char *)0;
}
scm-5e5/dynl.c 0000644 0017052 0001750 00000042711 10750224323 011147 0 ustar tb tb /* "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 (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), 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-5e5/example.scm 0000644 0017052 0001750 00000006614 06467700740 012212 0 ustar tb tb ;From Revised^4 Report on the Algorithmic Language Scheme
;William Clinger and Jonathon Rees (Editors)
; EXAMPLE
;INTEGRATE-SYSTEM integrates the system
; y_k' = f_k(y_1, y_2, ..., y_n), k = 1, ..., n
;of differential equations with the method of Runge-Kutta.
;The parameter SYSTEM-DERIVATIVE is a function that takes a system
;state (a vector of values for the state variables y_1, ..., y_n) and
;produces a system derivative (the values y_1', ..., y_n'). The
;parameter INITIAL-STATE provides an initial system state, and H is an
;initial guess for the length of the integration step.
;The value returned by INTEGRATE-SYSTEM is an infinite stream of
;system states.
(define integrate-system
(lambda (system-derivative initial-state h)
(let ((next (runge-kutta-4 system-derivative h)))
(letrec ((states
(cons initial-state
(delay (map-streams next states)))))
states))))
;RUNGE-KUTTA-4 takes a function, F, that produces a
;system derivative from a system state. RUNGE-KUTTA-4
;produces a function that takes a system state and
;produces a new system state.
(define runge-kutta-4
(lambda (f h)
(let ((*h (scale-vector h))
(*2 (scale-vector 2))
(*1/2 (scale-vector (/ 1 2)))
(*1/6 (scale-vector (/ 1 6))))
(lambda (y)
;; Y is a system state
(let* ((k0 (*h (f y)))
(k1 (*h (f (add-vectors y (*1/2 k0)))))
(k2 (*h (f (add-vectors y (*1/2 k1)))))
(k3 (*h (f (add-vectors y k2)))))
(add-vectors y
(*1/6 (add-vectors k0
(*2 k1)
(*2 k2)
k3))))))))
(define elementwise
(lambda (f)
(lambda vectors
(generate-vector
(vector-length (car vectors))
(lambda (i)
(apply f
(map (lambda (v) (vector-ref v i))
vectors)))))))
(define generate-vector
(lambda (size proc)
(let ((ans (make-vector size)))
(letrec ((loop
(lambda (i)
(cond ((= i size) ans)
(else
(vector-set! ans i (proc i))
(loop (+ i 1)))))))
(loop 0)))))
(define add-vectors (elementwise +))
(define scale-vector
(lambda (s)
(elementwise (lambda (x) (* x s)))))
;MAP-STREAMS is analogous to MAP: it applies its first
;argument (a procedure) to all the elements of its second argument (a
;stream).
(define map-streams
(lambda (f s)
(cons (f (head s))
(delay (map-streams f (tail s))))))
;Infinite streams are implemented as pairs whose car holds the first
;element of the stream and whose cdr holds a promise to deliver the rest
;of the stream.
(define head car)
(define tail
(lambda (stream) (force (cdr stream))))
;The following illustrates the use of INTEGRATE-SYSTEM in
;integrating the system
;
; dvC vC
; C --- = -i - --
; dt L R
;
; diL
; L --- = v
; dt C
;
;which models a damped oscillator.
(define damped-oscillator
(lambda (R L C)
(lambda (state)
(let ((Vc (vector-ref state 0))
(Il (vector-ref state 1)))
(vector (- 0 (+ (/ Vc (* R C)) (/ Il C)))
(/ Vc L))))))
(define the-states
(integrate-system
(damped-oscillator 10000 1000 .001)
'#(1 0)
.01))
(do ((i 10 (- i 1))
(s the-states (tail s)))
((zero? i) (newline))
(newline)
(write (head s)))
; #(1 0)
; #(0.99895054 9.994835e-6)
; #(0.99780226 1.9978681e-5)
; #(0.9965554 2.9950552e-5)
; #(0.9952102 3.990946e-5)
; #(0.99376684 4.985443e-5)
; #(0.99222565 5.9784474e-5)
; #(0.9905868 6.969862e-5)
; #(0.9888506 7.9595884e-5)
; #(0.9870173 8.94753e-5)
scm-5e5/xevent.scm 0000644 0017052 0001750 00000001711 10752242351 012050 0 ustar tb tb ;; xgen.scm extracted typedef structs from /usr/include/X11/Xlib.h
(define X-event:type #x10)
(define X-event:serial #x11)
(define X-event:send-event #x12)
(define X-event:time #x13)
(define X-event:x #x14)
(define X-event:y #x15)
(define X-event:x-root #x16)
(define X-event:y-root #x17)
(define X-event:state #x18)
(define X-event:keycode #x19)
(define X-event:same-screen #x1a)
(define X-event:button #x1b)
(define X-event:is-hint #x1c)
(define X-event:mode #x1d)
(define X-event:detail #x1e)
(define X-event:focus #x1f)
(define X-event:width #x20)
(define X-event:height #x21)
(define X-event:count #x22)
(define X-event:major-code #x23)
(define X-event:minor-code #x24)
(define X-event:border-width #x25)
(define X-event:override-redirect #x26)
(define X-event:from-configure #x27)
(define X-event:value-mask #x28)
(define X-event:place #x29)
(define X-event:new #x2a)
(define X-event:format #x2b)
(define X-event:request #x2c)
(define X-event:first-keycode #x2d)
scm-5e5/x11.scm 0000644 0017052 0001750 00000041766 10750407300 011161 0 ustar tb tb ;;inc2scm extracted #define values from /usr/include/X11/X.h
(define X:PROTOCOL 11)
(define X:PROTOCOL-REVISION 0)
(define x:None 0)
(define x:Parent-Relative 1)
(define x:Copy-From-Parent 0)
(define x:Pointer-Window 0)
(define x:Input-Focus 1)
(define x:Pointer-Root 1)
(define x:Any-Property-Type 0)
(define x:Any-Key 0)
(define x:Any-Button 0)
(define x:All-Temporary 0)
(define x:Current-Time 0)
(define x:No-Symbol 0)
(define x:No-Event-Mask 0)
(define x:Key-Press-Mask 1)
(define x:Key-Release-Mask 2)
(define x:Button-Press-Mask 4)
(define x:Button-Release-Mask 8)
(define x:Enter-Window-Mask 16)
(define x:Leave-Window-Mask 32)
(define x:Pointer-Motion-Mask 64)
(define x:Pointer-Motion-Hint-Mask 128)
(define x:Button1-Motion-Mask 256)
(define x:Button2-Motion-Mask 512)
(define x:Button3-Motion-Mask 1024)
(define x:Button4-Motion-Mask 2048)
(define x:Button5-Motion-Mask 4096)
(define x:Button-Motion-Mask 8192)
(define x:Keymap-State-Mask 16384)
(define x:Exposure-Mask 32768)
(define x:Visibility-Change-Mask 65536)
(define x:Structure-Notify-Mask 131072)
(define x:Resize-Redirect-Mask 262144)
(define x:Substructure-Notify-Mask 524288)
(define x:Substructure-Redirect-Mask 1048576)
(define x:Focus-Change-Mask 2097152)
(define x:Property-Change-Mask 4194304)
(define x:Colormap-Change-Mask 8388608)
(define x:Owner-Grab-Button-Mask 16777216)
(define x:Key-Press 2)
(define x:Key-Release 3)
(define x:Button-Press 4)
(define x:Button-Release 5)
(define x:Motion-Notify 6)
(define x:Enter-Notify 7)
(define x:Leave-Notify 8)
(define x:Focus-In 9)
(define x:Focus-Out 10)
(define x:Keymap-Notify 11)
(define x:Expose 12)
(define x:Graphics-Expose 13)
(define x:No-Expose 14)
(define x:Visibility-Notify 15)
(define x:Create-Notify 16)
(define x:Destroy-Notify 17)
(define x:Unmap-Notify 18)
(define x:Map-Notify 19)
(define x:Map-Request 20)
(define x:Reparent-Notify 21)
(define x:Configure-Notify 22)
(define x:Configure-Request 23)
(define x:Gravity-Notify 24)
(define x:Resize-Request 25)
(define x:Circulate-Notify 26)
(define x:Circulate-Request 27)
(define x:Property-Notify 28)
(define x:Selection-Clear 29)
(define x:Selection-Request 30)
(define x:Selection-Notify 31)
(define x:Colormap-Notify 32)
(define x:Client-Message 33)
(define x:Mapping-Notify 34)
(define x:LAST-Event 35)
(define x:Shift-Mask 1)
(define x:Lock-Mask 2)
(define x:Control-Mask 4)
(define x:Mod1-Mask 8)
(define x:Mod2-Mask 16)
(define x:Mod3-Mask 32)
(define x:Mod4-Mask 64)
(define x:Mod5-Mask 128)
(define x:Shift-Map-Index 0)
(define x:Lock-Map-Index 1)
(define x:Control-Map-Index 2)
(define x:Mod1-Map-Index 3)
(define x:Mod2-Map-Index 4)
(define x:Mod3-Map-Index 5)
(define x:Mod4-Map-Index 6)
(define x:Mod5-Map-Index 7)
(define x:Button1-Mask 256)
(define x:Button2-Mask 512)
(define x:Button3-Mask 1024)
(define x:Button4-Mask 2048)
(define x:Button5-Mask 4096)
(define x:Any-Modifier 32768)
(define x:Button1 1)
(define x:Button2 2)
(define x:Button3 3)
(define x:Button4 4)
(define x:Button5 5)
(define x:Notify-Normal 0)
(define x:Notify-Grab 1)
(define x:Notify-Ungrab 2)
(define x:Notify-While-Grabbed 3)
(define x:Notify-Hint 1)
(define x:Notify-Ancestor 0)
(define x:Notify-Virtual 1)
(define x:Notify-Inferior 2)
(define x:Notify-Nonlinear 3)
(define x:Notify-Nonlinear-Virtual 4)
(define x:Notify-Pointer 5)
(define x:Notify-Pointer-Root 6)
(define x:Notify-Detail-None 7)
(define x:Visibility-Unobscured 0)
(define x:Visibility-Partially-Obscured 1)
(define x:Visibility-Fully-Obscured 2)
(define x:Place-On-Top 0)
(define x:Place-On-Bottom 1)
(define x:Family-Internet 0)
(define x:Family-DE-Cnet 1)
(define x:Family-Chaos 2)
(define x:Family-Internet6 6)
(define x:Family-Server-Interpreted 5)
(define x:Property-New-Value 0)
(define x:Property-Delete 1)
(define x:Colormap-Uninstalled 0)
(define x:Colormap-Installed 1)
(define x:Grab-Mode-Sync 0)
(define x:Grab-Mode-Async 1)
(define x:Grab-Success 0)
(define x:Already-Grabbed 1)
(define x:Grab-Invalid-Time 2)
(define x:Grab-Not-Viewable 3)
(define x:Grab-Frozen 4)
(define x:Async-Pointer 0)
(define x:Sync-Pointer 1)
(define x:Replay-Pointer 2)
(define x:Async-Keyboard 3)
(define x:Sync-Keyboard 4)
(define x:Replay-Keyboard 5)
(define x:Async-Both 6)
(define x:Sync-Both 7)
(define x:Revert-To-None 0)
(define x:Revert-To-Pointer-Root 1)
(define x:Revert-To-Parent 2)
(define x:Success 0)
(define x:Bad-Request 1)
(define x:Bad-Value 2)
(define x:Bad-Window 3)
(define x:Bad-Pixmap 4)
(define x:Bad-Atom 5)
(define x:Bad-Cursor 6)
(define x:Bad-Font 7)
(define x:Bad-Match 8)
(define x:Bad-Drawable 9)
(define x:Bad-Access 10)
(define x:Bad-Alloc 11)
(define x:Bad-Color 12)
(define x:Bad-GC 13)
(define x:Bad-ID-Choice 14)
(define x:Bad-Name 15)
(define x:Bad-Length 16)
(define x:Bad-Implementation 17)
(define x:First-Extension-Error 128)
(define x:Last-Extension-Error 255)
(define x:Input-Output 1)
(define x:Input-Only 2)
(define x:CW-Back-Pixmap 1)
(define x:CW-Back-Pixel 2)
(define x:CW-Border-Pixmap 4)
(define x:CW-Border-Pixel 8)
(define x:CW-Bit-Gravity 16)
(define x:CW-Win-Gravity 32)
(define x:CW-Backing-Store 64)
(define x:CW-Backing-Planes 128)
(define x:CW-Backing-Pixel 256)
(define x:CW-Override-Redirect 512)
(define x:CW-Save-Under 1024)
(define x:CW-Event-Mask 2048)
(define x:CW-Dont-Propagate 4096)
(define x:CW-Colormap 8192)
(define x:CW-Cursor 16384)
(define x:CWX 1)
(define x:CWY 2)
(define x:CW-Width 4)
(define x:CW-Height 8)
(define x:CW-Border-Width 16)
(define x:CW-Sibling 32)
(define x:CW-Stack-Mode 64)
(define x:Forget-Gravity 0)
(define x:North-West-Gravity 1)
(define x:North-Gravity 2)
(define x:North-East-Gravity 3)
(define x:West-Gravity 4)
(define x:Center-Gravity 5)
(define x:East-Gravity 6)
(define x:South-West-Gravity 7)
(define x:South-Gravity 8)
(define x:South-East-Gravity 9)
(define x:Static-Gravity 10)
(define x:Unmap-Gravity 0)
(define x:Not-Useful 0)
(define x:When-Mapped 1)
(define x:Always 2)
(define x:Is-Unmapped 0)
(define x:Is-Unviewable 1)
(define x:Is-Viewable 2)
(define x:Set-Mode-Insert 0)
(define x:Set-Mode-Delete 1)
(define x:Destroy-All 0)
(define x:Retain-Permanent 1)
(define x:Retain-Temporary 2)
(define x:Above 0)
(define x:Below 1)
(define x:Top-If 2)
(define x:Bottom-If 3)
(define x:Opposite 4)
(define x:Raise-Lowest 0)
(define x:Lower-Highest 1)
(define x:Prop-Mode-Replace 0)
(define x:Prop-Mode-Prepend 1)
(define x:Prop-Mode-Append 2)
(define x:G-Xclear 0)
(define x:G-Xand 1)
(define x:G-Xand-Reverse 2)
(define x:G-Xcopy 3)
(define x:G-Xand-Inverted 4)
(define x:G-Xnoop 5)
(define x:G-Xxor 6)
(define x:G-Xor 7)
(define x:G-Xnor 8)
(define x:G-Xequiv 9)
(define x:G-Xinvert 10)
(define x:G-Xor-Reverse 11)
(define x:G-Xcopy-Inverted 12)
(define x:G-Xor-Inverted 13)
(define x:G-Xnand 14)
(define x:G-Xset 15)
(define x:Line-Solid 0)
(define x:Line-On-Off-Dash 1)
(define x:Line-Double-Dash 2)
(define x:Cap-Not-Last 0)
(define x:Cap-Butt 1)
(define x:Cap-Round 2)
(define x:Cap-Projecting 3)
(define x:Join-Miter 0)
(define x:Join-Round 1)
(define x:Join-Bevel 2)
(define x:Fill-Solid 0)
(define x:Fill-Tiled 1)
(define x:Fill-Stippled 2)
(define x:Fill-Opaque-Stippled 3)
(define x:Even-Odd-Rule 0)
(define x:Winding-Rule 1)
(define x:Clip-By-Children 0)
(define x:Include-Inferiors 1)
(define x:Unsorted 0)
(define x:Y-Sorted 1)
(define x:YX-Sorted 2)
(define x:YX-Banded 3)
(define x:Coord-Mode-Origin 0)
(define x:Coord-Mode-Previous 1)
(define x:Complex 0)
(define x:Nonconvex 1)
(define x:Convex 2)
(define x:Arc-Chord 0)
(define x:Arc-Pie-Slice 1)
(define x:GC-Function 1)
(define x:GC-Plane-Mask 2)
(define x:GC-Foreground 4)
(define x:GC-Background 8)
(define x:GC-Line-Width 16)
(define x:GC-Line-Style 32)
(define x:GC-Cap-Style 64)
(define x:GC-Join-Style 128)
(define x:GC-Fill-Style 256)
(define x:GC-Fill-Rule 512)
(define x:GC-Tile 1024)
(define x:GC-Stipple 2048)
(define x:GC-Tile-Stip-X-Origin 4096)
(define x:GC-Tile-Stip-Y-Origin 8192)
(define x:GC-Font 16384)
(define x:GC-Subwindow-Mode 32768)
(define x:GC-Graphics-Exposures 65536)
(define x:GC-Clip-X-Origin 131072)
(define x:GC-Clip-Y-Origin 262144)
(define x:GC-Clip-Mask 524288)
(define x:GC-Dash-Offset 1048576)
(define x:GC-Dash-List 2097152)
(define x:GC-Arc-Mode 4194304)
(define x:GC-Last-Bit 22)
(define x:Font-Left-To-Right 0)
(define x:Font-Right-To-Left 1)
(define x:Font-Change 255)
(define x:XY-Bitmap 0)
(define x:XY-Pixmap 1)
(define x:Z-Pixmap 2)
(define x:Alloc-None 0)
(define x:Alloc-All 1)
(define x:Do-Red 1)
(define x:Do-Green 2)
(define x:Do-Blue 4)
(define x:Cursor-Shape 0)
(define x:Tile-Shape 1)
(define x:Stipple-Shape 2)
(define x:Auto-Repeat-Mode-Off 0)
(define x:Auto-Repeat-Mode-On 1)
(define x:Auto-Repeat-Mode-Default 2)
(define x:Led-Mode-Off 0)
(define x:Led-Mode-On 1)
(define x:KB-Key-Click-Percent 1)
(define x:KB-Bell-Percent 2)
(define x:KB-Bell-Pitch 4)
(define x:KB-Bell-Duration 8)
(define x:KB-Led 16)
(define x:KB-Led-Mode 32)
(define x:KB-Key 64)
(define x:KB-Auto-Repeat-Mode 128)
(define x:Mapping-Success 0)
(define x:Mapping-Busy 1)
(define x:Mapping-Failed 2)
(define x:Mapping-Modifier 0)
(define x:Mapping-Keyboard 1)
(define x:Mapping-Pointer 2)
(define x:Dont-Prefer-Blanking 0)
(define x:Prefer-Blanking 1)
(define x:Default-Blanking 2)
(define x:Disable-Screen-Saver 0)
(define x:Disable-Screen-Interval 0)
(define x:Dont-Allow-Exposures 0)
(define x:Allow-Exposures 1)
(define x:Default-Exposures 2)
(define x:Screen-Saver-Reset 0)
(define x:Screen-Saver-Active 1)
(define x:Host-Insert 0)
(define x:Host-Delete 1)
(define x:Enable-Access 1)
(define x:Disable-Access 0)
(define x:Static-Gray 0)
(define x:Gray-Scale 1)
(define x:Static-Color 2)
(define x:Pseudo-Color 3)
(define x:True-Color 4)
(define x:Direct-Color 5)
(define x:LSB-First 0)
(define x:MSB-First 1)
;;inc2scm extracted #define values from /usr/include/X11/cursorfont.h
(define XC:num-glyphs 154)
(define XC:X-cursor 0)
(define XC:arrow 2)
(define XC:based-arrow-down 4)
(define XC:based-arrow-up 6)
(define XC:boat 8)
(define XC:bogosity 10)
(define XC:bottom-left-corner 12)
(define XC:bottom-right-corner 14)
(define XC:bottom-side 16)
(define XC:bottom-tee 18)
(define XC:box-spiral 20)
(define XC:center-ptr 22)
(define XC:circle 24)
(define XC:clock 26)
(define XC:coffee-mug 28)
(define XC:cross 30)
(define XC:cross-reverse 32)
(define XC:crosshair 34)
(define XC:diamond-cross 36)
(define XC:dot 38)
(define XC:dotbox 40)
(define XC:double-arrow 42)
(define XC:draft-large 44)
(define XC:draft-small 46)
(define XC:draped-box 48)
(define XC:exchange 50)
(define XC:fleur 52)
(define XC:gobbler 54)
(define XC:gumby 56)
(define XC:hand1 58)
(define XC:hand2 60)
(define XC:heart 62)
(define XC:icon 64)
(define XC:iron-cross 66)
(define XC:left-ptr 68)
(define XC:left-side 70)
(define XC:left-tee 72)
(define XC:leftbutton 74)
(define XC:ll-angle 76)
(define XC:lr-angle 78)
(define XC:man 80)
(define XC:middlebutton 82)
(define XC:mouse 84)
(define XC:pencil 86)
(define XC:pirate 88)
(define XC:plus 90)
(define XC:question-arrow 92)
(define XC:right-ptr 94)
(define XC:right-side 96)
(define XC:right-tee 98)
(define XC:rightbutton 100)
(define XC:rtl-logo 102)
(define XC:sailboat 104)
(define XC:sb-down-arrow 106)
(define XC:sb-h-double-arrow 108)
(define XC:sb-left-arrow 110)
(define XC:sb-right-arrow 112)
(define XC:sb-up-arrow 114)
(define XC:sb-v-double-arrow 116)
(define XC:shuttle 118)
(define XC:sizing 120)
(define XC:spider 122)
(define XC:spraycan 124)
(define XC:star 126)
(define XC:target 128)
(define XC:tcross 130)
(define XC:top-left-arrow 132)
(define XC:top-left-corner 134)
(define XC:top-right-corner 136)
(define XC:top-side 138)
(define XC:top-tee 140)
(define XC:trek 142)
(define XC:ul-angle 144)
(define XC:umbrella 146)
(define XC:ur-angle 148)
(define XC:watch 150)
(define XC:xterm 152)
;;inc2scm extracted #define values from /usr/include/X11/Xlib.h
(define x:Xlib-Specification-Release 6)
(define X:HAVE-UTF8-STRING 1)
(define x:True 1)
(define x:False 0)
(define x:Queued-Already 0)
(define x:Queued-After-Reading 1)
(define x:Queued-After-Flush 2)
(define x:All-Planes -1)
(define x:XN-Required-Char-Set 134532633)
(define x:XN-Query-Orientation 134532672)
(define x:XN-Base-Font-Name 134532712)
(define x:XNOM-Automatic 134532745)
(define x:XN-Missing-Char-Set 134532774)
(define x:XN-Default-String 134532811)
(define x:XN-Orientation 134532845)
(define x:XN-Directional-Dependent-Drawing 134532874)
(define x:XN-Contextual-Drawing 134532939)
(define x:XN-Font-Info 134532981)
(define x:XIM-Preedit-Area 1)
(define x:XIM-Preedit-Callbacks 2)
(define x:XIM-Preedit-Position 4)
(define x:XIM-Preedit-Nothing 8)
(define x:XIM-Preedit-None 16)
(define x:XIM-Status-Area 256)
(define x:XIM-Status-Callbacks 512)
(define x:XIM-Status-Nothing 1024)
(define x:XIM-Status-None 2048)
(define x:XN-Va-Nested-List 134533192)
(define x:XN-Query-Input-Style 134533227)
(define x:XN-Client-Window 134533266)
(define x:XN-Input-Style 134533298)
(define x:XN-Focus-Window 134533326)
(define x:XN-Resource-Name 134533356)
(define x:XN-Resource-Class 134533388)
(define x:XN-Geometry-Callback 134533422)
(define x:XN-Destroy-Callback 134533462)
(define x:XN-Filter-Events 134533500)
(define x:XN-Preedit-Start-Callback 134533532)
(define x:XN-Preedit-Done-Callback 134533581)
(define x:XN-Preedit-Draw-Callback 134533628)
(define x:XN-Preedit-Caret-Callback 134533675)
(define x:XN-Preedit-State-Notify-Callback 134533724)
(define x:XN-Preedit-Attributes 134533787)
(define x:XN-Status-Start-Callback 134533829)
(define x:XN-Status-Done-Callback 134533876)
(define x:XN-Status-Draw-Callback 134533921)
(define x:XN-Status-Attributes 134533966)
(define x:XN-Area 134534006)
(define x:XN-Area-Needed 134534021)
(define x:XN-Spot-Location 134534049)
(define x:XN-Colormap 134534081)
(define x:XN-Std-Colormap 134534104)
(define x:XN-Foreground 134534134)
(define x:XN-Background 134534161)
(define x:XN-Background-Pixmap 134534188)
(define x:XN-Font-Set 134534228)
(define x:XN-Line-Space 134534250)
(define x:XN-Cursor 134534276)
(define x:XN-Query-IM-Values-List 134534295)
(define x:XN-Query-IC-Values-List 134534339)
(define x:XN-Visible-Position 134534383)
(define x:XNR6-Preedit-Callback 134534421)
(define x:XN-String-Conversion-Callback 134534463)
(define x:XN-String-Conversion 134534520)
(define x:XN-Reset-State 134534560)
(define x:XN-Hot-Key 134534588)
(define x:XN-Hot-Key-State 134534608)
(define x:XN-Preedit-State 134534639)
(define x:XN-Separatorof-Nested-List 134534671)
(define x:X-Buffer-Overflow -1)
(define x:X-Lookup-None 1)
(define x:X-Lookup-Chars 2)
(define x:X-Lookup-Key-Sym 3)
(define x:X-Lookup-Both 4)
(define x:XIM-Reverse 1)
(define x:XIM-Underline 2)
(define x:XIM-Highlight 4)
(define x:XIM-Primary 32)
(define x:XIM-Secondary 64)
(define x:XIM-Tertiary 128)
(define x:XIM-Visible-To-Forward 256)
(define x:XIM-Visible-To-Backword 512)
(define x:XIM-Visible-To-Center 1024)
(define x:XIM-Preedit-Un-Known 0)
(define x:XIM-Preedit-Enable 1)
(define x:XIM-Preedit-Disable 2)
(define x:XIM-Initial-State 1)
(define x:XIM-Preserve-State 2)
(define x:XIM-String-Conversion-Left-Edge 1)
(define x:XIM-String-Conversion-Right-Edge 2)
(define x:XIM-String-Conversion-Top-Edge 4)
(define x:XIM-String-Conversion-Bottom-Edge 8)
(define x:XIM-String-Conversion-Concealed 16)
(define x:XIM-String-Conversion-Wrapped 32)
(define x:XIM-String-Conversion-Buffer 1)
(define x:XIM-String-Conversion-Line 2)
(define x:XIM-String-Conversion-Word 3)
(define x:XIM-String-Conversion-Char 4)
(define x:XIM-String-Conversion-Substitution 1)
(define x:XIM-String-Conversion-Retrieval 2)
(define x:XIM-Hot-Key-State-ON 1)
(define x:XIM-Hot-Key-State-OFF 2)
;;inc2scm extracted #define values from /usr/include/X11/Xutil.h
(define x:No-Value 0)
(define x:X-Value 1)
(define x:Y-Value 2)
(define x:Width-Value 4)
(define x:Height-Value 8)
(define x:All-Values 15)
(define x:X-Negative 16)
(define x:Y-Negative 32)
(define x:US-Position 1)
(define x:US-Size 2)
(define x:P-Position 4)
(define x:P-Size 8)
(define x:P-Min-Size 16)
(define x:P-Max-Size 32)
(define x:P-Resize-Inc 64)
(define x:P-Aspect 128)
(define x:P-Base-Size 256)
(define x:P-Win-Gravity 512)
(define x:P-All-Hints 252)
(define x:Input-Hint 1)
(define x:State-Hint 2)
(define x:Icon-Pixmap-Hint 4)
(define x:Icon-Window-Hint 8)
(define x:Icon-Position-Hint 16)
(define x:Icon-Mask-Hint 32)
(define x:Window-Group-Hint 64)
(define x:All-Hints 127)
(define x:X-Urgency-Hint 256)
(define x:Withdrawn-State 0)
(define x:Normal-State 1)
(define x:Iconic-State 3)
(define x:Dont-Care-State 0)
(define x:Zoom-State 2)
(define x:Inactive-State 4)
(define x:X-No-Memory -1)
(define x:X-Locale-Not-Supported -2)
(define x:X-Converter-Not-Found -3)
(define x:Rectangle-Out 0)
(define x:Rectangle-In 1)
(define x:Rectangle-Part 2)
(define x:Visual-No-Mask 0)
(define x:Visual-ID-Mask 1)
(define x:Visual-Screen-Mask 2)
(define x:Visual-Depth-Mask 4)
(define x:Visual-Class-Mask 8)
(define x:Visual-Red-Mask-Mask 16)
(define x:Visual-Green-Mask-Mask 32)
(define x:Visual-Blue-Mask-Mask 64)
(define x:Visual-Colormap-Size-Mask 128)
(define x:Visual-Bits-Per-RGB-Mask 256)
(define x:Visual-All-Mask 511)
(define x:Release-By-Freeing-Colormap 1)
(define x:Bitmap-Success 0)
(define x:Bitmap-Open-Failed 1)
(define x:Bitmap-File-Invalid 2)
(define x:Bitmap-No-Memory 3)
(define x:XCSUCCESS 0)
(define x:XCNOMEM 1)
(define x:XCNOENT 2)
scm-5e5/unexelf.c 0000644 0017052 0001750 00000127336 10750241221 011652 0 ustar tb tb /* Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992, 1999, 2000, 2001,
2002, 2003, 2004, 2005 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
. */
/*
* unexec.c - Convert a running program into an a.out file.
*
* Author: Spencer W. Thomas
* Computer Science Dept.
* University of Utah
* Date: Tue Mar 2 1982
* Modified heavily since then.
*
* Synopsis:
* unexec (new_name, old_name, data_start, bss_start, entry_address)
* char *new_name, *old_name;
* unsigned data_start, bss_start, entry_address;
*
* Takes a snapshot of the program and makes an a.out format file in the
* file named by the string argument new_name.
* If old_name is non-NULL, the symbol table will be taken from the given file.
* On some machines, an existing old_name file is required.
*
* The boundaries within the a.out file may be adjusted with the data_start
* and bss_start arguments. Either or both may be given as 0 for defaults.
*
* Data_start gives the boundary between the text segment and the data
* segment of the program. The text segment can contain shared, read-only
* program code and literal data, while the data segment is always unshared
* and unprotected. Data_start gives the lowest unprotected address.
* The value you specify may be rounded down to a suitable boundary
* as required by the machine you are using.
*
* Bss_start indicates how much of the data segment is to be saved in the
* a.out file and restored when the program is executed. It gives the lowest
* unsaved address, and is rounded up to a page boundary. The default when 0
* is given assumes that the entire data segment is to be stored, including
* the previous data and bss as well as any additional storage allocated with
* break (2).
*
* The new file is set up to start at entry_address.
*
*/
/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co.
* ELF support added.
*
* Basic theory: the data space of the running process needs to be
* dumped to the output file. Normally we would just enlarge the size
* of .data, scooting everything down. But we can't do that in ELF,
* because there is often something between the .data space and the
* .bss space.
*
* In the temacs dump below, notice that the Global Offset Table
* (.got) and the Dynamic link data (.dynamic) come between .data1 and
* .bss. It does not work to overlap .data with these fields.
*
* The solution is to create a new .data segment. This segment is
* filled with data from the current process. Since the contents of
* various sections refer to sections by index, the new .data segment
* is made the last in the table to avoid changing any existing index.
* This is an example of how the section headers are changed. "Addr"
* is a process virtual address. "Offset" is a file offset.
raid:/nfs/raid/src/dist-18.56/src> dump -h temacs
temacs:
**** SECTION HEADER TABLE ****
[No] Type Flags Addr Offset Size Name
Link Info Adralgn Entsize
[1] 1 2 0x80480d4 0xd4 0x13 .interp
0 0 0x1 0
[2] 5 2 0x80480e8 0xe8 0x388 .hash
3 0 0x4 0x4
[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
4 1 0x4 0x10
[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
0 0 0x1 0
[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
3 7 0x4 0x8
[6] 1 6 0x8049348 0x1348 0x3 .init
0 0 0x4 0
[7] 1 6 0x804934c 0x134c 0x680 .plt
0 0 0x4 0x4
[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
0 0 0x4 0
[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
0 0 0x4 0
[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
0 0 0x4 0
[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
0 0 0x4 0
[12] 1 3 0x8088330 0x3f330 0x20afc .data
0 0 0x4 0
[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
0 0 0x4 0
[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
0 0 0x4 0x4
[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
4 0 0x4 0x8
[16] 8 3 0x80a98f4 0x608f4 0x449c .bss
0 0 0x4 0
[17] 2 0 0 0x608f4 0x9b90 .symtab
18 371 0x4 0x10
[18] 3 0 0 0x6a484 0x8526 .strtab
0 0 0x1 0
[19] 3 0 0 0x729aa 0x93 .shstrtab
0 0 0x1 0
[20] 1 0 0 0x72a3d 0x68b7 .comment
0 0 0x1 0
raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs
xemacs:
**** SECTION HEADER TABLE ****
[No] Type Flags Addr Offset Size Name
Link Info Adralgn Entsize
[1] 1 2 0x80480d4 0xd4 0x13 .interp
0 0 0x1 0
[2] 5 2 0x80480e8 0xe8 0x388 .hash
3 0 0x4 0x4
[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
4 1 0x4 0x10
[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
0 0 0x1 0
[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
3 7 0x4 0x8
[6] 1 6 0x8049348 0x1348 0x3 .init
0 0 0x4 0
[7] 1 6 0x804934c 0x134c 0x680 .plt
0 0 0x4 0x4
[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
0 0 0x4 0
[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
0 0 0x4 0
[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
0 0 0x4 0
[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
0 0 0x4 0
[12] 1 3 0x8088330 0x3f330 0x20afc .data
0 0 0x4 0
[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
0 0 0x4 0
[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
0 0 0x4 0x4
[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
4 0 0x4 0x8
[16] 8 3 0x80c6800 0x7d800 0 .bss
0 0 0x4 0
[17] 2 0 0 0x7d800 0x9b90 .symtab
18 371 0x4 0x10
[18] 3 0 0 0x87390 0x8526 .strtab
0 0 0x1 0
[19] 3 0 0 0x8f8b6 0x93 .shstrtab
0 0 0x1 0
[20] 1 0 0 0x8f949 0x68b7 .comment
0 0 0x1 0
[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data
0 0 0x4 0
* This is an example of how the file header is changed. "Shoff" is
* the section header offset within the file. Since that table is
* after the new .data section, it is moved. "Shnum" is the number of
* sections, which we increment.
*
* "Phoff" is the file offset to the program header. "Phentsize" and
* "Shentsz" are the program and section header entries sizes respectively.
* These can be larger than the apparent struct sizes.
raid:/nfs/raid/src/dist-18.56/src> dump -f temacs
temacs:
**** ELF HEADER ****
Class Data Type Machine Version
Entry Phoff Shoff Flags Ehsize
Phentsize Phnum Shentsz Shnum Shstrndx
1 1 2 3 1
0x80499cc 0x34 0x792f4 0 0x34
0x20 5 0x28 21 19
raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs
xemacs:
**** ELF HEADER ****
Class Data Type Machine Version
Entry Phoff Shoff Flags Ehsize
Phentsize Phnum Shentsz Shnum Shstrndx
1 1 2 3 1
0x80499cc 0x34 0x96200 0 0x34
0x20 5 0x28 22 19
* These are the program headers. "Offset" is the file offset to the
* segment. "Vaddr" is the memory load address. "Filesz" is the
* segment size as it appears in the file, and "Memsz" is the size in
* memory. Below, the third segment is the code and the fourth is the
* data: the difference between Filesz and Memsz is .bss
raid:/nfs/raid/src/dist-18.56/src> dump -o temacs
temacs:
***** PROGRAM EXECUTION HEADER *****
Type Offset Vaddr Paddr
Filesz Memsz Flags Align
6 0x34 0x8048034 0
0xa0 0xa0 5 0
3 0xd4 0 0
0x13 0 4 0
1 0x34 0x8048034 0
0x3f2f9 0x3f2f9 5 0x1000
1 0x3f330 0x8088330 0
0x215c4 0x25a60 7 0x1000
2 0x60874 0x80a9874 0
0x80 0 7 0
raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs
xemacs:
***** PROGRAM EXECUTION HEADER *****
Type Offset Vaddr Paddr
Filesz Memsz Flags Align
6 0x34 0x8048034 0
0xa0 0xa0 5 0
3 0xd4 0 0
0x13 0 4 0
1 0x34 0x8048034 0
0x3f2f9 0x3f2f9 5 0x1000
1 0x3f330 0x8088330 0
0x3e4d0 0x3e4d0 7 0x1000
2 0x60874 0x80a9874 0
0x80 0 7 0
*/
/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc.
*
* The above mechanism does not work if the unexeced ELF file is being
* re-layout by other applications (such as `strip'). All the applications
* that re-layout the internal of ELF will layout all sections in ascending
* order of their file offsets. After the re-layout, the data2 section will
* still be the LAST section in the section header vector, but its file offset
* is now being pushed far away down, and causes part of it not to be mapped
* in (ie. not covered by the load segment entry in PHDR vector), therefore
* causes the new binary to fail.
*
* The solution is to modify the unexec algorithm to insert the new data2
* section header right before the new bss section header, so their file
* offsets will be in the ascending order. Since some of the section's (all
* sections AFTER the bss section) indexes are now changed, we also need to
* modify some fields to make them point to the right sections. This is done
* by macro PATCH_INDEX. All the fields that need to be patched are:
*
* 1. ELF header e_shstrndx field.
* 2. section header sh_link and sh_info field.
* 3. symbol table entry st_shndx field.
*
* The above example now should look like:
**** SECTION HEADER TABLE ****
[No] Type Flags Addr Offset Size Name
Link Info Adralgn Entsize
[1] 1 2 0x80480d4 0xd4 0x13 .interp
0 0 0x1 0
[2] 5 2 0x80480e8 0xe8 0x388 .hash
3 0 0x4 0x4
[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
4 1 0x4 0x10
[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
0 0 0x1 0
[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
3 7 0x4 0x8
[6] 1 6 0x8049348 0x1348 0x3 .init
0 0 0x4 0
[7] 1 6 0x804934c 0x134c 0x680 .plt
0 0 0x4 0x4
[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
0 0 0x4 0
[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
0 0 0x4 0
[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
0 0 0x4 0
[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
0 0 0x4 0
[12] 1 3 0x8088330 0x3f330 0x20afc .data
0 0 0x4 0
[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
0 0 0x4 0
[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
0 0 0x4 0x4
[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
4 0 0x4 0x8
[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data
0 0 0x4 0
[17] 8 3 0x80c6800 0x7d800 0 .bss
0 0 0x4 0
[18] 2 0 0 0x7d800 0x9b90 .symtab
19 371 0x4 0x10
[19] 3 0 0 0x87390 0x8526 .strtab
0 0 0x1 0
[20] 3 0 0 0x8f8b6 0x93 .shstrtab
0 0 0x1 0
[21] 1 0 0 0x8f949 0x68b7 .comment
0 0 0x1 0
*/
/* We do not use mmap because that fails with NFS.
Instead we read the whole file, modify it, and write it out. */
#ifndef emacs
#define fatal(a, b, c) fprintf (stderr, a, b, c), exit (1)
#include
#else
#include
extern void fatal (const char *msgid, ...);
#endif
#include
#include
#include
#include
#include
#include
#include
#if !defined (__NetBSD__) && !defined (__OpenBSD__)
#include
#endif
#include
#if defined (__sony_news) && defined (_SYSTYPE_SYSV)
#include
#include
#endif /* __sony_news && _SYSTYPE_SYSV */
#if __sgi
#include /* for HDRR declaration */
#endif /* __sgi */
#ifndef MAP_ANON
#ifdef MAP_ANONYMOUS
#define MAP_ANON MAP_ANONYMOUS
#else
#define MAP_ANON 0
#endif
#endif
#ifndef MAP_FAILED
#define MAP_FAILED ((void *) -1)
#endif
#if defined (__alpha__) && !defined (__NetBSD__) && !defined (__OpenBSD__)
/* Declare COFF debugging symbol table. This used to be in
/usr/include/sym.h, but this file is no longer included in Red Hat
5.0 and presumably in any other glibc 2.x based distribution. */
typedef struct {
short magic;
short vstamp;
int ilineMax;
int idnMax;
int ipdMax;
int isymMax;
int ioptMax;
int iauxMax;
int issMax;
int issExtMax;
int ifdMax;
int crfd;
int iextMax;
long cbLine;
long cbLineOffset;
long cbDnOffset;
long cbPdOffset;
long cbSymOffset;
long cbOptOffset;
long cbAuxOffset;
long cbSsOffset;
long cbSsExtOffset;
long cbFdOffset;
long cbRfdOffset;
long cbExtOffset;
} HDRR, *pHDRR;
#define cbHDRR sizeof(HDRR)
#define hdrNil ((pHDRR)0)
#endif
#ifdef __NetBSD__
/*
* NetBSD does not have normal-looking user-land ELF support.
*/
# if defined __alpha__ || defined __sparc_v9__
# define ELFSIZE 64
# else
# define ELFSIZE 32
# endif
# include
# ifndef PT_LOAD
# define PT_LOAD Elf_pt_load
# if 0 /* was in pkgsrc patches for 20.7 */
# define SHT_PROGBITS Elf_sht_progbits
# endif
# define SHT_SYMTAB Elf_sht_symtab
# define SHT_DYNSYM Elf_sht_dynsym
# define SHT_NULL Elf_sht_null
# define SHT_NOBITS Elf_sht_nobits
# define SHT_REL Elf_sht_rel
# define SHT_RELA Elf_sht_rela
# define SHN_UNDEF Elf_eshn_undefined
# define SHN_ABS Elf_eshn_absolute
# define SHN_COMMON Elf_eshn_common
# endif /* !PT_LOAD */
# ifdef __alpha__
# include
# define HDRR struct ecoff_symhdr
# define pHDRR HDRR *
# endif /* __alpha__ */
#ifdef __mips__ /* was in pkgsrc patches for 20.7 */
# define SHT_MIPS_DEBUG DT_MIPS_FLAGS
# define HDRR struct Elf_Shdr
#endif /* __mips__ */
#endif /* __NetBSD__ */
#ifdef __OpenBSD__
# include
#endif
#if __GNU_LIBRARY__ - 0 >= 6
# include /* get ElfW etc */
#endif
#ifndef ElfW
# ifdef __STDC__
# define ElfBitsW(bits, type) Elf##bits##_##type
# else
# define ElfBitsW(bits, type) Elf/**/bits/**/_/**/type
# endif
# ifdef _LP64
# define ELFSIZE 64
# else
# define ELFSIZE 32
# endif
/* This macro expands `bits' before invoking ElfBitsW. */
# define ElfExpandBitsW(bits, type) ElfBitsW (bits, type)
# define ElfW(type) ElfExpandBitsW (ELFSIZE, type)
#endif
#ifndef ELF_BSS_SECTION_NAME
#define ELF_BSS_SECTION_NAME ".bss"
#endif
/* Get the address of a particular section or program header entry,
* accounting for the size of the entries.
*/
/*
On PPC Reference Platform running Solaris 2.5.1
the plt section is also of type NOBI like the bss section.
(not really stored) and therefore sections after the bss
section start at the plt offset. The plt section is always
the one just before the bss section.
Thus, we modify the test from
if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset)
to
if (NEW_SECTION_H (nn).sh_offset >=
OLD_SECTION_H (old_bss_index-1).sh_offset)
This is just a hack. We should put the new data section
before the .plt section.
And we should not have this routine at all but use
the libelf library to read the old file and create the new
file.
The changed code is minimal and depends on prep set in m/prep.h
Erik Deumens
Quantum Theory Project
University of Florida
deumens@qtp.ufl.edu
Apr 23, 1996
*/
#define OLD_SECTION_H(n) \
(*(ElfW(Shdr) *) ((byte *) old_section_h + old_file_h->e_shentsize * (n)))
#define NEW_SECTION_H(n) \
(*(ElfW(Shdr) *) ((byte *) new_section_h + new_file_h->e_shentsize * (n)))
#define OLD_PROGRAM_H(n) \
(*(ElfW(Phdr) *) ((byte *) old_program_h + old_file_h->e_phentsize * (n)))
#define NEW_PROGRAM_H(n) \
(*(ElfW(Phdr) *) ((byte *) new_program_h + new_file_h->e_phentsize * (n)))
#define PATCH_INDEX(n) \
do { \
if ((int) (n) >= old_bss_index) \
(n)++; } while (0)
typedef unsigned char byte;
/* Round X up to a multiple of Y. */
static ElfW(Addr)
round_up (x, y)
ElfW(Addr) x, y;
{
int rem = x % y;
if (rem == 0)
return x;
return x - rem + y;
}
/* Return the index of the section named NAME.
SECTION_NAMES, FILE_NAME and FILE_H give information
about the file we are looking in.
If we don't find the section NAME, that is a fatal error
if NOERROR is 0; we return -1 if NOERROR is nonzero. */
static int
find_section (name, section_names, file_name, old_file_h, old_section_h, noerror)
char *name;
char *section_names;
char *file_name;
ElfW(Ehdr) *old_file_h;
ElfW(Shdr) *old_section_h;
int noerror;
{
int idx;
for (idx = 1; idx < old_file_h->e_shnum; idx++)
{
#ifdef DEBUG
fprintf (stderr, "Looking for %s - found %s\n", name,
section_names + OLD_SECTION_H (idx).sh_name);
#endif
if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name,
name))
break;
}
if (idx == old_file_h->e_shnum)
{
if (noerror)
return -1;
else
fatal ("Can't find %s in %s.\n", name, file_name);
}
return idx;
}
/* ****************************************************************
* unexec
*
* driving logic.
*
* In ELF, this works by replacing the old .bss section with a new
* .data section, and inserting an empty .bss immediately afterwards.
*
*/
void
unexec (new_name, old_name, data_start, bss_start, entry_address)
char *new_name, *old_name;
unsigned data_start, bss_start, entry_address;
{
int new_file, old_file, new_file_size;
/* Pointers to the base of the image of the two files. */
caddr_t old_base, new_base;
#if MAP_ANON == 0
int mmap_fd;
#else
# define mmap_fd -1
#endif
/* Pointers to the file, program and section headers for the old and
new files. */
ElfW(Ehdr) *old_file_h, *new_file_h;
ElfW(Phdr) *old_program_h, *new_program_h;
ElfW(Shdr) *old_section_h, *new_section_h;
/* Point to the section name table in the old file. */
char *old_section_names;
ElfW(Addr) old_bss_addr, new_bss_addr;
ElfW(Word) old_bss_size, new_data2_size;
ElfW(Off) new_data2_offset;
ElfW(Addr) new_data2_addr;
int n, nn;
int old_bss_index, old_sbss_index;
int old_data_index, new_data2_index;
int old_mdebug_index;
struct stat stat_buf;
int old_file_size;
/* Open the old file, allocate a buffer of the right size, and read
in the file contents. */
old_file = open (old_name, O_RDONLY);
if (old_file < 0)
fatal ("Can't open %s for reading: errno %d\n", old_name, errno);
if (fstat (old_file, &stat_buf) == -1)
fatal ("Can't fstat (%s): errno %d\n", old_name, errno);
#if MAP_ANON == 0
mmap_fd = open ("/dev/zero", O_RDONLY);
if (mmap_fd < 0)
fatal ("Can't open /dev/zero for reading: errno %d\n", errno, 0);
#endif
/* We cannot use malloc here because that may use sbrk. If it does,
we'd dump our temporary buffers with Emacs, and we'd have to be
extra careful to use the correct value of sbrk(0) after
allocating all buffers in the code below, which we aren't. */
old_file_size = stat_buf.st_size;
old_base = mmap (NULL, old_file_size, PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE, mmap_fd, 0);
if (old_base == MAP_FAILED)
fatal ("Can't allocate buffer for %s\n", old_name, 0);
if (read (old_file, old_base, stat_buf.st_size) != stat_buf.st_size)
fatal ("Didn't read all of %s: errno %d\n", old_name, errno);
/* Get pointers to headers & section names */
old_file_h = (ElfW(Ehdr) *) old_base;
old_program_h = (ElfW(Phdr) *) ((byte *) old_base + old_file_h->e_phoff);
old_section_h = (ElfW(Shdr) *) ((byte *) old_base + old_file_h->e_shoff);
old_section_names = (char *) old_base
+ OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset;
/* Find the mdebug section, if any. */
old_mdebug_index = find_section (".mdebug", old_section_names,
old_name, old_file_h, old_section_h, 1);
/* Find the old .bss section. Figure out parameters of the new
data2 and bss sections. */
old_bss_index = find_section (".bss", old_section_names,
old_name, old_file_h, old_section_h, 0);
old_sbss_index = find_section (".sbss", old_section_names,
old_name, old_file_h, old_section_h, 1);
if (old_sbss_index != -1)
if (OLD_SECTION_H (old_sbss_index).sh_type == SHT_PROGBITS)
old_sbss_index = -1;
if (old_sbss_index == -1)
{
old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr;
old_bss_size = OLD_SECTION_H (old_bss_index).sh_size;
new_data2_index = old_bss_index;
}
else
{
old_bss_addr = OLD_SECTION_H (old_sbss_index).sh_addr;
old_bss_size = OLD_SECTION_H (old_bss_index).sh_size
+ OLD_SECTION_H (old_sbss_index).sh_size;
new_data2_index = old_sbss_index;
}
/* Find the old .data section. Figure out parameters of
the new data2 and bss sections. */
old_data_index = find_section (".data", old_section_names,
old_name, old_file_h, old_section_h, 0);
#if defined (emacs) || !defined (DEBUG)
new_bss_addr = (ElfW(Addr)) sbrk (0);
#else
new_bss_addr = old_bss_addr + old_bss_size + 0x1234;
#endif
new_data2_addr = old_bss_addr;
new_data2_size = new_bss_addr - old_bss_addr;
new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset +
(new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr);
#ifdef DEBUG
fprintf (stderr, "old_bss_index %d\n", old_bss_index);
fprintf (stderr, "old_bss_addr %x\n", old_bss_addr);
fprintf (stderr, "old_bss_size %x\n", old_bss_size);
fprintf (stderr, "new_bss_addr %x\n", new_bss_addr);
fprintf (stderr, "new_data2_addr %x\n", new_data2_addr);
fprintf (stderr, "new_data2_size %x\n", new_data2_size);
fprintf (stderr, "new_data2_offset %x\n", new_data2_offset);
#endif
if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size)
fatal (".bss shrank when undumping???\n", 0, 0);
/* Set the output file to the right size. Allocate a buffer to hold
the image of the new file. Set pointers to various interesting
objects. stat_buf still has old_file data. */
new_file = open (new_name, O_RDWR | O_CREAT, 0666);
if (new_file < 0)
fatal ("Can't creat (%s): errno %d\n", new_name, errno);
new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size;
if (ftruncate (new_file, new_file_size))
fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno);
new_base = mmap (NULL, new_file_size, PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE, mmap_fd, 0);
if (new_base == MAP_FAILED)
fatal ("Can't allocate buffer for %s\n", old_name, 0);
new_file_h = (ElfW(Ehdr) *) new_base;
new_program_h = (ElfW(Phdr) *) ((byte *) new_base + old_file_h->e_phoff);
new_section_h = (ElfW(Shdr) *)
((byte *) new_base + old_file_h->e_shoff + new_data2_size);
/* Make our new file, program and section headers as copies of the
originals. */
memcpy (new_file_h, old_file_h, old_file_h->e_ehsize);
memcpy (new_program_h, old_program_h,
old_file_h->e_phnum * old_file_h->e_phentsize);
/* Modify the e_shstrndx if necessary. */
PATCH_INDEX (new_file_h->e_shstrndx);
/* Fix up file header. We'll add one section. Section header is
further away now. */
new_file_h->e_shoff += new_data2_size;
new_file_h->e_shnum += 1;
#ifdef DEBUG
fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff);
fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum);
fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff);
fprintf (stderr, "New section count %d\n", new_file_h->e_shnum);
#endif
/* Fix up a new program header. Extend the writable data segment so
that the bss area is covered too. Find that segment by looking
for a segment that ends just before the .bss area. Make sure
that no segments are above the new .data2. Put a loop at the end
to adjust the offset and address of any segment that is above
data2, just in case we decide to allow this later. */
for (n = new_file_h->e_phnum - 1; n >= 0; n--)
{
/* Compute maximum of all requirements for alignment of section. */
ElfW(Word) alignment = (NEW_PROGRAM_H (n)).p_align;
if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment)
alignment = OLD_SECTION_H (old_bss_index).sh_addralign;
#ifdef __sgi
/* According to r02kar@x4u2.desy.de (Karsten Kuenne)
and oliva@gnu.org (Alexandre Oliva), on IRIX 5.2, we
always get "Program segment above .bss" when dumping
when the executable doesn't have an sbss section. */
if (old_sbss_index != -1)
#endif /* __sgi */
if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz
> (old_sbss_index == -1
? old_bss_addr
: round_up (old_bss_addr, alignment)))
fatal ("Program segment above .bss in %s\n", old_name, 0);
if (NEW_PROGRAM_H (n).p_type == PT_LOAD
&& (round_up ((NEW_PROGRAM_H (n)).p_vaddr
+ (NEW_PROGRAM_H (n)).p_filesz,
alignment)
== round_up (old_bss_addr, alignment)))
break;
}
if (n < 0)
fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0);
/* Make sure that the size includes any padding before the old .bss
section. */
NEW_PROGRAM_H (n).p_filesz = new_bss_addr - NEW_PROGRAM_H (n).p_vaddr;
NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz;
#if 0 /* Maybe allow section after data2 - does this ever happen? */
for (n = new_file_h->e_phnum - 1; n >= 0; n--)
{
if (NEW_PROGRAM_H (n).p_vaddr
&& NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr)
NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size;
if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset)
NEW_PROGRAM_H (n).p_offset += new_data2_size;
}
#endif
/* Fix up section headers based on new .data2 section. Any section
whose offset or virtual address is after the new .data2 section
gets its value adjusted. .bss size becomes zero and new address
is set. data2 section header gets added by copying the existing
.data header and modifying the offset, address and size. */
for (old_data_index = 1; old_data_index < (int) old_file_h->e_shnum;
old_data_index++)
if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name,
".data"))
break;
if (old_data_index == old_file_h->e_shnum)
fatal ("Can't find .data in %s.\n", old_name, 0);
/* Walk through all section headers, insert the new data2 section right
before the new bss section. */
for (n = 1, nn = 1; n < (int) old_file_h->e_shnum; n++, nn++)
{
caddr_t src;
/* If it is (s)bss section, insert the new data2 section before it. */
/* new_data2_index is the index of either old_sbss or old_bss, that was
chosen as a section for new_data2. */
if (n == new_data2_index)
{
/* Steal the data section header for this data2 section. */
memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index),
new_file_h->e_shentsize);
NEW_SECTION_H (nn).sh_addr = new_data2_addr;
NEW_SECTION_H (nn).sh_offset = new_data2_offset;
NEW_SECTION_H (nn).sh_size = new_data2_size;
/* Use the bss section's alignment. This will assure that the
new data2 section always be placed in the same spot as the old
bss section by any other application. */
NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign;
/* Now copy over what we have in the memory now. */
memcpy (NEW_SECTION_H (nn).sh_offset + new_base,
(caddr_t) OLD_SECTION_H (n).sh_addr,
new_data2_size);
nn++;
}
memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n),
old_file_h->e_shentsize);
if (n == old_bss_index
/* The new bss and sbss section's size is zero, and its file offset
and virtual address should be off by NEW_DATA2_SIZE. */
|| n == old_sbss_index
)
{
/* NN should be `old_s?bss_index + 1' at this point. */
NEW_SECTION_H (nn).sh_offset =
NEW_SECTION_H (new_data2_index).sh_offset + new_data2_size;
NEW_SECTION_H (nn).sh_addr =
NEW_SECTION_H (new_data2_index).sh_addr + new_data2_size;
/* Let the new bss section address alignment be the same as the
section address alignment followed the old bss section, so
this section will be placed in exactly the same place. */
NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign;
NEW_SECTION_H (nn).sh_size = 0;
}
else
{
/* Any section that was originally placed after the .bss
section should now be off by NEW_DATA2_SIZE. If a
section overlaps the .bss section, consider it to be
placed after the .bss section. Overlap can occur if the
section just before .bss has less-strict alignment; this
was observed between .symtab and .bss on Solaris 2.5.1
(sparc) with GCC snapshot 960602. */
#ifdef SOLARIS_POWERPC
/* On PPC Reference Platform running Solaris 2.5.1
the plt section is also of type NOBI like the bss section.
(not really stored) and therefore sections after the bss
section start at the plt offset. The plt section is always
the one just before the bss section.
It would be better to put the new data section before
the .plt section, or use libelf instead.
Erik Deumens, deumens@qtp.ufl.edu. */
if (NEW_SECTION_H (nn).sh_offset
>= OLD_SECTION_H (old_bss_index-1).sh_offset)
NEW_SECTION_H (nn).sh_offset += new_data2_size;
#else
if (NEW_SECTION_H (nn).sh_offset + NEW_SECTION_H (nn).sh_size
> new_data2_offset)
NEW_SECTION_H (nn).sh_offset += new_data2_size;
#endif
/* Any section that was originally placed after the section
header table should now be off by the size of one section
header table entry. */
if (NEW_SECTION_H (nn).sh_offset > new_file_h->e_shoff)
NEW_SECTION_H (nn).sh_offset += new_file_h->e_shentsize;
}
/* If any section hdr refers to the section after the new .data
section, make it refer to next one because we have inserted
a new section in between. */
PATCH_INDEX (NEW_SECTION_H (nn).sh_link);
/* For symbol tables, info is a symbol table index,
so don't change it. */
if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB
&& NEW_SECTION_H (nn).sh_type != SHT_DYNSYM)
PATCH_INDEX (NEW_SECTION_H (nn).sh_info);
if (old_sbss_index != -1)
if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".sbss"))
{
NEW_SECTION_H (nn).sh_offset =
round_up (NEW_SECTION_H (nn).sh_offset,
NEW_SECTION_H (nn).sh_addralign);
NEW_SECTION_H (nn).sh_type = SHT_PROGBITS;
}
/* Now, start to copy the content of sections. */
if (NEW_SECTION_H (nn).sh_type == SHT_NULL
|| NEW_SECTION_H (nn).sh_type == SHT_NOBITS)
continue;
/* Write out the sections. .data and .data1 (and data2, called
".data" in the strings table) get copied from the current process
instead of the old file. */
if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data")
|| !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
".sdata")
|| !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
".lit4")
|| !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
".lit8")
/* The conditional bit below was in Oliva's original code
(1999-08-25) and seems to have been dropped by mistake
subsequently. It prevents a crash at startup under X in
`IRIX64 6.5 6.5.17m', whether compiled on that relase or
an earlier one. It causes no trouble on the other ELF
platforms I could test (Irix 6.5.15m, Solaris 8, Debian
Potato x86, Debian Woody SPARC); however, it's reported
to cause crashes under some version of GNU/Linux. It's
not yet clear what's changed in that Irix version to
cause the problem, or why the fix sometimes fails under
GNU/Linux. There's probably no good reason to have
something Irix-specific here, but this will have to do
for now. IRIX6_5 is the most specific macro we have to
test. -- fx 2002-10-01
The issue _looks_ as though it's gone away on 6.5.18m,
but maybe it's still lurking, to be triggered by some
change in the binary. It appears to concern the dynamic
loader, but I never got anywhere with an SGI support call
seeking clues. -- fx 2002-11-29. */
#ifdef IRIX6_5
|| !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
".got")
#endif
|| !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
".sdata1")
|| !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
".data1")
|| !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
".sbss"))
src = (caddr_t) OLD_SECTION_H (n).sh_addr;
else
src = old_base + OLD_SECTION_H (n).sh_offset;
memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src,
NEW_SECTION_H (nn).sh_size);
#ifdef __alpha__
/* Update Alpha COFF symbol table: */
if (strcmp (old_section_names + OLD_SECTION_H (n).sh_name, ".mdebug")
== 0)
{
pHDRR symhdr = (pHDRR) (NEW_SECTION_H (nn).sh_offset + new_base);
symhdr->cbLineOffset += new_data2_size;
symhdr->cbDnOffset += new_data2_size;
symhdr->cbPdOffset += new_data2_size;
symhdr->cbSymOffset += new_data2_size;
symhdr->cbOptOffset += new_data2_size;
symhdr->cbAuxOffset += new_data2_size;
symhdr->cbSsOffset += new_data2_size;
symhdr->cbSsExtOffset += new_data2_size;
symhdr->cbFdOffset += new_data2_size;
symhdr->cbRfdOffset += new_data2_size;
symhdr->cbExtOffset += new_data2_size;
}
#endif /* __alpha__ */
#if defined (__sony_news) && defined (_SYSTYPE_SYSV)
if (NEW_SECTION_H (nn).sh_type == SHT_MIPS_DEBUG
&& old_mdebug_index != -1)
{
int diff = NEW_SECTION_H(nn).sh_offset
- OLD_SECTION_H(old_mdebug_index).sh_offset;
HDRR *phdr = (HDRR *)(NEW_SECTION_H (nn).sh_offset + new_base);
if (diff)
{
phdr->cbLineOffset += diff;
phdr->cbDnOffset += diff;
phdr->cbPdOffset += diff;
phdr->cbSymOffset += diff;
phdr->cbOptOffset += diff;
phdr->cbAuxOffset += diff;
phdr->cbSsOffset += diff;
phdr->cbSsExtOffset += diff;
phdr->cbFdOffset += diff;
phdr->cbRfdOffset += diff;
phdr->cbExtOffset += diff;
}
}
#endif /* __sony_news && _SYSTYPE_SYSV */
#if __sgi
/* Adjust the HDRR offsets in .mdebug and copy the
line data if it's in its usual 'hole' in the object.
Makes the new file debuggable with dbx.
patches up two problems: the absolute file offsets
in the HDRR record of .mdebug (see /usr/include/syms.h), and
the ld bug that gets the line table in a hole in the
elf file rather than in the .mdebug section proper.
David Anderson. davea@sgi.com Jan 16,1994. */
if (n == old_mdebug_index)
{
#define MDEBUGADJUST(__ct,__fileaddr) \
if (n_phdrr->__ct > 0) \
{ \
n_phdrr->__fileaddr += movement; \
}
HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset);
HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset);
unsigned movement = new_data2_size;
MDEBUGADJUST (idnMax, cbDnOffset);
MDEBUGADJUST (ipdMax, cbPdOffset);
MDEBUGADJUST (isymMax, cbSymOffset);
MDEBUGADJUST (ioptMax, cbOptOffset);
MDEBUGADJUST (iauxMax, cbAuxOffset);
MDEBUGADJUST (issMax, cbSsOffset);
MDEBUGADJUST (issExtMax, cbSsExtOffset);
MDEBUGADJUST (ifdMax, cbFdOffset);
MDEBUGADJUST (crfd, cbRfdOffset);
MDEBUGADJUST (iextMax, cbExtOffset);
/* The Line Section, being possible off in a hole of the object,
requires special handling. */
if (n_phdrr->cbLine > 0)
{
if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset
+ OLD_SECTION_H (n).sh_size))
{
/* line data is in a hole in elf. do special copy and adjust
for this ld mistake.
*/
n_phdrr->cbLineOffset += movement;
memcpy (n_phdrr->cbLineOffset + new_base,
o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine);
}
else
{
/* somehow line data is in .mdebug as it is supposed to be. */
MDEBUGADJUST (cbLine, cbLineOffset);
}
}
}
#endif /* __sgi */
/* If it is the symbol table, its st_shndx field needs to be patched. */
if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB
|| NEW_SECTION_H (nn).sh_type == SHT_DYNSYM)
{
ElfW(Shdr) *spt = &NEW_SECTION_H (nn);
unsigned int num = spt->sh_size / spt->sh_entsize;
ElfW(Sym) * sym = (ElfW(Sym) *) (NEW_SECTION_H (nn).sh_offset +
new_base);
for (; num--; sym++)
{
if ((sym->st_shndx == SHN_UNDEF)
|| (sym->st_shndx == SHN_ABS)
|| (sym->st_shndx == SHN_COMMON))
continue;
PATCH_INDEX (sym->st_shndx);
}
}
}
/* Update the symbol values of _edata and _end. */
for (n = new_file_h->e_shnum - 1; n; n--)
{
byte *symnames;
ElfW(Sym) *symp, *symendp;
if (NEW_SECTION_H (n).sh_type != SHT_DYNSYM
&& NEW_SECTION_H (n).sh_type != SHT_SYMTAB)
continue;
symnames = ((byte *) new_base
+ NEW_SECTION_H (NEW_SECTION_H (n).sh_link).sh_offset);
symp = (ElfW(Sym) *) (NEW_SECTION_H (n).sh_offset + new_base);
symendp = (ElfW(Sym) *) ((byte *)symp + NEW_SECTION_H (n).sh_size);
for (; symp < symendp; symp ++)
if (strcmp ((char *) (symnames + symp->st_name), "_end") == 0
|| strcmp ((char *) (symnames + symp->st_name), "end") == 0
|| strcmp ((char *) (symnames + symp->st_name), "_edata") == 0
|| strcmp ((char *) (symnames + symp->st_name), "edata") == 0)
memcpy (&symp->st_value, &new_bss_addr, sizeof (new_bss_addr));
}
/* This loop seeks out relocation sections for the data section, so
that it can undo relocations performed by the runtime linker. */
for (n = new_file_h->e_shnum - 1; n; n--)
{
ElfW(Shdr) section = NEW_SECTION_H (n);
/* Cause a compilation error if anyone uses n instead of nn below. */
struct {int a;} n;
(void)n.a; /* Prevent `unused variable' warnings. */
switch (section.sh_type)
{
default:
break;
case SHT_REL:
case SHT_RELA:
/* This code handles two different size structs, but there should
be no harm in that provided that r_offset is always the first
member. */
nn = section.sh_info;
if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data")
|| !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
".sdata")
|| !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
".lit4")
|| !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
".lit8")
#ifdef IRIX6_5 /* see above */
|| !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
".got")
#endif
|| !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
".sdata1")
|| !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
".data1"))
{
ElfW(Addr) offset = (NEW_SECTION_H (nn).sh_addr
- NEW_SECTION_H (nn).sh_offset);
caddr_t reloc = old_base + section.sh_offset, end;
for (end = reloc + section.sh_size; reloc < end;
reloc += section.sh_entsize)
{
ElfW(Addr) addr = ((ElfW(Rel) *) reloc)->r_offset - offset;
#ifdef __alpha__
/* The Alpha ELF binutils currently have a bug that
sometimes results in relocs that contain all
zeroes. Work around this for now... */
if (((ElfW(Rel) *) reloc)->r_offset == 0)
continue;
#endif
memcpy (new_base + addr, old_base + addr, sizeof(ElfW(Addr)));
}
}
break;
}
}
/* Write out new_file, and free the buffers. */
if (write (new_file, new_base, new_file_size) != new_file_size)
#ifndef emacs
fatal ("Didn't write %d bytes: errno %d\n",
new_file_size, errno);
#else
fatal ("Didn't write %d bytes to %s: errno %d\n",
new_file_size, new_base, errno);
#endif
munmap (old_base, old_file_size);
munmap (new_base, new_file_size);
/* Close the files and make the new file executable. */
#if MAP_ANON == 0
close (mmap_fd);
#endif
if (close (old_file))
fatal ("Can't close (%s): errno %d\n", old_name, errno);
if (close (new_file))
fatal ("Can't close (%s): errno %d\n", new_name, errno);
if (stat (new_name, &stat_buf) == -1)
fatal ("Can't stat (%s): errno %d\n", new_name, errno);
n = umask (777);
umask (n);
stat_buf.st_mode |= 0111 & ~n;
if (chmod (new_name, stat_buf.st_mode) == -1)
fatal ("Can't chmod (%s): errno %d\n", new_name, errno);
}
/* arch-tag: e02e1512-95e2-4ef0-bba7-b6bce658f1e3
(do not change this comment) */
scm-5e5/pi.scm 0000644 0017052 0001750 00000012000 10750212465 011141 0 ustar tb tb ;;;; "pi.scm" Programs for computing digits of PI and e.
;; Copyright (C) 1991, 1993, 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
;; .
;;; Authors: Aubrey Jaffer & Jerry D. Hedden
;;; (pi ) prints out digits of pi in groups of digits.
;;; 'Spigot' algorithm origionally due to Stanly Rabinowitz.
;;; This algorithm takes time proportional to the square of /.
;;; This fact can make comparisons of computational speed between systems
;;; of vastly differring performances quicker and more accurate.
;;; Try (pi 100 5)
;;; The digit size will have to be reduced for larger or an
;;; overflow error will occur (on systems lacking bignums).
;;; It your Scheme has bignums try (pi 1000).
(define (pi n . args)
(if (null? args) (bigpi n)
(let* ((d (car args))
(r (do ((s 1 (* 10 s))
(i d (- i 1)))
((zero? i) s)))
(n (+ (quotient n d) 1))
(m (quotient (* n d 3322) 1000))
(a (make-vector (+ 1 m) 2)))
(vector-set! a m 4)
(do ((j 1 (+ 1 j))
(q 0 0)
(b 2 (remainder q r)))
((> j n))
(do ((k m (- k 1)))
((zero? k))
(set! q (+ q (* (vector-ref a k) r)))
(let ((t (+ 1 (* 2 k))))
(vector-set! a k (remainder q t))
(set! q (* k (quotient q t)))))
(let ((s (number->string (+ b (quotient q r)))))
(do ((l (string-length s) (+ 1 l)))
((>= l d) (display s))
(display #\0)))
(if (zero? (modulo j 10)) (newline) (display #\ )))
(newline))))
;;; (pi ) prints out digits of pi.
;;; 'Spigot' algorithm originally due to Stanly Rabinowitz:
;;;
;;; PI = 2+(1/3)*(2+(2/5)*(2+(3/7)*(2+ ... *(2+(k/(2k+1))*(4)) ... )))
;;;
;;; where 'k' is approximately equal to the desired precision of 'n'
;;; places times 'log2(10)'.
;;;
;;; This version takes advantage of "bignums" in SCM to compute all
;;; of the requested digits in one pass! Basically, it calculates
;;; the truncated portion of (PI * 10^n), and then displays it in a
;;; nice format.
(define (bigpi digits)
(let* ((n (* 10 (quotient (+ digits 9) 10))) ; digits in multiples of 10
(z (inexact->exact (truncate ; z = number of terms
(/ (* n (log 10)) (log 2)))))
(q (do ((x 2 (* 10000000000 x)) ; q = 2 * 10^n
(i (/ n 10) (- i 1)))
((zero? i) x)))
(_pi (number->string ; _pi = PI * 10^n
;; do the calculations in one pass!!!
(let pi_calc ((j z) (k (+ z z 1)) (p (+ q q)))
(if (zero? j)
p
(pi_calc (- j 1) (- k 2) (+ q (quotient (* p j) k))))))))
;; print out the result ("3." followed by 5 groups of 10 digits per line)
(display (substring _pi 0 1)) (display #\.) (newline)
(do ((i 0 (+ i 10)))
((>= i n))
(display (substring _pi (+ i 1) (+ i 11)))
(display (if (zero? (modulo (+ i 10) 50)) #\newline #\ )))
(if (not (zero? (modulo n 50))) (newline))))
;;; (e ) prints out digits of 'e'.
;;; Uses the formula:
;;;
;;; 1 1 1 1 1
;;; e = 1 + -- + -- + -- + -- + ... + --
;;; 1! 2! 3! 4! k!
;;;
;;; where 'k' is determined using the desired precision 'n' in:
;;;
;;; n < ((k * (ln(k) - 1)) / ln(10))
;;;
;;; which uses Stirling's formula for approximating ln(k!)
;;;
;;; This program takes advantage of "bignums" in SCM to compute all
;;; the requested digits at once! Basically, it calculates the
;;; fractional part of 'e' (i.e., e-2) as a fraction of two bignums
;;; 'e_n' and 'e_d', determines the integer part of (e_n * 10^n)/e_d,
;;; and then displays it in a nice format.
(define (e digits)
(let* ((n (* 10 (quotient (+ digits 9) 10))) ; digits in multiples of 10
(k (do ((i 15 (+ i 1))) ; k = number of terms
((< n (/ (* i (- (log i) 1)) (log 10))) i)))
(q (do ((x 1 (* 10000000000 x)) ; q = 10^n
(i (/ n 10) (- i 1)))
((zero? i) x)))
(_e (let ((ee
; do calculations
(let e_calc ((i k) (e_d 1) (e_n 0))
(if (= i 1)
(cons (* q e_n) e_d)
(e_calc (- i 1) (* e_d i) (+ e_n e_d))))))
(number->string (+ (quotient (car ee) (cdr ee))
; rounding
(if (< (remainder (car ee) (cdr ee))
(quotient (cdr ee) 2))
0 1))))))
;; print out the result ("2." followed by 5 groups of 10 digits per line)
(display "2.") (newline)
(do ((i 0 (+ i 10)))
((>= i n))
(display (substring _e i (+ i 10)))
(display (if (zero? (modulo (+ i 10) 50)) #\newline #\ )))
(if (not (zero? (modulo n 50))) (newline))))
scm-5e5/turtle 0000644 0017052 0001750 00000002463 05267114342 011305 0 ustar tb tb #define turtle_width 40
#define turtle_height 40
static char turtle_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80,
0xff, 0x00, 0x00, 0x00, 0xe0, 0x84, 0x07, 0x00, 0x00, 0x10, 0x0c, 0x78,
0x00, 0x00, 0x0c, 0x08, 0xc0, 0x00, 0x00, 0x02, 0x18, 0x40, 0x03, 0x00,
0x01, 0x28, 0x40, 0x02, 0x80, 0x0f, 0xcc, 0x7f, 0x02, 0xc0, 0xf8, 0x07,
0x10, 0x06, 0x40, 0x00, 0x04, 0x30, 0x0c, 0x60, 0x00, 0x04, 0x7c, 0x08,
0xf8, 0x00, 0x04, 0xc2, 0x0f, 0x8c, 0x01, 0x0f, 0x01, 0x0b, 0x26, 0x01,
0xf1, 0x01, 0x11, 0x03, 0x81, 0x01, 0x81, 0x20, 0x07, 0x83, 0x80, 0x80,
0x40, 0x9a, 0x83, 0x00, 0x8f, 0xf8, 0x42, 0xc6, 0xff, 0xe3, 0x0f, 0x7e,
0x63, 0x18, 0x22, 0x00, 0xc0, 0x31, 0xf0, 0x13, 0x00, 0x00, 0x11, 0x00,
0x11, 0x00, 0x00, 0x0f, 0x00, 0x1b, 0x00, 0x00, 0x06, 0x00, 0x0e, 0x0e,
0x00, 0x00, 0x00, 0x80, 0x09, 0x00, 0x00, 0x00, 0xc0, 0x88, 0x00, 0x00,
0x00, 0x00, 0xff, 0x00, 0x00, 0x02, 0x00, 0x08, 0x00, 0x00, 0x05, 0x38,
0x08, 0x00, 0x80, 0x08, 0x44, 0x08, 0x00, 0x40, 0x04, 0x44, 0x08, 0x00,
0x20, 0x02, 0x48, 0x04, 0x00, 0x10, 0x01, 0x70, 0x06, 0x00, 0x88, 0x00,
0xc0, 0x01, 0x00, 0x44, 0x00, 0x40, 0x00, 0x00, 0x22, 0x0e, 0x40, 0x00,
0x00, 0x11, 0x0a, 0x40, 0x00, 0x00, 0x09, 0x0c, 0x40, 0x00, 0x80, 0x06,
0x3e, 0x20, 0x00, 0x80, 0xf1, 0xc1, 0x1f, 0x00};
scm-5e5/compile.scm 0000755 0017052 0001750 00000006230 10750210226 012165 0 ustar tb tb #! /bin/sh
:;exec scm -e"(set! *script* \"$0\")" -f$0 "$@"
;;;; "compile.scm", Compile C ==> Scheme ==> object-file.
;; Copyright (C) 1992-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.
(require-if 'compiling 'hobbit)
(require-if 'compiling 'filename)
(require-if 'compiling 'build)
(define (compile.scm args)
(cond ((and (<= 1 (length args))
(not (eqv? #\- (string-ref (car args) 0))))
(apply compile-file args))
(else (compile.usage))))
(define (compile.usage)
(display "\
\
Usage: compile.scm FILE1.scm FILE2.scm ...
\
Compiles Scheme FILE1.scm FILE2.scm ... to an object file named
FILE1, where is the object file suffix
for your computer (for instance, `.o'). FILE1.scm must be in the
current directory; FILE2.scm ... can be in other directories.
http://swiss.csail.mit.edu/~jaffer/SCM
"
(current-error-port))
#f)
;;; This unusual autoload loads either the
;;; source or compiled version if present.
(if (not (defined? hobbit)) ;Autoload for hobbit
(define (hobbit . args)
(require 'hobbit)
(apply hobbit args)))
(define (find-option-file file)
(let ((opt file))
(if (file-exists? opt)
(list "-f" opt)
'())))
;@
(define (compile-file file . args)
(define sfs (scheme-file-suffix))
(require 'filename)
(apply hobbit file args)
(let ((command
(apply list
"build"
"-hsystem"
"-tdll"
(string-append "--compiler-options=-I" (implementation-vicinity))
"-c" (replace-suffix file sfs ".c")
(find-option-file (replace-suffix file sfs ".opt")))))
(require 'build)
(cond ((>= (verbose) 3) (write command) (newline)))
(build-from-whole-argv command)))
;@
(define (compile->executable exename . files)
(define sfs (scheme-file-suffix))
(require 'filename)
(for-each hobbit files)
(let ((inits (map (lambda (file)
(string-append "-iinit_" (replace-suffix file sfs "")))
files))
(files (map (lambda (file)
(string-append "-c" (replace-suffix file sfs ".c")))
files)))
(define command (append (list "build"
"-hsystem"
"--type=exe"
"-o" exename
"-F" "compiled-closure" "inexact"
(string-append "--linker-options=-L"
(implementation-vicinity)))
(find-option-file (string-append exename ".opt"))
files
inits))
(require 'build)
(cond ((>= (verbose) 3) (write command) (newline)))
(build-from-whole-argv command)))
;;; Local Variables:
;;; mode:scheme
;;; End:
(and *script* (exit (compile.scm (list-tail *argv* *optind*))))
scm-5e5/scm.nsi 0000644 0017052 0001750 00000032502 10751113535 011332 0 ustar tb tb ; Install SCM on Windows for current user
; Basic script generated by the HM NIS Edit Script Wizard.
; Augmented by Jerry van Dijk, february 2007
; placed in the public domain
; *** version numbers ***
!define PRODUCT_VERSION "5e5-1"
!define REQ_SLIB_VERSION "3b1-1"
; ----------------[ NO CHANGES BELOW ]----------------
; *** unless files are added or removed ***
; *** remember to edit both 'file' and 'delete' sections!
; *** registry settings ***
!define KEY_VERSION "version"
!define SCM_KEY "Software\Voluntocracy\scm"
!define SLIB_KEY "Software\Voluntocracy\slib"
; HM NIS Edit Wizard helper defines
!define PRODUCT_NAME "SCM"
!define PRODUCT_COMPANY "Voluntocracy"
!define PRODUCT_PUBLISHER "Aubrey Jaffer"
!define PRODUCT_WEB_SITE "http://swissnet.ai.mit.edu/~jaffer/SCM.html"
!define PRODUCT_DIR_REGKEY "Software\Microsoft\Windows\CurrentVersion\App Paths\scm-${PRODUCT_VERSION}.exe"
!define PRODUCT_UNINST_KEY "Software\Microsoft\Windows\CurrentVersion\Uninstall\${PRODUCT_NAME}"
!define PRODUCT_UNINST_ROOT_KEY "HKLM"
!define PRODUCT_STARTMENU_REGVAL "NSIS:StartMenuDir"
; MUI 1.67 compatible ------
!include "MUI.nsh"
; MUI Settings
!define MUI_ABORTWARNING
!define MUI_ICON "SCM.ico"
!define MUI_UNICON "${NSISDIR}\Contrib\Graphics\Icons\modern-uninstall.ico"
; Welcome page
!insertmacro MUI_PAGE_WELCOME
; License page
!insertmacro MUI_PAGE_LICENSE "COPYING"
; Directory page
!insertmacro MUI_PAGE_DIRECTORY
; Start menu page
var ICONS_GROUP
!define MUI_STARTMENUPAGE_NODISABLE
!define MUI_STARTMENUPAGE_DEFAULTFOLDER "scm"
!define MUI_STARTMENUPAGE_REGISTRY_ROOT "${PRODUCT_UNINST_ROOT_KEY}"
!define MUI_STARTMENUPAGE_REGISTRY_KEY "${PRODUCT_UNINST_KEY}"
!define MUI_STARTMENUPAGE_REGISTRY_VALUENAME "${PRODUCT_STARTMENU_REGVAL}"
!insertmacro MUI_PAGE_STARTMENU Application $ICONS_GROUP
; Instfiles page
!insertmacro MUI_PAGE_INSTFILES
; Finish page
!insertmacro MUI_PAGE_FINISH
; Uninstaller pages
!insertmacro MUI_UNPAGE_INSTFILES
; Language files
!insertmacro MUI_LANGUAGE "English"
; MUI end ------
Name "${PRODUCT_NAME} ${PRODUCT_VERSION}"
OutFile "scm-${PRODUCT_VERSION}.exe"
InstallDir "$PROGRAMFILES\scm"
InstallDirRegKey ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_DIR_REGKEY}" ""
ShowInstDetails show
ShowUnInstDetails show
; Check that the correct slib is installed, and no other scm version is present
Function .onInit
; Check that slib is installed
ClearErrors
ReadRegStr $0 ${PRODUCT_UNINST_ROOT_KEY} "${SLIB_KEY}" "${KEY_VERSION}"
IfErrors 0 +3
MessageBox MB_OK|MB_ICONSTOP "No SLIB found. Please install SLIB before installing SCM."
Abort
; Check that the correct slib is installed
StrCmp $0 ${REQ_SLIB_VERSION} +3 0
MessageBox MB_OK|MB_ICONSTOP "Found SLIB version $0. SCM ${PRODUCT_VERSION} requires SLIB ${REQ_SLIB_VERSION}. Please install this SLIB version first."
Abort
; Check for older scm installed
ReadRegStr $0 ${PRODUCT_UNINST_ROOT_KEY} "${SCM_KEY}" "${KEY_VERSION}"
StrCmp $0 '' +4 0
StrCmp $0 ${PRODUCT_VERSION} +3 0
MessageBox MB_OK|MB_ICONSTOP "You already have SCM version $0 installed. Please uninstall this SCM first."
Abort
FunctionEnd
Section "MainSection" SEC01
SetOutPath "$INSTDIR"
SetOverwrite try
File "scm.exe"
File "scm.html"
File "SCM.ico"
File "Init5e5.scm"
File "Transcen.scm"
File "mkimpcat.scm"
File "hobbit.scm"
File "scmhob.scm"
File "hobbit.html"
File "wbtab.scm"
File "rwb-isam.scm"
File "r4rstest.scm"
File "pi.scm"
; Shortcuts
!insertmacro MUI_STARTMENU_WRITE_BEGIN Application
CreateShortCut "$DESKTOP\SCM.lnk" "$INSTDIR\scm.exe" "" "$INSTDIR\SCM.ico"
CreateDirectory "$SMPROGRAMS\$ICONS_GROUP"
CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\SCM Manual.lnk" "$INSTDIR\scm.html"
CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\SCM.lnk" "$INSTDIR\scm.exe" "" "$INSTDIR\SCM.ico"
CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\Hobbit Manual.lnk" "$INSTDIR\hobbit.html"
!insertmacro MUI_STARTMENU_WRITE_END
; Jaffer scm registry settings
WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${SCM_KEY}" "${KEY_VERSION}" "${PRODUCT_VERSION}"
; Jaffer scm path settings
Push "$INSTDIR\"
Call AddToPath
SectionEnd
Section -AdditionalIcons
!insertmacro MUI_STARTMENU_WRITE_BEGIN Application
WriteIniStr "$INSTDIR\${PRODUCT_NAME}.url" "InternetShortcut" "URL" "${PRODUCT_WEB_SITE}"
CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\Website.lnk" "$INSTDIR\${PRODUCT_NAME}.url"
CreateShortCut "$SMPROGRAMS\$ICONS_GROUP\Uninstall.lnk" "$INSTDIR\uninst.exe"
!insertmacro MUI_STARTMENU_WRITE_END
SectionEnd
Section -Post
WriteUninstaller "$INSTDIR\uninst.exe"
WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_DIR_REGKEY}" "" "$INSTDIR\scm-${PRODUCT_VERSION}.exe"
WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "DisplayName" "$(^Name)"
WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "UninstallString" "$INSTDIR\uninst.exe"
WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "DisplayIcon" "$INSTDIR\scm-${PRODUCT_VERSION}.exe"
WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "DisplayVersion" "${PRODUCT_VERSION}"
WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "URLInfoAbout" "${PRODUCT_WEB_SITE}"
WriteRegStr ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}" "Publisher" "${PRODUCT_PUBLISHER}"
SectionEnd
Function .onInstSuccess
IfRebootFlag 0 noreboot
MessageBox MB_YESNO|MB_ICONQUESTION|MB_DEFBUTTON1 "A reboot is required to finish the installation. Do you wish to reboot now?" IDNO noreboot
Reboot
noreboot:
FunctionEnd
Function un.onUninstSuccess
HideWindow
MessageBox MB_ICONINFORMATION|MB_OK "$(^Name) was successfully removed from your computer."
FunctionEnd
Function un.onInit
MessageBox MB_ICONQUESTION|MB_YESNO|MB_DEFBUTTON2 "Are you sure you want to completely remove $(^Name) and all of its components?" IDYES +2
Abort
FunctionEnd
Section Uninstall
!insertmacro MUI_STARTMENU_GETFOLDER "Application" $ICONS_GROUP
Delete "$INSTDIR\${PRODUCT_NAME}.url"
Delete "$INSTDIR\uninst.exe"
Delete "$INSTDIR\pi.scm"
Delete "$INSTDIR\r4rstest.scm"
Delete "$INSTDIR\rwb-isam.scm"
Delete "$INSTDIR\wbtab.scm"
Delete "$INSTDIR\hobbit.html"
Delete "$INSTDIR\scmhob.scm"
Delete "$INSTDIR\hobbit.scm"
Delete "$INSTDIR\mkimpcat.scm"
Delete "$INSTDIR\Transcen.scm"
Delete "$INSTDIR\Init5e5.scm"
Delete "$INSTDIR\SCM.ico"
Delete "$INSTDIR\scm.html"
Delete "$INSTDIR\scm.exe"
Delete "$INSTDIR\scmlit.exe"
Delete "$INSTDIR\implcat"
Delete "$INSTDIR\slibcat"
Delete "$INSTDIR\tmp1"
Delete "$INSTDIR\tmp2"
Delete "$INSTDIR\tmp3"
Delete "$SMPROGRAMS\$ICONS_GROUP\Uninstall.lnk"
Delete "$SMPROGRAMS\$ICONS_GROUP\Website.lnk"
Delete "$SMPROGRAMS\$ICONS_GROUP\SCM.lnk"
Delete "$SMPROGRAMS\$ICONS_GROUP\SCM Manual.lnk"
Delete "$SMPROGRAMS\$ICONS_GROUP\Hobbit Manual.lnk"
Delete "$DESKTOP\SCM.lnk"
RMDir "$SMPROGRAMS\$ICONS_GROUP"
RMDir "$INSTDIR"
# remove from the path
Push "$INSTDIR\"
Call un.RemoveFromPath
; remove Jaffer registry entries
DeleteRegKey ${PRODUCT_UNINST_ROOT_KEY} "${SCM_KEY}"
DeleteRegKey ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_UNINST_KEY}"
DeleteRegKey ${PRODUCT_UNINST_ROOT_KEY} "${PRODUCT_DIR_REGKEY}"
SetAutoClose true
SectionEnd
; ----------------[ ENVIRONMENT MANIPULATION ]----------------
!ifndef WriteEnvStr_RegKey
!ifdef ALL_USERS
!define WriteEnvStr_RegKey \
'HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"'
!else
!define WriteEnvStr_RegKey 'HKCU "Environment"'
!endif
!endif
; ----------------[ EXECUTABLE PATH MANIPULATION ]----------------
; AddToPath - Adds the given dir to the search path.
; Input - head of the stack
; Note - Win9x systems requires reboot
Function AddToPath
Exch $0
Push $1
Push $2
Push $3
# don't add if the path doesn't exist
IfFileExists "$0\*.*" "" AddToPath_done
ReadEnvStr $1 PATH
Push "$1;"
Push "$0;"
Call StrStr
Pop $2
StrCmp $2 "" "" AddToPath_done
Push "$1;"
Push "$0\;"
Call StrStr
Pop $2
StrCmp $2 "" "" AddToPath_done
GetFullPathName /SHORT $3 $0
Push "$1;"
Push "$3;"
Call StrStr
Pop $2
StrCmp $2 "" "" AddToPath_done
Push "$1;"
Push "$3\;"
Call StrStr
Pop $2
StrCmp $2 "" "" AddToPath_done
Call IsNT
Pop $1
StrCmp $1 1 AddToPath_NT
; Not on NT
StrCpy $1 $WINDIR 2
FileOpen $1 "$1\autoexec.bat" a
FileSeek $1 -1 END
FileReadByte $1 $2
IntCmp $2 26 0 +2 +2 # DOS EOF
FileSeek $1 -1 END # write over EOF
FileWrite $1 "$\r$\nSET PATH=%PATH%;$3$\r$\n"
FileClose $1
SetRebootFlag true
Goto AddToPath_done
AddToPath_NT:
ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH"
StrCmp $1 "" AddToPath_NTdoIt
Push $1
Call Trim
Pop $1
StrCpy $0 "$1;$0"
AddToPath_NTdoIt:
WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $0
SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000
AddToPath_done:
Pop $3
Pop $2
Pop $1
Pop $0
FunctionEnd
; RemoveFromPath - Remove a given dir from the path
; Input: head of the stack
Function un.RemoveFromPath
Exch $0
Push $1
Push $2
Push $3
Push $4
Push $5
Push $6
IntFmt $6 "%c" 26 # DOS EOF
Call un.IsNT
Pop $1
StrCmp $1 1 unRemoveFromPath_NT
; Not on NT
StrCpy $1 $WINDIR 2
FileOpen $1 "$1\autoexec.bat" r
GetTempFileName $4
FileOpen $2 $4 w
GetFullPathName /SHORT $0 $0
StrCpy $0 "SET PATH=%PATH%;$0"
Goto unRemoveFromPath_dosLoop
unRemoveFromPath_dosLoop:
FileRead $1 $3
StrCpy $5 $3 1 -1 # read last char
StrCmp $5 $6 0 +2 # if DOS EOF
StrCpy $3 $3 -1 # remove DOS EOF so we can compare
StrCmp $3 "$0$\r$\n" unRemoveFromPath_dosLoopRemoveLine
StrCmp $3 "$0$\n" unRemoveFromPath_dosLoopRemoveLine
StrCmp $3 "$0" unRemoveFromPath_dosLoopRemoveLine
StrCmp $3 "" unRemoveFromPath_dosLoopEnd
FileWrite $2 $3
Goto unRemoveFromPath_dosLoop
unRemoveFromPath_dosLoopRemoveLine:
SetRebootFlag true
Goto unRemoveFromPath_dosLoop
unRemoveFromPath_dosLoopEnd:
FileClose $2
FileClose $1
StrCpy $1 $WINDIR 2
Delete "$1\autoexec.bat"
CopyFiles /SILENT $4 "$1\autoexec.bat"
Delete $4
Goto unRemoveFromPath_done
unRemoveFromPath_NT:
ReadRegStr $1 ${WriteEnvStr_RegKey} "PATH"
StrCpy $5 $1 1 -1 # copy last char
StrCmp $5 ";" +2 # if last char != ;
StrCpy $1 "$1;" # append ;
Push $1
Push "$0;"
Call un.StrStr ; Find `$0;` in $1
Pop $2 ; pos of our dir
StrCmp $2 "" unRemoveFromPath_done
; else, it is in path
# $0 - path to add
# $1 - path var
StrLen $3 "$0;"
StrLen $4 $2
StrCpy $5 $1 -$4 # $5 is now the part before the path to remove
StrCpy $6 $2 "" $3 # $6 is now the part after the path to remove
StrCpy $3 $5$6
StrCpy $5 $3 1 -1 # copy last char
StrCmp $5 ";" 0 +2 # if last char == ;
StrCpy $3 $3 -1 # remove last char
WriteRegExpandStr ${WriteEnvStr_RegKey} "PATH" $3
SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=5000
unRemoveFromPath_done:
Pop $6
Pop $5
Pop $4
Pop $3
Pop $2
Pop $1
Pop $0
FunctionEnd
; ----------------[ OS TYPE DETERMINATION ]----------------
#
# [un.]IsNT - Pushes 1 if running on NT, 0 if not
#
# Example:
# Call IsNT
# Pop $0
# StrCmp $0 1 +3
# MessageBox MB_OK "Not running on NT!"
# Goto +2
# MessageBox MB_OK "Running on NT!"
#
!macro IsNT UN
Function ${UN}IsNT
Push $0
ReadRegStr $0 HKLM "SOFTWARE\Microsoft\Windows NT\CurrentVersion" CurrentVersion
StrCmp $0 "" 0 IsNT_yes
; we are not NT.
Pop $0
Push 0
Return
IsNT_yes:
; NT!!!
Pop $0
Push 1
FunctionEnd
!macroend
!insertmacro IsNT ""
!insertmacro IsNT "un."
; ----------------[ STRING MANIPULATION ]----------------
; StrStr
; input, top of stack = string to search for
; top of stack-1 = string to search in
; output, top of stack (replaces with the portion of the string remaining)
; modifies no other variables.
;
; Usage:
; Push "this is a long ass string"
; Push "ass"
; Call StrStr
; Pop $R0
; ($R0 at this point is "ass string")
!macro StrStr un
Function ${un}StrStr
Exch $R1 ; st=haystack,old$R1, $R1=needle
Exch ; st=old$R1,haystack
Exch $R2 ; st=old$R1,old$R2, $R2=haystack
Push $R3
Push $R4
Push $R5
StrLen $R3 $R1
StrCpy $R4 0
; $R1=needle
; $R2=haystack
; $R3=len(needle)
; $R4=cnt
; $R5=tmp
loop:
StrCpy $R5 $R2 $R3 $R4
StrCmp $R5 $R1 done
StrCmp $R5 "" done
IntOp $R4 $R4 + 1
Goto loop
done:
StrCpy $R1 $R2 "" $R4
Pop $R5
Pop $R4
Pop $R3
Pop $R2
Exch $R1
FunctionEnd
!macroend
!insertmacro StrStr ""
!insertmacro StrStr "un."
Function Trim ; Added by Pelaca
Exch $R1
Push $R2
Loop:
StrCpy $R2 "$R1" 1 -1
StrCmp "$R2" " " RTrim
StrCmp "$R2" "$\n" RTrim
StrCmp "$R2" "$\r" RTrim
StrCmp "$R2" ";" RTrim
GoTo Done
RTrim:
StrCpy $R1 "$R1" -1
Goto Loop
Done:
Pop $R2
Exch $R1
FunctionEnd
scm-5e5/grtest.scm 0000644 0017052 0001750 00000003430 05702353536 012056 0 ustar tb tb
; This is a quick hack to test the graphics primitives.
; The SLIB scheme library is needed for random.
; IMHO, the syntax of `do' in scheme is horrible!
; - sjm
(define (grtest)
(require 'random) ; needs SLIB
(graphics-mode!)
(display "testing draw-to") (newline)
(clear-graphics!)
(goto-center!)
(do ((x 0 (+ x 3)))
((> x (max-x)) 0)
(set-color! (remainder (/ x 3) (max-color)))
(draw-to x 0)
(draw-to x (max-y))
)
(do ((y 0 (+ y 3)))
((> y (max-y)) 0)
(set-color! (remainder (/ y 3) (max-color)))
(goto-center!)
(draw-to! 0 y)
(goto-center!)
(draw-to! (max-x) y)
)
(goto-nw!)
(do ((x 0 (+ x 2)))
((> x (max-x)) 0)
(set-color! (remainder (/ x 2) (max-color)))
(draw-to x (max-y))
)
(do ((y (+ (max-y) 1) (- y 2)))
((< y 0) 0)
(set-color! (remainder (/ y 2) (max-color)))
(draw-to (max-x) y)
)
(display "testing set-dot!") (newline)
(clear-graphics!)
(do ((x 0 (+ x 1)))
((= x 100) 0)
(set-dot! (+ (random (max-x)) 1) (+ (random (max-y)) 1)
(+ (random (max-color)) 1))
)
(display "testing draw with turn-to!") (newline)
(clear-graphics!)
(goto-center!)
(do ((x 0 (+ x 1)))
((= x 100) 0)
(set-color! (+ (random (max-color)) 1))
(turn-to! (random 360))
(draw (random 50))
)
(display "testing draw with turn-right") (newline)
(clear-graphics!)
(goto-center!)
(do ((x 0 (+ x 1)))
((= x 100) 0)
(set-color! (+ (random (max-color)) 1))
(turn-right (random 90))
(draw (random 50))
)
(display "testing draw with turn-left") (newline)
(clear-graphics!)
(goto-center!)
(do ((x 0 (+ x 1)))
((= x 100) 0)
(set-color! (+ (random (max-color)) 1))
(turn-left (random 90))
(draw (random 50))
)
(text-mode!)
)
scm-5e5/QUICKREF 0000644 0017052 0001750 00000014722 06467700737 011214 0 ustar tb tb ;; FILE "Scheme Sigs"
;; IMPLEMENTS R^4RS Function Signature Synopsis
;; AUTHOR Kenneth A Dickey
;; DATE 1992 October 2
;; LAST UPDATED 1992 October 3
;; NOTES: Extracted from Amiga Gambit QuickTour file
=== FUNCTION SYNOPSIS ===
Notation: