scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Imported scheme48-0.53 sources as base

This commit is contained in:
marting 1999-09-14 12:45:00 +00:00
parent 606245fc41
commit 37210efdc5
374 changed files with 0 additions and 50641 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
build/build-external-modules
View File

@ -1,28 +0,0 @@
#!/bin/sh
# Build external-modules.c.
target="$1"
shift
(
cat <<!
!
for i in "s48_initialize_external" "$@"; do
cat <<!
extern void $i(void);
!
done
cat <<!
void s48_initialize_external_modules (void) {
!
for i in "s48_initialize_external" "$@"; do
cat <<!
$i();
!
done
cat <<!
};
!
) >"$target"

90
build/load-linker.exec
View File

@ -1,90 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Load the linker. -*- Mode: Scheme; -*-
; Run this script with ,exec ,load l.exec.
; After the script is loaded, you can, in principle, do whatever
; you might do in the usual linker image. For example, you might do
; (this is from the Makefile)
;
; ,in link-config
; (load-configuration "interfaces.scm")
; (load-configuration "packages.scm")
; (flatload initial-structures)
; (load "initial.scm")
; (link-initial-system)
;
; This is intended to be used to debug new versions of the compiler or
; static linker.
(config '(run (define :arguments :values))) ;temporary hack
(translate "=scheme48/" "./")
(load-package 'flatloading)
(open 'flatloading)
(define (r x) (config `(run ,x)))
(r '(define-structure source-file-names (export (%file-name% :syntax))
(open scheme-level-1
syntactic
fluids)
(begin (define-syntax %file-name%
(syntax-rules ()
((%file-name%) (fluid $source-file-name)))))))
(r '(define-structure enumerated enumerated-interface
(open scheme-level-1 signals)
(files (rts defenum scm))))
(r '(define-structure architecture architecture-interface
(open scheme-level-1 signals enumerated)
(files (rts arch))))
(config '(structure reflective-tower-maker
(export-reflective-tower-maker)))
; Make the new linker obtain its table, record, etc. structures from
; the currently running Scheme.
(config '(load "packages.scm"))
(config '(structure %run-time-structures run-time-structures-interface))
(config '(structure %features-structures features-structures-interface))
(r
'(define-structure %linker-structures
(make-linker-structures %run-time-structures
%features-structures
(make-compiler-structures %run-time-structures
%features-structures))))
; Load the linker's interface and structure definitions.
(config '(load "interfaces.scm" "more-interfaces.scm"))
(let ((z (config '(run %linker-structures)))
(env (config interaction-environment)))
(config (lambda () (flatload z env))))
; Load the linker.
(load-package 'link-config)
; Initialize
(in 'link-config
'(open scheme packages packages-internal
reflective-tower-maker))
(in 'linker '(run (set! *debug-linker?* #t)))
(in 'link-config '(open flatloading)) ; A different one.
; ,open debuginfo packages-internal compiler scan syntactic meta-types
; (in 'link-config '(dump "l.image"))
; ,exec (usual-stuff)
(define (usual-stuff)
(in 'link-config)
(run '(begin (load-configuration "interfaces.scm")
(load-configuration "packages.scm")
(flatload initial-structures)))
(load "initial.scm"))

82
build/lucid-script.lisp
View File

@ -1,82 +0,0 @@
; Script to load the Scheme 48 linker into Common Lisp.
; Requires Pseudoscheme 2.11.
(defvar pseudoscheme-directory "../pseudo/")
(load (concatenate 'string pseudoscheme-directory "loadit.lisp"))
; or perhaps (load (merge-pathnames "loadit.lisp" pseudoscheme-directory))
(load-pseudoscheme pseudoscheme-directory)
(progn (revised^4-scheme::define-sharp-macro #\.
#'(lambda (c port)
(read-char port)
(eval (let ((*readtable* ps::scheme-readtable))
(read port)))))
(values))
(ps:scheme)
;--------------------
; Scheme forms
(benchmark-mode)
(define config-env ; (interaction-environment) would also work here.
(#.'scheme-translator:make-program-env
'%config
(list #.'scheme-translator:revised^4-scheme-structure)))
(load "bcomp/module-language" config-env)
(load "alt/config" config-env)
(load "env/flatload" config-env)
(eval '(set! *load-file-type* #f) config-env)
(define load-config
(let ((load-config (eval 'load-configuration config-env)))
(lambda (filename)
(load-config filename config-env))))
(load-config "packages")
(define flatload-package (eval 'flatload config-env))
(flatload-package (eval 'linker-structures config-env) config-env)
(let ((#.'clever-load:*compile-if-necessary-p* #t))
(let ((#.'ps:*scheme-read* #.'#'ps::scheme-read-using-commonlisp-reader))
(load "alt/pseudoscheme-record")
(load "alt/pseudoscheme-features")))
(let ((#.'clever-load:*compile-if-necessary-p* #t))
(flatload-package (eval 'link-config config-env)))
(load "alt/init-defpackage.scm")
(define-syntax struct-list ;not in link.sbin
(syntax-rules ()
((struct-list ?name ...) (list (cons '?name ?name) ...))))
;--------------------
(quit)
#+Lucid
(defun disksave-restart-function ()
(format t "~&Scheme 48 linker.~2%")
;; (hax:init-interrupt-delivery) - for threads
(ps:scheme)
(terpri))
#+Lucid
(defun dump-linker ()
(lcl:disksave "link/linker-in-lucid" :gc t :full-gc t :verbose t
:restart-function #'disksave-restart-function))
;(dump-linker)
;(lcl:quit)
; Debugging hacks
;(defun enable-lisp-packages ()
; (setq *readtable* ps:scheme-readtable)
; (values))
;(defun disable-lisp-packages ()
; (setq *readtable* ps::roadblock-readtable)
; (values))

236
c/extension.c
View File

@ -1,236 +0,0 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
/* Implementation of the vm-extension opcode. This is completely
optional; nothing in the standard system uses these features.
If you have ANSI C but not POSIX support, try compiling with -DPOSIX=0.
The vm-extension opcode is being phased out. New code should use the
external-call opcode to call C procedures.
floating point: POSIX.1, ANSI C (should we be linking with -lM or -lm?)
sprintf: POSIX.1, ANSI C
atof: POSIX.1, ANSI C
*/
#ifndef POSIX
# define POSIX 2
#endif
#include <stdio.h>
#include "sysdep.h"
#include "scheme48.h"
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include <signal.h>
#include <unistd.h> /* setuid & setgid */
#include <errno.h>
#include <netdb.h> /* gethostbyname */ /* Kali code */
#include <sys/types.h>
#include <sys/wait.h>
#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)
#define LEAST_FIXNUM_VALUE (-1 << 29)
#define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
#define FOR_INPUT 1
#define FOR_OUTPUT 2
typedef struct {
char b[sizeof(double)];
} unaligned_double;
typedef union {
double f;
unaligned_double b;
} float_or_bytes;
extern long s48_Sextension_valueS; /* how values are returned */
/* return status values */
#define EXT_ST_OKAY 0
#define EXT_ST_EXCEPTION 1
#define EXT_RETURN(value) {s48_Sextension_valueS = (value); return EXT_ST_OKAY; }
#define EXT_EXCEPTION return EXT_ST_EXCEPTION
/******************************************/
s48_value
s48_extended_vm (long key, s48_value value)
{
double x, y;
switch (key) {
/* Cases 0 through 19 are reserved for the mobot system. */
case 0: /* read jumpers on 68000 board */
EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(0));
/* Floating point */
#define FLOP 100
#define FLOP2(i) case FLOP+(i): \
if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 2) \
EXT_EXCEPTION;
#define FLOP3(i) case FLOP+(i): \
if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 3) \
EXT_EXCEPTION;
#define get_arg(args,i) S48_STOB_REF(args,(i))
#define get_string_arg(args,i) (S48_UNSAFE_EXTRACT_STRING(get_arg(args,i)))
#define get_float_arg(args, i, var) EXTRACT_FLOAT(get_arg(args, i), var)
#define set_float_arg(args, i, val) SET_FLOAT(get_arg(args, i), val)
#define EXTRACT_FLOAT(stob, var) \
{ s48_value temp_ = (stob); \
float_or_bytes loser_; \
if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
loser_.b = *(unaligned_double*)(&S48_STOB_REF(temp_, 0)); \
(var) = loser_.f; }
#define SET_FLOAT(stob, val) \
{ s48_value temp_ = (stob); \
float_or_bytes loser_; \
if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
loser_.f = (double)(val); \
*(unaligned_double*)(&S48_STOB_REF(temp_, 0)) = loser_.b; }
FLOP3(0) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
set_float_arg(value, 2, x + y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(1) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
set_float_arg(value, 2, x - y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(2) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
set_float_arg(value, 2, x * y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(3) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
if (y == 0.0) EXT_EXCEPTION;
set_float_arg(value, 2, x / y);
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(4) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
EXT_RETURN(S48_ENTER_BOOLEAN(x == y));}
FLOP2(5) {
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
EXT_RETURN(S48_ENTER_BOOLEAN(x < y));}
FLOP2(6) { /* fixnum->float */
s48_value arg = get_arg(value, 0);
if (!S48_FIXNUM_P(arg)) EXT_RETURN(S48_FALSE);
set_float_arg(value, 1, S48_UNSAFE_EXTRACT_FIXNUM(arg));
EXT_RETURN(S48_TRUE);}
FLOP2(7) { /* string->float */
char *str = get_string_arg(value, 0);
set_float_arg(value, 1, atof(str));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(8) { /* float->string */
size_t len;
char *str = get_string_arg(value,1);
get_float_arg(value, 0, x);
sprintf(str, "%g", x);
len = strlen(str);
if (len > S48_UNSAFE_STRING_LENGTH(get_arg(value,1)))
/* unlikely but catastrophic */
fprintf(stderr, "printing float: output too long: %s\n",
str);
EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(len));}
/* exp log sin cos tan asin acos atan sqrt */
FLOP2(9) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, exp(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(10) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, log(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(11) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, sin(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(12) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, cos(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(13) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, tan(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(14) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, asin(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(15) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, acos(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(16) { /* atan */
get_float_arg(value, 0, y);
get_float_arg(value, 1, x);
set_float_arg(value, 2, atan2(y, x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(17) {
get_float_arg(value, 0, x);
set_float_arg(value, 1, sqrt(x));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP2(18) { /* floor */
get_float_arg(value, 0, x);
set_float_arg(value, 1, floor(x));
EXT_RETURN(S48_UNSPECIFIC);}
case FLOP+19: { /* integer? */
EXTRACT_FLOAT(value, x);
EXT_RETURN(S48_ENTER_BOOLEAN(fmod(x, 1.0) == 0.0)); }
case FLOP+20: { /* float->fixnum */
EXTRACT_FLOAT(value, x);
if (x <= (double)GREATEST_FIXNUM_VALUE
&& x >= (double)LEAST_FIXNUM_VALUE)
{
EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM((long)x)); }
else
EXT_RETURN(S48_FALSE);}
FLOP3(21) { /* quotient */
double z;
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
if (y == 0.0) EXT_EXCEPTION;
z = x / y;
set_float_arg(value, 2, z < 0.0 ? ceil(z) : floor(z));
EXT_RETURN(S48_UNSPECIFIC);}
FLOP3(22) { /* remainder */
get_float_arg(value, 0, x);
get_float_arg(value, 1, y);
if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
if (y == 0.0) EXT_EXCEPTION;
/* "fmod(double x, double y) returns the floating-point remainder
(f) of the division of x by y, where f has the same sign as x,
such that x=iy+f for some integer i, and |f| < |y|." */
set_float_arg(value, 2, fmod(x, y));
EXT_RETURN(S48_UNSPECIFIC);}
default:
EXT_EXCEPTION;
}
}

43
c/fake/libdl2.c
View File

@ -1,43 +0,0 @@
/*
* This is a fake version of the dynamic loading library for machines
* which don't have it, and don't even have an nlist.
* We fake it so that everything fails.
*/
#include "sysdep.h"
static char *lasterror;
char *
dlerror(void)
{
char *res;
res = lasterror;
lasterror = NULL;
return (res);
}
void *
dlopen(char *name, int flags)
{
lasterror = "Dynamic loading not supported on this machine";
return (NULL);
}
int
dlclose(void *lib)
{
return (0);
}
void *
dlsym(void *lib, char *name)
{
lasterror = "Dynamic loading not supported on this machine";
return (NULL);
}

15
c/fake/sigact.h
View File

@ -1,15 +0,0 @@
/*
* If we don't have sigaction, we fake it using signal.
*/
#if ! defined(HAVE_SIGACTION)
struct sigaction {
void (*sa_handler)();
int sa_mask;
int sa_flags;
};
#define sigaction(sig, act, oact) signal((sig), (act)->sa_handler)
#define sigemptyset(ign) 0
#endif

22
c/fake/strerror.c
View File

@ -1,22 +0,0 @@
/*
* If the system doesn't have a strerror procedure, we provide our own.
* Note, this depends on sys_nerr and sys_errlist being provided.
* If your system doesn't provide that either, you can replace this
* procedure with one that always returns "Unknown error".
*/
#include "sysdep.h"
extern int sys_nerr;
extern char *sys_errlist[];
char *
strerror(int errnum)
{
if ((0 <= errnum)
&& (errnum < sys_nerr))
return (sys_errlist[errnum]);
else
return ("Unknown error");
}

8
c/fake/strerror.h
View File

@ -1,8 +0,0 @@
/*
* If we don't have strerror(), we fake it using sys_nerr and sys_errlist.
*/
#if ! defined(HAVE_STRERROR)
extern char *strerror(int errnum);
#endif

9
c/fake/sys-select.h
View File

@ -1,9 +0,0 @@
/*
* If we have a sys/select.h, then include it.
*/
#if defined(HAVE_SYS_SELECT_H)
#include <sys/types.h>
#include <sys/select.h>
#endif

12
c/io.h
View File

@ -1,12 +0,0 @@
extern FILE *ps_open_input_file(char *, long *);
extern FILE *ps_open_output_file(char *, long *);
extern long ps_close(FILE *);
extern char ps_read_char(FILE *, char *, long *, char);
extern long ps_read_integer(FILE *, char *, long *);
extern long ps_write_char(char, FILE *);
extern long ps_write_integer(long, FILE *);
extern long ps_write_string(char *, FILE *);
extern long ps_read_block(FILE *, char *, long, char *, long *);
extern long ps_write_block(FILE *, char *, long);
extern char *ps_error_string(long);
extern void ps_error(char *, long count, ...);

110
c/old-scheme48.h
View File

@ -1,110 +0,0 @@
typedef long scheme_value;
#define FIXNUM_TAG 0
#define FIXNUMP(x) (((long)(x) & 3L) == FIXNUM_TAG)
#define IMMEDIATE_TAG 1
#define IMMEDIATEP(x) (((long)(x) & 3L) == IMMEDIATE_TAG)
#define HEADER_TAG 2
#define HEADERP(x) (((long)(x) & 3L) == HEADER_TAG)
#define STOB_TAG 3
#define STOBP(x) (((long)(x) & 3L) == STOB_TAG)
#define ENTER_FIXNUM(n) ((scheme_value)((n) << 2))
#define EXTRACT_FIXNUM(x) ((long)(x) >> 2)
#define MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))
#define SCHFALSE MISC_IMMEDIATE(0)
#define SCHTRUE MISC_IMMEDIATE(1)
#define SCHCHAR MISC_IMMEDIATE(2)
#define SCHUNSPECIFIC MISC_IMMEDIATE(3)
#define SCHUNDEFINED MISC_IMMEDIATE(4)
#define SCHEOF MISC_IMMEDIATE(5)
#define SCHNULL MISC_IMMEDIATE(6)
#define UNDEFINED SCHUNDEFINED
#define UNSPECIFIC SCHUNSPECIFIC
#define ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)
#define EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)
#define ENTER_CHAR(c) (SCHCHAR | ((c) << 8))
#define EXTRACT_CHAR(x) ((x) >> 8)
#define CHARP(x) ((((long) (x)) & 0xff) == SCHCHAR)
#define ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))
#define STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])
#define STOB_TYPE(x) ((STOB_HEADER(x)>>2)&31)
#define STOB_HEADER(x) (STOB_REF((x),-1))
#define STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)
#define STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)
#define STOBTYPE_PAIR 0
#define PAIRP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PAIR))
#define STOBTYPE_SYMBOL 1
#define SYMBOLP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SYMBOL))
#define STOBTYPE_VECTOR 2
#define VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_VECTOR))
#define STOBTYPE_CLOSURE 3
#define CLOSUREP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CLOSURE))
#define STOBTYPE_LOCATION 4
#define LOCATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_LOCATION))
#define STOBTYPE_CHANNEL 5
#define CHANNELP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CHANNEL))
#define STOBTYPE_PORT 6
#define PORTP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PORT))
#define STOBTYPE_RATNUM 7
#define RATNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RATNUM))
#define STOBTYPE_RECORD 8
#define RECORDP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RECORD))
#define STOBTYPE_CONTINUATION 9
#define CONTINUATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CONTINUATION))
#define STOBTYPE_EXTENDED_NUMBER 10
#define EXTENDED_NUMBERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_EXTENDED_NUMBER))
#define STOBTYPE_TEMPLATE 11
#define TEMPLATEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_TEMPLATE))
#define STOBTYPE_WEAK_POINTER 12
#define WEAK_POINTERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_WEAK_POINTER))
#define STOBTYPE_SHARED_BINDING 13
#define SHARED_BINDINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SHARED_BINDING))
#define STOBTYPE_UNUSED_D_HEADER1 14
#define UNUSED_D_HEADER1P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER1))
#define STOBTYPE_UNUSED_D_HEADER2 15
#define UNUSED_D_HEADER2P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER2))
#define STOBTYPE_STRING 16
#define STRINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_STRING))
#define STOBTYPE_CODE_VECTOR 17
#define CODE_VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CODE_VECTOR))
#define STOBTYPE_DOUBLE 18
#define DOUBLEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_DOUBLE))
#define STOBTYPE_BIGNUM 19
#define BIGNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_BIGNUM))
#define CAR(x) STOB_REF(x, 0)
#define CDR(x) STOB_REF(x, 1)
#define SYMBOL_TO_STRING(x) STOB_REF(x, 0)
#define LOCATION_ID(x) STOB_REF(x, 0)
#define CONTENTS(x) STOB_REF(x, 1)
#define CLOSURE_TEMPLATE(x) STOB_REF(x, 0)
#define CLOSURE_ENV(x) STOB_REF(x, 1)
#define WEAK_POINTER_REF(x) STOB_REF(x, 0)
#define SHARED_BINDING_NAME(x) STOB_REF(x, 0)
#define SHARED_BINDING_IS_IMPORTP(x) STOB_REF(x, 1)
#define SHARED_BINDING_REF(x) STOB_REF(x, 2)
#define PORT_HANDLER(x) STOB_REF(x, 0)
#define PORT_STATUS(x) STOB_REF(x, 1)
#define PORT_LOCK(x) STOB_REF(x, 2)
#define PORT_LOCKEDP(x) STOB_REF(x, 3)
#define PORT_DATA(x) STOB_REF(x, 4)
#define PORT_BUFFER(x) STOB_REF(x, 5)
#define PORT_INDEX(x) STOB_REF(x, 6)
#define PORT_LIMIT(x) STOB_REF(x, 7)
#define PORT_PENDING_EOFP(x) STOB_REF(x, 8)
#define CHANNEL_STATUS(x) STOB_REF(x, 0)
#define CHANNEL_ID(x) STOB_REF(x, 1)
#define CHANNEL_OS_INDEX(x) STOB_REF(x, 2)
#define VECTOR_LENGTH(x) STOB_LLENGTH(x)
#define VECTOR_REF(x, i) STOB_REF(x, i)
#define CODE_VECTOR_LENGTH(x) STOB_BLENGTH(x)
#define CODE_VECTOR_REF(x, i) (ADDRESS_AFTER_HEADER(x, unsigned char)[i])
#define STRING_LENGTH(x) (STOB_BLENGTH(x)-1)
#define STRING_REF(x, i) (ADDRESS_AFTER_HEADER(x, char)[i])

59
c/prescheme.h
View File

@ -1,59 +0,0 @@
#include <errno.h>
#include "io.h"
#define PS_READ_CHAR(PORT,RESULT,EOFP,STATUS) \
{ \
FILE * TTport = PORT; \
int TTchar; \
if (EOF == (TTchar = getc(TTport))) \
RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==1);\
else { \
RESULT = TTchar; \
EOFP = 0; \
STATUS = 0; } \
}
#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS) \
{ \
FILE * TTport = PORT; \
int TTchar; \
if (EOF == (TTchar = getc(TTport))) \
RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==0);\
else { \
RESULT = TTchar; \
ungetc(RESULT, TTport); \
EOFP = 0; \
STATUS = 0; } \
}
#define PS_READ_INTEGER(PORT,RESULT,EOFP,STATUS) \
RESULT = ps_read_integer(PORT,&EOFP,&STATUS);
#define PS_WRITE_CHAR(CHAR,PORT,STATUS) \
{ \
FILE * TTport = PORT; \
char TTchar = CHAR; \
if (EOF == putc(TTchar,TTport)) \
STATUS = ps_write_char(TTchar,TTport); \
else { \
STATUS = 0; } \
}
/* C shifts may not work if the amount is greater than the machine word size */
/* Patched by JAR 6/6/93 */
#define PS_SHIFT_RIGHT(X,Y,RESULT) \
{ \
long TTx = X, TTy = Y; \
RESULT = TTy >= 32 ? (TTx < 0 ? -1 : 0) : TTx >> TTy; \
}
#define PS_SHIFT_LEFT(X,Y,RESULT) \
{ \
long TTy = Y; \
RESULT = TTy >= 32 ? 0 : X << TTy; \
}
extern long s48_return_value, s48_run_machine();

53
c/scheme48heap.h
View File

@ -1,53 +0,0 @@
/*
* Externally visible objects defined in scheme48heap.c.
*/
/* initialize top-level variables */
extern void s48_heap_init(void);
/* heap-init interface */
extern void s48_initialize_heap(long, long);
extern void s48_register_static_areas(unsigned char, long *, long *,
unsigned char, long *, long *);
/* heap interface */
extern long s48_available(void);
extern long s48_heap_size(void);
extern long s48_find_all(long);
extern long s48_find_all_records(long);
extern char *s48_ShpS;
extern char *s48_SlimitS;
/* gc interface */
extern void s48_begin_collection(void);
extern long s48_trace_value(long);
extern long s48_trace_locationsB(char *, char *);
extern long s48_trace_stob_contentsB(long);
extern void s48_do_gc(void);
extern void s48_end_collection(void);
extern char s48_extantP(long);
extern long s48_gc_count(void);
/* allocation interface */
extern char s48_availableP(long);
extern long s48_preallocate_space(long);
extern char *s48_allocate_space(long, long, long);
extern void s48_write_barrier(long, char *, long);
/* images interface */
extern char s48_image_writing_okayP(void);
extern long s48_write_image(long, FILE *);
extern long s48_check_image_header(unsigned char *);
extern long s48_read_image();
extern long s48_startup_procedure(void);
extern long s48_initial_symbols(void);
extern long s48_initial_imported_bindings(void);
extern long s48_initial_exported_bindings(void);
extern long s48_resumer_records(void);
extern long s48_undumpable_records(long *);
extern void s48_initialization_completeB(void);
extern void s48_initializing_gc_root(void);
extern void s48_set_image_valuesB(long, long, long, long);

40
c/unix/dynamo-test.c
View File

@ -1,40 +0,0 @@
/*
* A simple test file for dynamic loading, dynamic name lookup, and
* old-style external calls.
*/
#include <stdio.h>
#include "scheme48.h"
/*
* These should only be called on characters or other immediates.
*/
s48_value
s48_dynamo_test(s48_value arg0, s48_value arg1, s48_value arg2)
{
int i;
s48_value vector = s48_make_vector(3, S48_FALSE);
S48_VECTOR_SET(vector, 0, arg0);
S48_VECTOR_SET(vector, 1, arg1);
S48_VECTOR_SET(vector, 2, arg2);
return vector;
}
s48_value
s48_old_dynamo_test(long nargs, s48_value args[])
{
int i;
s48_value vector = s48_make_vector(nargs, S48_FALSE);
for (i = 0; i < nargs; i++)
S48_VECTOR_SET(vector, i, args[i]);
return vector;
}

129
c/unix/misc.c
View File

@ -1,129 +0,0 @@
/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
#include <stdio.h>
#include <stdlib.h> /* for getenv(), etc. (POSIX?/ANSI) */
#include <string.h> /* for strncpy(), etc. (POSIX/ANSI) */
#include <pwd.h> /* for getpwnam() (POSIX.1) */
#include <unistd.h> /* for sysconf(), etc. (POSIX.1/.2)*/
#include <errno.h>
#include "sysdep.h"
#define TRUE (0 == 0)
#define FALSE (0 == 1)
/*
Expanding Unix filenames
Unix Sucks
Richard Kelsey Wed Jan 17 21:40:26 EST 1990
Later modified by others who wish to remain anonymous
Expands initial ~ and ~/ in string `name', leaving the result in `buffer'.
`buffer_len' is the length of `buffer'.
Note: strncpy(x, y, n) copies from y to x.
*/
char *s48_expand_file_name (name, buffer, buffer_len)
char *name, *buffer;
int buffer_len;
{
#define USER_NAME_SIZE 256
char *dir, *p, user_name[USER_NAME_SIZE];
struct passwd *user_data;
int dir_len, i;
extern char *getenv();
int name_len = strlen(name);
dir = 0;
if (name[0] == '~') {
name++; name_len--;
if (name[0] == '/' || name[0] == 0) {
dir = getenv("HOME"); }
else {
for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
if (i > (USER_NAME_SIZE - 2)) {
fprintf(stderr,
"\ns48_expand_file_name: user name longer than %d characters\n",
USER_NAME_SIZE - 3);
return(NULL); };
strncpy(user_name, name, i);
user_name[i] = 0;
user_data = getpwnam(user_name);
if (!user_data) {
fprintf(stderr, "\ns48_expand_file_name: unknown user \"%s\"\n",
user_name);
return(NULL); };
name_len -= i;
name = p;
dir = user_data->pw_dir; } }
else if (name[0] == '$') {
name++; name_len--;
for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
if (i > (USER_NAME_SIZE - 2)) {
fprintf(stderr,
"\ns48_expand_file_name: environment variable longer than %d characters\n",
USER_NAME_SIZE - 3);
return(NULL); };
strncpy(user_name, name, i);
user_name[i] = 0;
name_len -= i;
name = p;
dir = getenv(user_name); }
if (dir) {
dir_len = strlen(dir);
if ((name_len + dir_len + 1) > buffer_len) {
fprintf(stderr, "\ns48_expand_file_name: supplied buffer is too small\n");
return(NULL); };
strncpy(buffer, dir, dir_len);
strncpy(buffer + dir_len, name, name_len);
buffer[name_len + dir_len] = 0; }
else {
if ((name_len + 1) > buffer_len) {
fprintf(stderr, "\ns48_expand_file_name: supplied buffer is too small\n");
return(NULL); };
strncpy(buffer, name, name_len);
buffer[name_len] = 0; }
return(buffer);
}
/* test routine
main(argc, argv)
int argc;
char *argv[];
{
char buffer[32];
s48_expand_file_name(argv[1], buffer, 32);
printf("%s\n", buffer);
return(0);
}
*/
/* Driver loop for tail-recursive calls */
long s48_return_value;
long
s48_run_machine(long (*proc) (void))
{
while (proc != 0)
proc = (long (*) (void)) (*proc)();
return s48_return_value;
}
unsigned char *
ps_error_string(long the_errno)
{
return((unsigned char *)strerror(the_errno));
}

12
c/unix/test.c
View File

@ -1,12 +0,0 @@
#include "c/scheme48.h"
long
frog(long arg_count, long *args)
{
long i, res;
for (i = 0, res = s48_enter_integer(-100); i < arg_count; res += args[i], i++);
return res;
}

2
c/write-barrier.h
View File

@ -1,2 +0,0 @@
#define S48_WRITE_BARRIER(stob, address, value) ((void)0)

290
doc/hacking.txt
View File

@ -1,290 +0,0 @@
,bench
,load-package linker
,new-package =link= linker debuginfo defpackage
,load scripts.scm
(link-initial-system)
To change between initial image starting in mini-command (MINI) and
command (MAXI):
1. Definition of initial system's command module in comp-packages.scm:
MINI: (make-mini-command scheme)
MAXI: (make-command scheme)
2. Location of (define-module (make-command ...)...):
MINI: more-packages.scm
MAXI: comp-packages.scm
3. Location of (define-interface command-interface ...):
MINI: more-interfaces.scm
MAXI: interfaces.scm
> ,new-package z architecture primitives packages table enumerated debug-data
z> (let ((i 0))
(table-walk (lambda (x y) (set! i (+ i 1)))
location-name-table)
i)
1385
z> (vector-length (find-all-xs (name->enumerand 'location stob)))
1259
(vector-length (find-all-xs (name->enumerand 'record stob)))
2150
(find-all-xs (name->enumerand 'record stob))
z> (do ((i 0 (+ i 1))
(j 0 (if (package? (vector-ref rs i)) (+ j 1) j))) ((= i (vector-length rs)) j))
72
z>
> ,new-package z architecture primitives compiler table
z> (vector-ref stob 10)
'template
z> stob
'#(pair symbol vector closure location port ratio record continuation extended-number template weak-pointer external unused-d-header1 unused-d-header2 string code-vector double bignum)
z> (vector-ref stob 7)
'record
z> (define rs (find-all-xs 7))
z> (vector-length rs)
2178
z> (define ls (find-all-xs 4))
z> (vector-length ls)
1266
z>
To get a fresh config package:
,in config (define-structures ((config1 (export)))
(open defpackage built-in-structures more-structures))
,config-package-is config1
To load a linker with a fresh new compiler:
x48 -i new-scheme48.image -h 10000000 <l.s48
Then ,load scripts.scm or whatever.
These are all files not belonging to any package description:
boot-packages.scm
comp-packages.scm
flatload.scm
more-packages.scm
more-interfaces.scm
rts-packages.scm
scripts.scm
interfaces.scm
infix/
debug/
alt/
link/p-features.scm
link/p-record.scm
link/t-features.scm
link/t-record.scm
misc/icon.scm
misc/mail.scm -- related to more-thread.scm
misc/more-thread.scm -- needs work
misc/sicp.scm -- add to more-packages
,load-package rk-extensions
,new-package rk-user rk-extensions
,user-package-is rk-user
# If initial images starts in mini-command instead of command, the
# rule for $(IMAGE) becomes something like this:
# (echo ,load more-interfaces.scm $(S48ROOT)/more-packages.scm; \
# echo "(ensure-loaded command)"; \
# echo ",go ((structure-ref command 'command-processor) batch)"; \
,in config (define-structures ((reification (export reify-structures)))
(open scheme-level-2 table
signals ;error
packages
features ;location-id location?
scan) ;find-free-names-in-syntax-rules
(files (link reify)))
,load-package reification
debug-config> ,in reification reify-structures
'#{Procedure 8447 reify-structures}
debug-config> (define reify-structures ##)
debug-config> make-simple-package
Error: undefined variable
make-simple-package
(package debug-config)
1 debug-config>
debug-config> (define-structures ((p (export start))) (open initial-system scheme-level-2 packages))
debug-config> (define go (in p `(start ,(reify-structures (desirable-packages) (lambda (loc) `',loc)))))
### Small images for exercising the linker and/or runtime system
debug/tiny.image: debug/tiny.scm $(LINKER_IMAGE)
($(START_LINKER_RUNNABLE) \
echo "(load \"debug/tiny-packages.scm\")"; \
echo "(link-simple-system '(debug tiny) 'start tiny-system)") \
| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE)
debug/little.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(little-files)
($(START_LINKER_RUNNABLE) \
echo "(load \"scripts.scm\")"; \
echo "(link-little-system)") \
| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP)
debug/medium.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(medium-files)
($(START_LINKER_RUNNABLE) \
echo "(load \"scripts.scm\")"; \
echo "(link-medium-system)") \
| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP)
echo "(define l-f (package-all-filenames little-system))"; \
echo "(define m-f (package-all-filenames medium-system))"; \
'little-files l-f 'medium-files m-f \
[The following is from June 1992, and probably not quite compatible
with the current compiler internals.]
To eliminate use of the stack GC to implement tail recursion, change
comp.scm as follows:
(define (compile-unknown-call exp cenv depth cont)
(note-source-code
exp
(maybe-push-continuation (sequentially
(push-all (cdr exp) cenv 0)
(compile (car exp)
cenv
(length (cdr exp))
(fall-through-cont))
(instruction (if (return-cont? cont)
op/move-args-and-call
op/call)
(length (cdr exp))))
depth
cont)))
--------------------
Here's another cool thing. 6/28/93
(define-interface evaluation-interface
(export eval load eval-from-file))
(define-structure run evaluation-interface
(open scheme-level-2 syntactic packages scan
environments
signals
locations
features ;force-output
table
fluids)
(files (debug run)))
,load-package run
,in run
,in package-commands (environment-for-syntax-promise)
(define cool (make-simple-package (list scheme) eval ## 'cool))
,in command set-environment-for-commands!
(## cool)
cool> ,inspect (lambda (x) x)
'#{Procedure 6394}
[0: exp] '(lambda (x) x)
[1: env] '#{Package 286 cool}
inspect:
inspect: q
cool>
(define (z s)
(define (show-type name static)
(write name)
(display " : ")
(write (static-type static))
(newline))
(if (package? s)
(for-each-definition (lambda (name static loc)
(show-type name static))
s)
(interface-walk (lambda (name type)
(show-type name
(car (structure-lookup
s name #t))))
(structure-interface s))))
; ,open expander syntactic packages reconstruction
(define (e x)
(let ((p (interaction-environment)))
(let ((node (expand-form x p)))
(write (node-type node (package->environment p)))
(newline)
(eval node p))))
> (define hunk3 (lap hunk3
0 (check-nargs= 3)
2 (pop)
3 (make-stored-object 3 0)
6 (return)))
> (hunk3 1 2 3)
'(1 . 2)
> (define cxr (lap cxr
0 (check-nargs= 2)
2 (pop)
3 (stored-object-indexed-ref 0)
5 (return)))
> (cxr (hunk3 1 2 3) 2)
3
>
(define-syntax %cons
(lambda (e r c)
(let ((n (cadr e))
(kind (caddr e)))
`(,(r 'lap) (%cons ,n ,kind)
(check-nargs= ,n)
(pop)
(make-stored-object ,n ,kind)
(return)))))
(define (& x)
(or (node-ref x 'uid)
(begin (set! *n* (+ *n* 1))
(node-set! x 'uid *n*)
*n*))
x)
(define (uid n) (node-ref (& n) 'uid))
(define *n* 0)

159
doc/install.txt
View File

@ -1,159 +0,0 @@
-*- Mode: Indented-text; -*-
Here are some remarks to complement what's in the INSTALL file.
-----
When running "make", don't worry if the ".notify" target fails. Its
only purpose is to send an email message to
scheme-48-notifications@martigny.ai.mit.edu, so that we can get a
rough idea of how much Scheme 48 is being used and by whom. We
promise not to use your name or email address for any commercial
purpose. If you don't want us to know, just do "make -t .notify"
first.
-----
Customizing the installation
1. If you don't believe in configure scripts, or don't have a
/bin/sh that can handle the configure script, you can make
sysdep.h and Makefile manually from sysdep.h.in and Makefile.in.
The technique is fairly obvious. For Makefile, just give
reasonable values for all of the variables at the top that are
defined as "foo = @foo@", e.g. srcdir=., CC=cc, LIBS=-lm,
INSTALL=cp, etc. For sysdep.h, read the comments. If your OS is
Posix compliant, you should be able to copy sysdep.h.in to
sysdep.h unmodified and everything should work.
2. If you definitely won't be installing Scheme 48, you should set
libdir to the distribution directory (e.g. "make libdir=`pwd`").
This will make the ,open and ,load-package commands work for the
library packages defined in more-packages.scm.
3. If desired, customize the contents of the development environment
heap image by editing the definitions of USUAL-COMMANDS and/or
USUAL-FEATURES in more-packages.scm; see below.
4. If you're using a DEC MIPS, and want to use the foreign function
interface, specify LDFLAGS=-N (with e.g. "make LDFLAGS=-N").
-----
Customizing scheme48.image
By default, the image consists of a core Scheme system (Revised^5
Scheme plus a very minimal read-eval-print loop) together with a
standard set of "options" (command processor, debugging commands,
inspector, disassembler, generic arithmetic). The set of options is
controlled by the definitions of USUAL-COMMANDS and USUAL-FEATURES in
more-packages.scm. If you make the (open ...) clause empty, then
"make scheme48.image" will create a Scheme system without any extras
(such as error recovery), and the image will be smaller. The files
are listed in approximate order of decreasing desirability; you'll
probably want at least these:
package-commands, build
- necessary for the scheme48.image script to work
debuginfo, disclosers
- necessary if you want error messages to be at all helpful
debugging
- defines important debugging commands such as ,preview and ,trace
After editing the definition of usual-features, simply
make scheme48.image
to rebuild the image.
-----
Deeper changes to the system -- for example, edits to most of the
files in the rts/ directory -- will require using the static linker to
make a new initial.image. After you have a working scheme48.image
(perhaps a previous version of Scheme 48), you can create a linker
image with
make linker
after which you can say
make image
to get the linker to build a new initial.image and initial.debug.
scheme48.image will then be built from those.
You might think that "make scheme48.image" ought to do this, but the
circular dependencies
scheme48.image on initial.image
initial.image on link/linker.image
link/linker.image on scheme48.image
needs to be broken somewhere, or else make will (justifiably) barf. I
chose to break the cycle by making scheme48.image not depend on
initial.image, since this is most robust for installation purposes.
-----
Editor support
We recommend interacting with the Scheme 48 command processor using the
emacs/scheme interface written by Olin Shivers at CMU. Copies of the
relevant .el files, together with a "cmuscheme48.el", are in the
emacs/ subdirectory of the release. Usage information is in
doc/user-guide.txt.
You will probably want to byte-compile the .el files to get .elc
files. Use M-x byte-compile-file to do this.
-----
Performance
If you don't have a C compiler that optimizes as well as gcc does,
then performance may suffer. Take a look at the automatically
generated code in scheme48vm.c to find out why. With a good register
allocator, all those variables (including some of the virtual
machine's virtual registers) get allocated to hardware registers, and
it really flies. Without one, performance can be pretty bad.
The configure script automatically sets the Makefile variable CFLAGS
to -O2 -g if gcc is available, or to -O if it isn't. This can be
overriden by specifying a different CFLAGS, e.g. "make CFLAGS=-g" for
no optimization.
Even if you do have a good compiler, you should be able to improve
overall performance even more, maybe about 6-10%, by removing the
range check from the interpreter's instruction dispatch. To do this,
use the -S flag to get assembly code for scheme48vm.c, then find the
instructions in scheme48vm.s corresponding to the big dispatch in
restart():
L19173: {
code_pointer_83X = arg1K0;
switch ((*((unsigned char *) code_pointer_83X))) {
... }
There will be one or two comparison instructions to see whether the
opcode is in range; just remove them. For the 68000 I use a "sed"
script
/cmpl #137,d0/ N
/cmpl #137,d0\n jhi L/ d
but of course the constant will probably have to change when a new
release comes along.
See the user's guide for information on the ,bench command, which
makes programs run faster.
-----
filenames.make is "include"d by the Makefile, but is automatically
generated from the module dependencies laid out in the various
configuration files (*-packages.scm). If you edit any of these .scm
files, you may want to do a "make filenames.make" before you do any
further "make"s in order to update the depedencies. This step isn't
necessary if you're using Gnu make, because Gnu make will make
included files automatically.

201
doc/io.txt
View File

@ -1,201 +0,0 @@
There are two types of I/O objects in Scheme 48, channels and ports.
Channels are the raw, unbuffered ports of the operating system. The
only I/O operations the VM supports for channels are block reads and
writes. Ports are the actual Scheme ports and are implemented in Scheme,
with some support from the VM for READ-CHAR, PEEK-CHAR, and WRITE-CHAR
for efficiency. The run-time system provides ports that are buffered
versions of channels. Other sorts of ports are in big/more-port.scm.
Source files:
rts/port.scm port operations and port handlers
rts/current-port.scm current-input-port, etc.
rts/channel.scm blocking on channels and handling i/o interrupts
rts/channel-port.scm ports that read and write to channels
rts/low.scm CHANNEL-READ and CHANNEL-WRITE
big/more-port.scm additional kinds of ports
vm/arch.scm fields of ports and channels
vm/prim-io.scm VM i/o opcodes
vm/vmio.scm implementation of channels
----------------------------------------------------------------
CHANNELS
The VM instructions that deal with channels are:
(OPEN-CHANNEL <spec> <mode>) -> channel
<mode> is a from the enumeration OPEN-CHANNEL-OPTION in arch.scm.
<spec> is either a filename (as a string) or an OS port (as a one-word
code-vector), depending on the mode.
(CLOSE-CHANNEL <channel>) -> unspecific
(CHANNEL-MAYBE-READ <string-or-code-vector> <start-index> <count> <wait?>
<channel>)
-> number of bytes read or the eof-object
(CHANNEL-MAYBE-WRITE <string-or-code-vector> <start-index> <count> <channel>)
-> number of bytes written
These read or write up to the specified number of characters or bytes
from or to the string or code-vector, with the first character or byte
going at <start-index>.
(CHANNEL-ABORT <channel>) -> number of bytes read or written or
the eof-object
This aborts any pending read or write operation on the channel. The return
value reflects any partial completion.
CHANNEL-MAYBE-READ and CHANNEL-MAYBE-WRITE do not block. If the read or
write cannot be completed immediately a PENDING-CHANNEL-I/O exception is
raised. It is then up to the run-time system to either wait or run some
other thread. The VM raises an I/O-COMPLETION interrupt whenever an i/o
operation completes.
Because CHANNEL-MAYBE-READ and CHANNEL-MAYBE-WRITE are awkward to use,
the RTS defines somewhat simpler versions:
(CHANNEL-READ <buffer> <start> <needed> <channel>)
-> number of bytes read or the eof-object
(CHANNEL-WRITE <buffer> <start> <count> <channel>)
-> unspecified
<Buffer> is either a string or code vector and <start> is the index of the
first character read or written. <Needed> is one of:
N > 0 : the call returns when this many characters has been read or
an EOF is reached.
'IMMEDIATE : the call reads as many characters as are available and
returns immediately.
'ANY : the call returns as soon as at least one character has been read
or an EOF is reached.
<Count> is the number of characters to be written. CHANNEL-READ will read
the requested number of characters unless an EOF is reached. CHANNEL-WRITE
will write the requested number of characters.
----------------------------------------------------------------
PORTS
Ports are actual Scheme port and are (usually) buffered. They are fully
exposed to the run-time system. The VM instructions on ports could be
implemented in Scheme; they are in the VM for efficiency. Buffers are
code-vectors (this is a micro-hack; strings have a slightly higher overhead
because of the null terminating byte for C compatibility) (code-vectors are
just vectors of bytes).
The fields of a port are:
PORT-STATUS: a bit set represented as a fixnum.
Indices into this bit set are from the PORT-STATUS-OPTIONS
enumeration in arch.scm. The current bits are: input, output,
open-for-input, open-for-output (the last two are for things like
sockets, on which you need to block but which do not support
normal reading or writing).
PORT-HANDLER: a record containing three procedures. These handle
printing the port, closing the port, and filling (for input ports)
or emptying (for output ports) buffers.
PORT-DATA: ?
Whatever stuff the handler needs.
PORT-LOCKED?, PORT-LOCK: used by the system to guarentee the atomicity
of i/o operations.
PORT-BUFFER: a code-vector. The input or output buffer of the port.
PORT-INDEX: a fixnum. The index of the next byte to read or written.
PORT-LIMIT: a fixnum. One past the end of the valid/available buffer space.
PORT-PENDING-EOF?: true if the next read to this port should return EOF.
Additional operations on ports:
(READ-BLOCK string-or-code-vector start count input-port)
Read COUNT bytes into STRING-OR-CODE-VECTOR starting at index START.
Returns the number of bytes read. Only an end-of-file will prevent
the requested number of bytes from being read.
(WRITE-STRING string output-port)
Write the characters in the string to the port.
(WRITE-BLOCK string-or-code-vector start count output-port)
The output counterpart to READ-BLOCK. This always writes out the
requested number of bytes. Its return value is unspecified.
(FORCE_OUTPUT output-port)
Causes any buffered characters to be written out.
(CURRENT-ERROR-PORT)
The current error port, analogous to Scheme's CURRENT-INPUT-PORT
and CURRENT-OUTPUT-PORT.
The system maintains a list of output ports whose buffers should be
periodically flushed. The default output port and ports made by
OPEN-OUTPUT-FILE are on this list. (PERIODICALLY-FORCE-OUTPUT! <output-port>)
may be used to add others.
----------------------------------------------------------------
PORT HANDLERS
Every port has a handler with three procedures. The first two are used
for printing and closing ports and have the same type for all ports:
(DISCLOSE port-data) -> disclose list
(CLOSE port-data) -> unspecific
For CLOSE, The system takes care of modifying the port's status.
The third procedure is used to fill and empty buffers. Its arguments
and return values depend on the kind of port:
Buffered output ports:
(BUFFER-PROC port-data buffer start-index byte-count) -> unspecific
BYTE-COUNT bytes should be copied from the buffer beginning at
START-INDEX. The buffer may be either a string or a code-vector.
Unbuffered output ports:
(BUFFER-PROC port-data char) -> unspecific
Write out the given character. The system uses this for the default
error port.
Input ports:
(BUFFER-PROC data buffer start-index needed-bytes)
-> EOF or number of bytes read (before an EOF)
Bytes should be copied into the buffer starting at START-INDEX. The
buffer may be either a string or a code-vector. NEEDED-BYTES is one of:
'IMMEDIATE
The call should return immediately after transfering whatever number
of bytes are currently available, possibly none (this is used for
CHAR-READY?). The maximum number of characters is determined by the
length of BUFFER.
'ANY
The call should wait until at least one byte is available or an EOF
occurs (used for READ-CHAR and PEEK-CHAR). The maximum number of
characters is determined by the length of BUFFER.
N > 0
The call should wait until N bytes have been copied into the buffer
or an EOF occurs. If the return value is less than NEEDED-BYTES the
port code inserts an EOF after the last byte.
----------------------------------------------------------------
Ports and the Virtual Machine
Ports could be implemented entirely in Scheme, with no support from
the VM. For efficiency reasons VM instructions are supplied for
three port operations:
(READ-CHAR <port>)
(PEEK-CHAR <port>)
(WRITE-CHAR <char> <port>)
For each of these, if there is sufficient data or space in the
appropriate buffer the VM performs the operation. Otherwise a
buffer-full/empty exception is raised and the exception handler
uses the buffer procedure from the port's handler to fill or
empty the buffer.

1090
doc/meeting.ps
View File

File diff suppressed because it is too large Load Diff

700
doc/news.txt
View File

@ -1,700 +0,0 @@
-*- Mode: Indented-text; -*-
Recent changes to Scheme 48.
2/24/99 (version 0.53)
Additions:
DEFINE-FINITE-TYPE and DEFINE-ENUMERATED-TYPE (in structure
FINITE-TYPES; documented in doc/utilities.ps and
doc/html/utilities.html.
Added CHAR-SOURCE->INPUT-PORT, CHAR-SINK->OUTPUT-PORT,
MAKE-STRING-OUTPUT-PORT, STRING-OUTPUT-SOURCE-OUTPUT to
the extended-ports structure.
The structure BYTE-VECTORS is the same as CODE-VECTORS with `byte'
replacing `code' in all the names. The underlying datatype is the
same for both, and uses `byte' when printing.
There is a new and much improved interface to C code, thanks to
Mike Sperber. It is documented in in doc/external.ps and
doc/html/external.html.
Bug fixes:
Session-data and user-context records are no longer in the fluid env.
Lexical environments can now be nested up to 65k deep.
,expand no longer prints `definition in expression context' warnings.
Added ARRAY? and SEARCH-TREE? to the array and search tree structures.
Flat environments work again.
Templates of the form `var ... ...' now work in syntax rules.
Reinstated caching of SCHEMIFY results to greatly reduce the space
used by debugging info.
Added argument checking to STRING->NUMBER and NUMBER->STRING.
Fixed space blow-up in LOAD.
Unused ports are closed more reliably.
Changes:
The heap, gc, and image code is now in three separate modules.
The symbol table is now held in a VM register.
Inlined SHOWING-FOCUS-VALUES into the main command loop and moved
the sentinal call to reduce the noise at the base of ,preview output.
The tables returned by MAKE-TABLE now use EQV? for comparison (instead
of EQ?). This makes these tables about 50% slower when numbers are
used as keys, but significantly more accurate.
Floating-point numbers are no longer double boxed.
The channels structure has been split into channels and low-channels.
7/22/98 (version 0.52)
Bug fixes:
Fixed problems with unbound variables in SET! and the inliner.
Made macro expansion a bit less eager; this should reduce the amount
of heap space needed for compilation.
6/29/98 (version 0.51)
Incompatible changes:
BIG-SCHEME no longer exports its version of DEFINE-RECORD-TYPE (but
it is available from the structure DEFRECORD). I am slowly removing
all uses of this version of DEFINE-RECORD-TYPE from the sources.
The version of DEFINE-RECORD-TYPE exported by DEFINE-RECORD-TYPES
checks that every constructor argument corresponds to a field.
Uses of LAP must list their free variables (see env/assem.scm).
Changes:
The functions exported by BIG-SCHEME that were not available elsewhere
are now exported by BIG-UTIL as well.
MAKE-RANDOM now checks its argument (but is still a fairly poor
source of pseudo-randomness).
SIGPIPE no longer kills the S48 process (this was done earlier but
not listed here).
The macro/module/compiler code has been reorganized. Hopefully
the only noticable difference is in the babble written when loading
files and packages.
Added CODE-QUOTE (in its own structure of the same name) for use
in writing hygienic macro-generating macros. CODE-QUOTE is the
same as QUOTE except that it does not strip off any of the macro
system's name annotations.
The FLOATNUMS package now exports FLOATNUM?.
Bug fixes:
Fixed phony stack-overflow bug.
Fixed a bug in thread time-debit mechanism.
Made floating point numbers always print as inexact.
Got rid of bogus type-error warnings when using floatnums.
Fixed declaration of call_startup_procedure in c/main.c.
2/11/98 (version 0.50)
Fixed bug in closed-compiled version of READ-CHAR.
Fixed negative-key bug in integer tables.
11/18/97 (version 0.49)
Removed some non-portable Kali code that had been accidentally
included in c/extension.c.
10/29/97 (version 0.48)
The VM's calling convention now has the caller doing protocol checking,
instead of the callee. The *NARGS* register no longer exists.
Scheme's variable-arity procedures (APPLY, MAKE-VECTOR, +, -, etc.)
are usually handled without raising an exception. Calls with an
`atypical' number of arguments are now much faster.
Opcodes were added for >, <=, and >=.
Procedures can take up to about 8k arguments. The limit is determined
by the value of AVAILABLE-STACK-SPACE in scheme/vm/arch.scm.
Compiler detects wrong number of arguments in ((lambda ...) ...).
Removed the dynamic point from the dynamic environment to make
DYNAMIC-WIND behave reasonably with threads.
KILL-THREAD! should work more reliably.
The I/O primitives now pass OS error messages to the exception handlers.
I/O errors when flushing buffers no longer crash the system.
The Pre-Scheme compiler's hack for shadowing global variables with
local copies is no longer used.
Incompatible changes:
The internal thread interface was simplified.
There are some architecture changes; .image files will have to
be rebuilt.
ACCESS-SCHEME-48 and scheme/misc/slib-init.scm have been removed
(thanks to Mike Sperber's updating of slib).
1/27/97 (version 0.47)
Fixed ,exit and added ,exit-when-done.
CASE now uses EQV? exclusively.
11/5/96 (version 0.46)
Fixed a few minor thread problems.
opt/analyze.scm now writes to current-noise-port.
DELQ and DELETE now delete every instance, as the documentation claims.
There should be no more spurious heap-overflow interrupts.
Fixed bugs that caused the system to die if stdout blocked.
Template offsets have been increased to two bytes.
Disassembly of flat-lambda now works (fix from Michael Sperber).
8/23/96 (version 0.45)
Fixed various problems with thread termination and nested schedulers.
Changed thread-internal interface to make schedulers easier to write.
BITWISE-{AND,IOR,XOR} now take an arbitrary number of arguments.
Output ports have their buffers flushed when Scheme 48 terminates.
In keeping with RnRS, CLOSE-{IN,OUT}PUT-PORT are now idempotent.
MODULO now handles negative arguments properly.
6/20/96 (version 0.44)
The VM's byte-code interpreter and storage management code are
now compiled to separate C files.
The socket code works again.
5/10/96 (version 0.42-0.43)
Various fixes to the thread and I/O systems.
The Unix interface code is more portable.
EOF (control-D) now resumes running all non-broken threads on
resumed command level. Thus EOF after a keyboard interrupt
(control-C) resumes running the interrupted thread.
11/30/95 (version 0.41)
The distribution has been reorganized to reduce the number of files
in the top-level directory.
The threads implementation has been replaced with one based on engines
to allow for nested schedulers.
Threads are now included in the initial image.
The I/O system has been fixed and automatic periodic output buffer
flushing has been reinstalled.
Command levels have been integrated with the threads system to ensure
that at most one REPL is active at any time.
CONDVAR has been changed to PLACEHOLDER (condition variables being
something quite different).
,profile no longer works, it will be fixed in a later version.
MIN and MAX now do inexact contagion.
4/13/95 (version 0.40)
Renamed error-output-port to current-error-port.
Reinstated ".gdbinit"...
segment->template now takes parent templates debug data as an
argument.
Automatic periodic output buffer flushing has been
temporarily disabled. A future version of the I/O system
will fix it.
Fixed expansion of named LET.
The bummed-define-record-types structure is now gone; use
define-record-types instead.
There is somewhat better syntax checking now.
8/12/94 (versions 0.38-0.39)
,profile <command> prints out profiling information
An interrupt is raised after ever GC; the default handler checks
to see if some reasonable amount of storage was reclaimed.
Some of the standard Scheme procedures, including LENGTH, FOR-EACH,
VECTOR, and ASSQ, are now significantly faster.
Making, accessing, and setting records is faster.
tar file now includes the top-level directory
The "scheme-level-2-internal" structure has been renamed to
"usual-resumer".
` ( . ' is now illegal (as required by the R4RS grammar).
Made DELAY and FORCE comply with R4RS.
The EXPAND optimizer does a topological sort on definitions.
(optimize flat-environments) causes the compiler to produce
flat (instead of nested) lexical environments.
The I/O system has been rewritten to do its own buffering. There
are significant changes to unix.c to support this. See doc/io.txt.
(ERROR-OUTPUT) is now available from the structure i/o.
jar-defrecord has been replaced with a modified bummed-jar-defrecord
Files load about 25% faster, for a number of reasons.
Removed the copy of vm/arch.scm from the rts directory.
Threads and sockets work together; SOCKET-ACCEPT no longer blocks.
The compiler no longer prints out .'s as it compiles definitions.
7/5/94 (version 0.37)
I/O opcodes now raise an interrupt instead of blocking (they still
block if no corresponding interrupt handler has been installed).
The threads code has been rewritten; threads that block on I/O
do not busy wait and THREAD-READ-CHAR and THREAD-PEEK-CHAR have
been removed.
Attempting to obtain a lock twice or to release an unowned lock
now signal errors.
READ-CHAR-WITH-TIMEOUT returns #F if the timeout occurs.
The socket structure is back in more-packages.scm.
Renamed .gdbinit to gdbinit
tar file now contains a top-level directory
3/22/94 (version 0.36)
Removed doc/lsc.ps for copyright reasons.
Fixed (* 47123 46039) multiply bug.
Modified vm/README to make it easier to run the VM.
3/16/94 (version 0.35)
Fixed (exact->inexact 0.1) -> 0..1. bug.
Fixed VM bug that permitted the creation of stored objects with
negative sizes.
3/8/94 (version 0.34)
"make check" target tests out various features.
Fixes for SGI IRIX 4.0.5 and MIPS RISC/OS 4.51, courtesy
Bryan O'Sullivan.
debug/run.scm and the "medium system" work again now.
misc/static.scm should work on the 68000.
Command processor no longer fluid-binds (interaction-environment)
on recursive entry.
2/24/94 (version 0.33)
Fixed bug in VM's interrupt system.
Made non-local srcdir work in Makefile.
Added (load-package 'bigbit) to vm/README.
2/23/94 (version 0.32)
Some incompatible changes to the VM; .image files will have
to be rebuilt.
Improvements to configuration script and to unix.c to support
a wider variety of Unixes. The system should now work
under any Posix-compliant Unix (except maybe for
char-ready?; see comments in unix.c).
Upped the default heap size from 4 meg (2 per semispace) to 6
meg (3 per semispace).
New command line argument -s <size> for specifying size of
stack buffer. Default is 2500 (words).
$@ -> "$@" in script (thanks to Paul Stodghill for this fix).
Obscure interrupt/exception VM bug fixed.
It is now possible to put an initial heap image into static
memory (effectively allocated by OS process creation).
Immutable initial objects go into static read-only memory,
and mutable initial objects go into static read-write
memory. Initial objects not copied by the GC. There is no
documentation yet, but look at the rules for little and
debug/little.o in the Makefile if you're interested.
2/13/94 (version 0.31)
Incompatible changes:
In interfaces, all exported syntactic keywords must be
given type :syntax. For example,
(define-interface my-macros
(export (my-macro :syntax) ...))
Image entry procedures for the ,build command are now
passed a list of strings, not just a single string, for
the command line arguments following -a.
The names of the macros defined in scheme48.h
(pairp, car, string_length, etc.) are now all upper case.
New "configure" script generates Makefile from Makefile.in
and sysdep.h from sysdep.h.in (thanks to Gnu autoconf).
See INSTALL and doc/install.txt.
Bug fixes:
Can now make vectors (strings, etc.) as big as the amount
of heap space available (but you're still screwed if you
try to make one bigger than 2^23-1 bytes - don't do it).
Non-ANSI-ness fixed in scheme48vm.c (jump out of, then
back into, a block expected block-local variables to be
unchanged).
Fixed big/external.scm (had VECTOR-POSQ instead of ENUM).
In (define-syntax foo bar) you got an error if bar was a
variable reference.
Plugged a storage leak (file-environments table in
env/debug.scm). Images made with ,build were too large.
Flushed extraneous delay from make-reflective-tower.
Renamed variables in Makefile to resemble Gnu standards.
Fixed definition of LINKER_RUNNABLE in Makefile.
Added doc/call-back.txt.
Fixed define-enumerated documentation (doc/big-scheme.txt).
Environment maps no longer retained for things in initial.image
and scheme48.image. This makes scheme48.image about 170K
smaller.
2/3/94 (version 0.30)
Faster EXPT.
FLOATNUMS improvement: (inexact->exact <float>) should now
work, e.g.
(inexact->exact (/ 1. 3.)) => 6004799503160661/18014398509481984
Reinstated ACCESS-SCHEME-48 for the benefit of PSD (portable
scheme debugger) and a certain other software package that
shall remain nameless. It only knows about a small number of
procedures, including things like ERROR and FORCE-OUTPUT.
Various changes to support the Pre-Scheme compiler, notably
SET-REFLECTIVE-TOWER-MAKER!.
Incompatible change to the ENUMERATED structure: the names
foo/bar no longer become defined. Write (enum foo bar)
instead. This will macro expand into the correct small
integer.
1/30/94 (version 0.29)
Fixed ps_run_time() to call sysconf() to find out how many
ticks there are per second. It used to assume 60. This
affects the output of the ,time command, so don't try
comparing numbers from this version with numbers from older
versions.
,time command will now accept a command, e.g.
,time ,load foo.scm.
It appears that if multiple arguments follow -a on the
argument line, they are concatenated together with spaces
separating them and passed to the startup procedure. I
don't know how long this has worked. This will change in
the future so that the startup procedure gets a list of
strings.
Installed what used to be called the GENERAL-TABLES structure
as the TABLES structure used by the system. This allows
the use of other comparison predicates besides EQ?, and
eliminates some code that had a restrictive copyright
notice.
ENUM, NAME->ENUMERAND, and ENUMERAND->NAME are all macros.
Enumerated types themselves are now macros as well.
1/23/94 Fixed bad multiplication bug in VM: (* 214760876 10) was
returning 125112.
Moved RECORD-TYPE? and RECORD-TYPE-FIELD-NAMES from the
RECORDS-INTERNAL interface to the RECORDS interface, for
a somewhat closer approximation to MIT Scheme.
Various type system improvements.
Still no documentation for the ,exec package, but see
link/load-linker.exec for an example.
New generic function feature, exported by the METHODS
interface (see interfaces.scm), almost like in a certain
dynamic object-oriented language.
1/11/94 (version 0.27)
Change:
The isomorphism used by CHAR->INTEGER and INTEGER->CHAR is
no longer ASCII. This change was introduced in order to
assist the development of portable programs. If you need
ASCII encoding, you should open the ASCII structure and
use the procedures CHAR->ASCII and ASCII->CHAR.
Features:
The help system is somewhat improved.
New form DEFINE-STRUCTURE defines a single structure.
Incompatible changes to package system:
Renamed DEFINE-PACKAGE to DEFINE-STRUCTURES
Renamed DEFINE-STRUCTURE to DEFINE
Renamed all the base types from FOO to :FOO. E.g.
:SYNTAX, :VALUE, :PAIR, etc.
Other:
Removed socket support due to restrictive copyright on some
of the C code that was in extension.c.
12/21/93 ,take has been flushed in favor of ,exec ,load. Commands are
now accessed via a distinguished package instead of a table.
Documentation pending.
Postscript (.ps) files now included in doc/ subdirectory. (I
thought they had been there all along, but apparently I was
wrong.)
Enhanced, but still kludgey, floating point support. Use
,open floatnum.
12/12/93 (version 0.26)
NetBSD port.
Hacked write-level and write-depth for inspecting circular
structure.
Recursive FORCEs signal errors, e.g.
(force (letrec ((loser (delay (force loser)))) loser))
12/7/93 (version 0.25)
Bug fix:
filenames.make can now be remade using initial.image. This
means that you can snarf a distribution and then edit
USUAL-FEATURES before making scheme48.image.
12/6/93 Incompatible changes:
Change of terminology: "signature" --> "interface".
This means that DEFINE-SIGNATURE is now called
DEFINE-INTERFACE, etc.
Some structures have been renamed:
condition -> conditions
continuation -> continuations
exception -> exceptions
queue -> queues
port -> ports
record -> records, record-internal -> records-internal
table -> tables
template -> templates
The ,load-into command has been removed. Use ,in ... ,load
instead (see below), e.g.
,in mumble ,load myfile.scm
The heap size for -h is specified in words, not bytes. As
before, the size must account for both semispaces; -h 2n
means n words per semispace. This change was actually
made a while ago, but I was confused as to what it meant.
Bug fixes:
#e1.7 reads as 17/10, (exact? 1+1.0i) => #f, and 1.0+i prints.
Features:
Things like ((structure-ref scheme if) 1 2 3) work.
The following commands now take arbitrary commands to execute
in the specified package, not just forms:
,config ,user ,for-syntax ,in <package>
For example, you can say
,in mumble ,trace foo
This subsumes the functionality of the ,load-into and
,load-config commands.
Dynamic loading of shared libraries for System V systems
(untested).
Documentation:
Somewhat improved. user-guide.txt now lists most of the
interesting built-in packages. lsc.ps is a draft of "A
Tractable Scheme Implementation," a paper submitted to Lisp
and Symbolic Computation. See also doc/big-scheme.txt,
doc/thread.txt, and doc/external.txt.
10/30/93 LET-SYNTAX and LETREC-SYNTAX.
Arrays (see big/array.scm).
Lots of internal changes.
7/20/93 Features:
Type system. See doc/types.txt.
7/4/93 Features:
New define-package clause (for-syntax <clause>*).
E.g. (define-package ((my-package ...))
(open ...)
(for-syntax (open scheme my-utilities)
(files more-crud-for-syntax))
...)
A file name to package map is now used by the emacs
interface. Whenever you load a file, or zap from a file that
hasn't been previously loaded or zapped, the package in
which forms are being evaluated is remembered in a table.
The next time you zap some forms from the same file, they
will be evaluated in that package.
Sometimes you may get an association you don't want. In that
situation, you can use the ,forget command to delete an
entry in the table.
A new ,push command goes to a deeper command level.
Experimental "command preferred" command processor mode: if
you give the command ",form-preferred off", commands will
be "preferred" to forms, meaning that you don't need to
type a comma before giving a command. To see the value
of a variable FOO you have to say (begin foo).
Experimental "no levels" command processor mode: if you
give the command ",levels off", then an error will not
push a new command level. If you want to ignore an
error, you don't need to take any action - further
evaluations will happen at top level. If you want to
enter the inspector or get a preview, you can issue these
commands or a ,push command immediately after the error
occurs (more precisely, any time until the focus object
is set by some other command).
All of the mode-control commands (batch, bench,
break-on-warnings, form-preferred, and levels) take
an optional argument. When no argument is given, they
will toggle the corresponding mode. With an argument of
ON or OFF, they turn the mode on or off.
The ,flush and ,keep commands have been made more flexible
and verbose.
6/18/93 Incompatible changes:
The access-scheme48 procedure has gone away. Use ,open
or the module system instead.
The user, configuration, and for-syntax packages no longer
have variables bound to them in the configuration package.
Where previously you said: Now you should say:
,in user <form> ,user <form>
,in config <form> ,config <form>
,in for-syntax <form> ,for-syntax <form>
,load-into config <file> ,load-config <file>
,load-into for-syntax <file> ,for-syntax (load "file")
Features:
There is an ,expand <form> command for debugging macros.
The ,open command takes any number of structure names, and opens
them all (like ,new-package).
New procedure DEFINE-INDENTATION exported by the PP structure.
E.g. (define-indentation 'let-fluid 1) is like Gnu emacs's
(put 'let-fluid 'scheme-indent-hook 1).
The inspector simplifies generated names in continuation
source code display. E.g. when formerly it said
"Waiting for (#{Generated lambda} () (x->node (car exps)))"
now it says
"Waiting for (lambda () (x->node (car exps)))"
Macros can signal syntax errors by returning input expression
unchanged. (Comparison uses EQ?.)
Documentation:
The doc/ directory contains a draft of a "Scheme 48
Progress Report."
Cleanup:
Procedure NULL-TERMINATE added to structure EXTERNALS's
signature.
"Vulgar Scheme" renamed to "Big Scheme".
Two new subdirectories, env/ (for programming environment)
and big/ (for Big Scheme), now contain most of what was
in the misc/ directory.
Several source files that were in the top level and link/
directories have moved to the env/ and alt/ directories.
5/6/93 Bug fixes:
Fixed -h command line switch. The size was being improperly
divided by 4, so if you asked for an N megabyte heap, you'd
actually only get an N/4 megabyte heap.
Nested backquotes were broken for a while; should be fixed
now.
Features:
Quoted structure is read-only: e.g. (set-car! '(a b) 3) will
produce an exception.
,config [<form>] and ,user [<form>] are like ,in <struct> <form>.
Unix socket support; see misc/socket.scm.
Now using gzip instead of compress for distributions.
,open command offers to load packages.
A .gdbinit file sets a breakpoint at CM's exception raising
code, and defines a handy "preview" command.
1/18/93 Feature:
Scheme 48 distributions now have version numbers. The
version number is printed in the image startup message.
Please include it in bug reports.
The module system is now documented. See doc/module.tex.
12/17/92 Bug fixes:
Macro templates of the form (x ... y) are supported.
Macro templates are now less fussy about meta-variable
rank: you can do "(x y) ..." even when the rank of either
x or y (but not both) is too low; the low-ranking text
will be copied as many times as necessary. (A
meta-variable's "rank" is the number of ...'s it sits
under in the left-hand side of the rewrite rule.)
SYNTAX-RULES is now itself hygienic. This means you can
have a meta-variable named CAR, for instance.
New development environment features:
Commands now start with comma (",") instead of colon
(":"). (Easier to type since it's not shifted.)
values, call-with-values, dynamic-wind, eval,
interaction-environment, and scheme-report-environment
added per upcoming Revised^5 Scheme report. See
doc/meeting.tex.
Modifications to quoted structure will now be detected and
reported as errors.
An interrupt will occur if an insufficient amount of memory
is reclaimed by a garbage collection.
Inspector now accepts arbitrary command processor commands
(with or without leading comma)
,keep command controls retention of debugging information.
Features removed:
#\page and #\tab. These aren't in the Scheme report.
Their absence in Scheme 48 will encourage portability.
access-scheme48 works with fewer names than before. Use the
package system instead.
Complex numbers not in the system, by default. Get them
back by changing usual-features in more-packages.scm.
Features changed:
Many changes to package system. See doc/module.tex.
The :identify-image command is gone. Instead, supply a
second argument (optional) to the ,dump command.
The inspector's TEM command has been shortened to T.
Internal changes and features:
Stored objects types are now part of the virtual machine
architecture, i.e. known to the byte-code compiler.
Run-time system is split up into many little modules.
File names are retained in debug database. (But not used for
anything yet...)
Tweaks to table package reduce standard image size by 50K
and increase compiler speed by 7%.
Immutability bit in object headers.
Weak pointers.
7/18/92 Features removed:
Table package's default hash function no longer supports
string, pairs, or vectors.
7/9/92 Bug fixes:
(- 0 -536870912)
Inspector now uses command i/o ports instead of current ones
Inexact integers print as N. instead of #iN
Throwing back into a call-with-....put-port now produces a
warning instead of an error
Feature fixes:
In DEFINE-PACKAGE, OPEN no longer implies ACCESS.
misc/receive.scm renamed to rts/values.scm, made to conform
with Revised^5 Report, and installed internally.
Features:
New :load-package command. Uses file names in (file ...) clause
of a define-package. These are interpreted relative to the
directory in which the file containing the define-package
was found.
#\tab and #\page now print this way.
6/17/92 Bug fixes:
Fixed bug in modulo.
Flushed LAST-PAIR (which disappeared between R^3 and R^4).
DEFINE-SYNTAX and SYNTAX-RULES now exist.
CEILING, FLOOR, and ROUND now exist.
GCD and LCM are now n-ary.
STRING-CI=? and STRING-COPY fixed.
STRING->SYMBOL now copies its argument before handing it to
INTERN.
=, <, etc. now work with more than two arguments.
CHAR-READY? exists.
Calls via APPLY are now tail-recursive.
DISPLAY of vectors and lists works (ugh).
Development environment improvements:
Type ? at inspector to get list of inspector commands.
Inspector D command goes to next continuation.
Inspector M command shows more of a long menu.
Inspector TEM command goes to a continuation's or closure's
template.
For closures and continuations, inspector displays local
variables with their names.
For continuations, inspector displays source code for
expression into which control will return.
Multiple command loop levels. EOF (control-D) now only pops
out a single level. :reset pops all the way out. :level n
goes out to level n.
Can disable benchmark mode.
Procedures made with (let ((f (lambda ...))) ...) now print
with names.
Features:
Package system: special forms define-package and package-ref;
command processor commands :set-package, :load-into,
:clear-package, :new-package, :export, :open-package, etc.
In misc directory: threads, queues, extended ports, format, etc.
Changes to system environment:
user-initial-environment -> user-package
record-updator -> record-modifier
primitive-throw superseded by with-continuation
ash -> arithmetic-shift
New bootstrap regime.
Support for threads: alarm clock interrupt, etc.
Etc.:
Liberal COPYRIGHT file, and a little notice in each source file.
INSTALL and NEWS split off from README.
doc.txt renamed to user-guide.txt.
The Makefile now provides two ways to make "s48" for
installation. One depends on the exec #! script execution
feature and the other doesn't.
"make" targets for testsys.image and little.image.
Runs Jaffer's test suite and library.
Flushed s48.el. Use cmuscheme instead.
9/5/90 Command processor argument parser revamped.
:load, :trace, and :untrace commands take arbitrary number
of arguments. Argument to :proceed is optional.
New (but undocumented) :identify-image command.
Better error messages: wrong number of arguments, undefined
variable.
+, *, min, max, apply are now n-ary; -, /, make-string,
make-vector, read-char, peek-char, write-char have
appropriate argument optionality.
Better internal support for macros; not yet ready for release.
Added STRING as per R^3.99RS.
More testing of Scheme version of bytecode interpreter.
Better scoping of ##; files can't see command processor context.
OR and CASE don't cons closures.
VM checks for non-existent heap image file, gives error
message instead of "bus error".
Numerous internal changes in compiler and exception system.
Fixed char<?.
Fixed -.5 bug in string->number.
8/26/90 Tested (link-system) inside of T; seems to work.
Benchmark mode available via :BENCH command.
System is 15K bigger due to new fatter global environment
representations.
Inspector abbreviation improved.
Disassembler now works on continuations, sort of.
7/26/90 ((lambda ...) ...) no longer makes a closure
Features now in default system:
:inspect
:dis[assemble]
Generic arithmetic: bignums, rationals, complexes
rationalize
:time command is more verbose
MOREFILES variable in Makefile for loading extra stuff
Default heap size increased to 2 megabytes per semispace

175
doc/no-leaf-env.txt
View File

@ -1,175 +0,0 @@
Return-Path: <kelsey@ccs.neu.edu>
Date: Mon, 14 Jun 93 14:34:40 -0400
To: jar@cs.cornell.edu
Subject: environments for leaf procedures
From: kelsey@flora.ccs.neu.edu
Sender: kelsey@ccs.neu.edu
I merged the no-leaf-environments code back into the system, and this
time it may be worth it. Loading pp.scm sped up by 2%, even though
the compiler is doing more work. Benchmark times (in seconds):
old new speedup
quicksort 1.48 1.39 6%
towers 1.05 1.05 0%
matrix-multiply 3.32 3.10 7%
matrix-multiply2 1.94 1.80 7%
Local variable names are screwed up:
> (define (f x) (let ((y 4)) (+ x y)))
> (f 'a)
Error: exception
(+ 'a 4)
1> ,debug
'#{Continuation (pc 13) f}
[0] 4
[1: y] 'a
inspect:
There is probably a simple fix for this.
Here is the diff:
% diff comp.scm comp.scm.save
26d25
< (define $compiling-leaf (make-fluid 'no))
28,33d26
< (define (note-not-leaf!)
< (set-fluid! $compiling-leaf 'no))
<
< (define (compiling-leaf?)
< (eq? 'yes (fluid $compiling-leaf)))
<
63,82c56,66
< (deliver-value (if (env-ref? den)
< (local-variable den cenv depth #f)
< (instruction-with-variable op/global exp den #f))
< cont)))
<
< (define (local-variable den cenv depth set?)
< (let ((back (env-ref-back den cenv))
< (over (env-ref-over den)))
< (if (and (compiling-leaf?)
< (= back 0))
< (instruction (if set? op/stack-set! op/stack-ref)
< (+ (- over 1) depth))
< (let ((back (if (compiling-leaf?) (- back 1) back)))
< (if set?
< (instruction op/set-local! back over)
< (case back
< ((0) (instruction op/local0 over)) ;+++
< ((1) (instruction op/local1 over)) ;+++
< ((2) (instruction op/local2 over)) ;+++
< (else (instruction op/local back over))))))))
---
> (if (env-ref? den)
> (let ((back (env-ref-back den cenv))
> (over (env-ref-over den)))
> (deliver-value (case back
> ((0) (instruction op/local0 over)) ;+++
> ((1) (instruction op/local1 over)) ;+++
> ((2) (instruction op/local2 over)) ;+++
> (else (instruction op/local back over)))
> cont))
> (deliver-value (instruction-with-variable op/global exp den #f)
> cont))))
143,145c127,132
< (if (env-ref? den)
< (local-variable den cenv depth #t)
< (instruction-with-variable op/set-global! name den #t)))
---
> (cond ((env-ref? den)
> (instruction op/set-local!
> (env-ref-back den cenv)
> (env-ref-over den)))
> (else
> (instruction-with-variable op/set-global! name den #t))))
203d189
< (note-not-leaf!) ; this isn't strictly necessary, but it keeps things simpler
222,231c208,215
< (cond ((return-cont? cont)
< code)
< (else
< (note-not-leaf!) ; this isn't strictly necessary, but it keeps things simpler
< (sequentially (instruction-with-offset&byte op/make-cont
< (segment-size code)
< depth)
< (note-source-code (cont-source-info cont)
< code)
< (cont-segment cont)))))
---
> (if (return-cont? cont)
> code
> (sequentially (instruction-with-offset&byte op/make-cont
> (segment-size code)
> depth)
> (note-source-code (cont-source-info cont)
> code)
> (cont-segment cont))))
264d247
< (note-not-leaf!)
280,315c263,284
< (let-fluids $compiling-leaf 'maybe
< (lambda ()
< (let ((code (really-compile-lambda-code formals body cenv name)))
< (if (eq? (fluid $compiling-leaf) 'maybe)
< (let-fluids $compiling-leaf 'yes
< (lambda ()
< (really-compile-lambda-code formals body cenv name)))
< code)))))
<
< (define (really-compile-lambda-code formals body cenv name)
< (let* ((nargs (number-of-required-args formals))
< (vars (normalize-formals formals))
< (cenv (if (null? formals)
< cenv ;+++
< (bind-vars vars cenv))))
< (sequentially
< (cond ((n-ary? formals)
< (sequentially
< (instruction op/make-rest-list nargs)
< (instruction op/push)
< (if (compiling-leaf?)
< empty-segment
< (instruction op/make-env (+ nargs 1)))))
< ((null? formals)
< (note-not-leaf!) ; no point if no variables
< empty-segment)
< ((compiling-leaf?)
< empty-segment)
< (else
< (instruction op/make-env nargs)))
< (note-environment
< vars
< (compile-body body
< cenv
< 0
< (return-cont name))))))
---
> (if (null? formals)
> (compile-body body ;+++ Don't make null environment
> cenv
> 0
> (return-cont name))
> (sequentially
> (let ((nargs (number-of-required-args formals)))
> (if (n-ary? formals)
> (sequentially
> (instruction op/make-rest-list nargs)
> (instruction op/push)
> (instruction op/make-env (+ nargs 1)))
> (instruction op/make-env nargs)))
> (let* ((vars (normalize-formals formals))
> (cenv (bind-vars vars cenv)))
> (note-environment
> vars
> (compile-body body
> cenv
> 0
> (return-cont name)))))))
>

81
doc/scheme48.man
View File

@ -1,81 +0,0 @@
.TH LS48 1
.\" File scheme48.man: Manual page template for Scheme 48.
.\" Replace LS48 with the name of your default image and LLIB with the
.\" directory containing scheme48vm and default image.
.SH NAME
LS48 \- a Scheme interpreter
.SH SYNOPSIS
.B LS48
[-i image] [-h heapsize] [-a argument]
.SH DESCRIPTION
.B LS48
is an implementation of the Scheme programming language as described in
the
.I "Revised^4 Report on the Algorithmic Language Scheme."
A runnable system requires two parts, an executable program that implements
the Scheme 48 virtual machine, and an image that is used to initialize
the store of the virtual machine.
.B LS48
is a shell script that starts the virtual machine with an image that runs
in a Scheme command loop.
.PP
The
.B LS48
command loop reads Scheme expressions,
evaluates them, and prints their results.
It also executes commands, which are identified by an initial comma character.
Type the command
.I ,help
to receive a list of available commands.
.PP
The
.B \-h
option causes
.IR heapsize
words to be allocated for both semispaces of the copying garbage
collector. One word is four bytes. Cons cells are currently 3 words,
so if you want to make sure you can allocate, say, a million cons
cells, you should specify
.B \-h
6000000 (actually a little more, to account for the initial heap
image and breathing room).
.PP
The
.I ,dump
and
.I ,build
commands put heap images in files.
The
.B \-i
option causes the initial heap image to be taken from file
.IR image .
The
.B \-a
option causes a list of strings to be passed as the argument
to an image generated using the
.I ,build
command. The first argument to
.I ,build
is a procedure that is passed
the arguments following
.B \-a
and which should return an integer (which is the
return value of the Scheme 48 process).
.PP
.nf
> ,build (lambda (a) (display a) (newline) 0) foo.image
> ,exit
$ LS48 -i foo.image -a mumble
mumble
$
.PP
.fi
.SH FILES
.TP 40
.B LLIB/scheme48vm
the virtual machine.
.TP
.B LLIB/LS48.image
the default image.
.SH BUGS
Procedure calls with more than 63 explicit arguments might not work.

94
doc/src/code.tex
View File

@ -1,94 +0,0 @@
% Latex Macros for Lisp code in text.
% Based on macros found in C. Rich's library.
\makeatletter
% \vobeyspaces turns all spaces into non-breakable spaces.
% Note: this is like \@vobeyspaces except without spurious space in defn.
{\catcode`\ =\active\gdef\vobeyspaces{\catcode`\ =\active\let =\@xobeysp}}
% \def\vobeytabs turns all tabs into 8 non-breakable spaces
{\catcode`\^^I=\active\gdef\vobeytabs{\catcode`\^^I=\active\let^^I=\xvobeytabs}}
\def\xvobeytabs{\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp}
% \vobeylines turns all cr's into non-breakable \par's
{\catcode`\^^M=\active\gdef\vobeylines{\catcode`\^^M=\active\let^^M=\xvobeylines}}
\def\xvobeylines{\par\penalty10000}
% \obeycrsp turns cr's into non-breakable spaces
{\catcode`\^^M=\active\gdef\obeycrsp{\catcode`\^^M=\active\let^^M=\@xobeysp}}
%% \@noligs prevents ?` and !` from being treated as ligatures
%% added 19 April 86 [copied from Latex sources]
\begingroup
\catcode``=13
\gdef\@noligs{\let`=\@lquote}
\endgroup
% Set up code environment, in which most of the common special characters
% appearing in code are treated verbatim, namely: _ # & ^ $ ~ @ " %
% *** JAR NEEDED $ AND _ IN SOME CODE ***
% Note: \ { } are still enabled so that macros can be called in this
% environment. Use \\, \{ and \} to use these characters verbatim
% in this environment.
% Note: this environment allows no breaking of lines whatsoever; not
% at spaces or hypens. To arrange for a break use the standard \- macro,
% or the \= macro which breaks, but inserts nothing. This is useful,
% for example for allowing hypenated identifiers to be broken, e.g.
% FOO-\=BAR.
\def\setupcode{\parsep=0pt\parindent=0pt
\tt\frenchspacing\catcode``=13\@noligs%
\def\\{\char`\\}%
\@makeother\#\@makeother\&\@makeother\^%\@makeother\_\@makeother\$%
\@makeother\`\@makeother\'%
\@makeother\~\@makeother\@\@makeother\"\@makeother\%\vobeytabs\vobeyspaces}
% Code environment as described above. Note that blank lines are
% not preserved, and lines are not kept on one page. Code is
% indented by the same amount as quotes.
% Note: to increase left margin, use \leftmargini=1in.
% was {\list{}{\parsep=0pt}\item[]\setupcode\obeylines}%
% then {\list{\parsep=0pt\listparindent=0pt\leftmargin=0pt}{}\item[]\setupcode%
\newenvironment{bigcode}%
{\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt%
\listparindent=0pt}\item[]\setupcode%
\obeylines}%
{\endlist}
% Code is just like bigcode, but everything inside is kept on one page
% Note: This actually works by setting a huge penalty for breaking
% between lines of code.
% was {\list{}{\parsep=0pt}\item[]\setupcode\vobeylines}%
\newenvironment{code}%
{\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt%
\listparindent=0pt}\item[]\setupcode%
\vobeylines}%
{\endlist}
% Reasonable separation between lines of code
\newcommand{\codeskip}{\penalty0\vspace{2ex}}
% \cd is used to build a code environment in the middle of text.
% Note: only difference from display code is that cr's are taken
% as unbreakable spaces instead of \par's.
\newcommand{\cd}{\begingroup\setupcode\obeycrsp\startcode}
\newcommand{\startcode}[1]{#1\endgroup}
%\setbox0\hbox{\@xobeysp}\hline{43\wd0}
\makeatother

439
doc/src/meeting.tex
View File

@ -1,439 +0,0 @@
\documentstyle[11pt,twoside]{article}
\input{code}
\input{latex-stuff}
\advance \textheight by 2ex
\begin{document}
\begin{center}
{\Large\bf The Scheme of Things:} \\
\vspace{2ex}
{\Large\bf The June 1992 Meeting$^{\hbox{\scriptsize 1}}$} \\
\vspace{3ex}
Jonathan Rees \\
Cornell University \\
{\tt jar@cs.cornell.edu}
\end{center}
\vspace{3ex}
\footnotetext[1]{To appear in {\em Lisp Pointers} V(4),
October--December 1992.}
An informally constituted group of people interested in the future of
the Scheme programming language met at the Xerox Palo Alto Research
Center on 25 June 1992. The main purpose of the meeting was to work
on the technical content of the next revision of the Scheme report.
We made progress on several fronts:
\begin{itemize}
\item Some differences with the IEEE Scheme standard were resolved.
\item Proposals for multiple return values and {\tt dynamic-wind} were
adopted.
\item A proposal for an {\tt eval} procedure was adopted.
\item The high-level macro facility described in the
Revised$^4$ Report's appendix will be moved into the report proper.
\end{itemize}
Two subcommittees were formed: one to work on exceptions, and one to
charter the formation of a standard library. The subcommittees will
report back to the group with proposals for inclusion in the report.
It had been hoped that there would be progress on some other fronts
(user-defined types, dynamic binding, improvements to ``rest''
parameters), but after inconclusive discussion these topics were
dropped. These topics will probably be taken up again in the future.
Norman Adams was appointed the Revised$^5$ Report's editor. It is
hoped that it will be ready by early 1993, so as to precede the
reconstitution of the IEEE standard group.
This article is my own interpretation of what transpired, and should
not be construed as definitive.
\piece{Agreement with the IEEE Scheme standard}
Until now, the Scheme reports have encouraged but not required the
empty list {\tt()} and the boolean false value {\tt\#f} to be
distinct. It has been the intent ever since the Revised Revised
Report, however, that this distinction would eventually be required.
The IEEE Scheme standard bit the bullet in 1990, and now the
Revised$^5$ report follows.
The standard also dropped the distinction between essential and
not-essential language features; most features that were formerly not
essential, such as n-ary {\tt+} and {\tt apply}, are now required.
The Revised$^5$ Report will adopt this stance, at least as regards
language features that are shared with the IEEE standard.
Non-essential non-IEEE oddities such as {\tt transcript-on} and {\tt
transcript-off} and the proposed {\tt interaction-\ok{}environment} (see
below) were not discussed at the meeting, however, and consensus on
their status will have to be reached via electronic mail.
A third aspect of the standard that was adopted was a certain obscure
paragraph regarding assignments to top-level variables (section 6,
paragraph 2). The effect of this is that if a program contains an
assignment to any top-level variable, then the program must contain a
{\tt define} for that variable; it is not sufficient that the variable
be bound. This has been the case for most variables, but the rule
applies as well to variables such as {\tt car} that have built-in
bindings. In addition, it is clarified that if a program makes such a
definition or assignment, then the behavior of built-in procedures
will not be affected. For example, redefining {\tt length} cannot
affect the behavior of the built-in {\tt list->vector} procedure.
If in some particular implementation {\tt list->vector} is written
in Scheme and calls {\tt length}, then it must be sure to call the
built-in {\tt length} procedure, not whatever happens to be the value
of the variable {\tt length}.
\piece{Multiple return values}
The {\tt call-with-values} and {\tt values} procedures were described
in an earlier Scheme of Things ({\em Lisp Pointers}, volume IV, number
1), but I'll review them here. The following is adapted from John Ramsdell's
concise description:
\begin{list}{}{}{}\item
{\tt(values \var{object} $\ldots$)}
\hfill {\rm essential procedure}
{\tt values} delivers all of its arguments to its continuation.
\vspace{2ex}
{\tt(call-with-values \var{thunk} \var{receiver})}
\hfill {\rm essential procedure}
{\tt call-with-values} calls its \var{thunk} argument with a
continuation that, when passed some values, calls the
\var{receiver} procedure with those values as arguments.
The continuation for the call to \var{receiver} is the
continuation of the call to {\tt call-with-values}.
\end{list}
Except for continuations created by the {\tt call-with-values}
procedure, all continuations take exactly one value, as now; the
effect of passing no value or more than one value to continuations
that were not created by {\tt call-with-values} is unspecified (as
indeed it is unspecified now).
{\tt values} might be defined as follows:
\begin{code}
(define (values . things)
(call-with-current-continuation
(lambda (cont) (apply cont things))))
\end{code}
That is, the procedures supplied by {\tt
call-with-current-continuation} must be passed the same number of
arguments as values expected by the continuation.
Because the behavior of a number-of-values mismatch between a
continuation and its invoker is unspecified, some implementations may
assign some specific meaning to such situations; for example, extra
values might be ignored, or defaults might be supplied for missing
values. Thus this multiple return value proposal is compatible with
Common Lisp's multiple values, but strictly more conservative than it.
The behavior of programs in such situations was a point of contention
among the authors, which is why only the least common denominator
behavior was specified.
\piece{Unwind/wind protection}
{\tt dynamic-wind}, which was described previously in this column (when it
was The Scheme Environment; {\em Lisp Pointers}, volume I, number 2),
is already implemented in many Scheme dialects. {\tt dynamic-wind}
takes three arguments, all of which are thunks (procedures of no arguments).
It behaves as if it were defined with
\begin{code}
(define (dynamic-wind before during after)
(before)
(call-with-values during
(lambda results
(after)
(apply values results))))
\end{code}
except that the execution of the {\tt during} thunk is ``protected''
against non-local entries and exits: a throw out of the execution
of {\tt during} will cause the {\tt after} thunk to be invoked, and a
throw from outside back in will cause the {\tt before} thunk to be
invoked. (By ``throw'' I mean an invocation of an explicit
continuation as obtained from {\tt call-with-current-continuation}.)
For details, the earlier Scheme Environment column refers the reader
to Friedman and Haynes's paper ``Constraining Control'' in POPL 1985,
but to save you the trouble of looking that up, I have supplied a more
direct implementation of {\tt dynamic-wind} in an appendix to the
present column.
{\tt dynamic-wind} was adopted with the following clarifications: The
semantics of {\tt(dynamic-wind \var{before} \var{during} \var{after})}
should leave unspecified what happens if a throw occurs out of {\em
before} or {\em after}\/; and it is best to defer interrupts during {\em
before} and {\em after}.
\piece{Evaluating computed expressions}
The original 1975 memo on Scheme described {\tt evaluate},
which was analogous to Lisp's traditional {\tt eval} function. {\tt
evaluate} took a single argument, an S-expression, and invoked an
interpreter on it. For example:
\begin{code}
(let ((name '+)) (evaluate (list name 2 3)))
\ev 5
\end{code}
Scheme being lexically scoped, however, there was some confusion over
which environment the expression was to be evaluated in. Should
\begin{code}
(let ((name '+))
(let ((+ *))
(evaluate (list name 2 3))))
\end{code}
evaluate to 5 or to 6?
To clarify matters, the Revised Report replaced {\tt evaluate} with
{\tt enclose}, which took two arguments, a {\tt lambda}-expression and
a representation of an environment from which to supply bindings of the
{\tt lambda}-expression's free variables. For example:
\begin{code}
(let ((name '+))
(let ((+ *))
((enclose (list 'lambda '() (list name 2 3))
(list (cons '+ +))))))
\ev 6
\end{code}
This forced the programmer to be explicit about the {\tt
lambda}-expression's enclosing environment.
For various technical and practical reasons, there was no {\tt eval}
analogue in subsequent Scheme reports. The major stumbling blocks
were how to describe {\tt eval} formally and how to define something
that makes sense in all extant variants of the language. Some Scheme
implementations contain a distinguished top-level environment, while
others extend the language by providing ways to create multiple
environments, any of which might serve equally well.
The {\tt eval} proposal adopted at the June meeting, which I reproduce
here, is one that comes from Bill Rozas.
\begin{list}{}{}{}\item
{\tt(eval \var{expression} \var{environment-specifier})}
\hfill {\rm essential procedure}
{\tt eval} evaluates \var{expression} in the environment indicated
by {\em environment-\discretionary{}{}{}specifier}. {\em
environment-specifier} may be the return value of one of the three
procedures described below, or implementation-specific extensions.
No other operations on environment specifiers are defined by this
proposal.
Implementations may allow non-expression programs (i.e.\
definitions) as the first argument to {\tt eval} \var{only} when
the second argument is the return value of {\tt interaction-environment}
or some implementation extension. In other words, {\tt eval} will never
create new bindings in the return value of {\tt null-environment} or
{\tt scheme-report-environment}.
\vspace{2ex}
{\tt(scheme-report-environment \var{version})}
\hfill {\rm essential procedure}
{\em Version} must be an exact non-negative integer corresponding to a
version of one of the Revised$^n$ Reports on Scheme. This procedure
returns a specifier for an environment that contains exactly the
set of bindings specified in the corresponding report that the
implementation supports. Not all versions may be available in all
implementations at all times. However, an implementation that
conforms to version $n$ of the Revised$^n$ Reports on Scheme must
accept version $n$. If {\tt scheme-report-environment} is
available, but the specified version is not, the procedure will
signal an error.
The effect of assigning (through the use of {\tt eval}) a variable
bound in a {\tt scheme-report-environment} (e.g.\ {\tt car}) is
unspecified. Thus the environments specified by the return
values of {\tt scheme-report-environment} may be immutable.
\vspace{2ex}
{\tt(null-environment)}
\hfill {\rm essential procedure}
This procedure returns a specifier for an environment that contains no
variable bindings, but contains (syntactic) bindings for all the
syntactic keywords defined in the report, and no others.
\vspace{2ex}
%\newpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
{\tt(interaction-environment)}
\hfill {\rm procedure}
This procedure returns a specifier for an environment that
contains imple\-men\-ta\-tion-defined bindings, typically a superset of
those listed in the report. The intent is that this procedure
will return a specifier for the environment in which the
implementation would evaluate expressions dynamically typed by the
user.
\end{list}
Rozas explains:
``The proposal does not imply the existence or support of first-class
environments, although it is compatible with them.
The proposal only requires a way of associating tags with a finite set
of distinguished environments which the implementations can maintain
implicitly (without reification).
``\,`Pascal-like' implementations can support both {\tt null-environment} and
%\penalty0
{\tt scheme-report-environment} since the environments specified by
the return values of these procedures need not share any bindings with
the current program. A version of {\tt eval} that supports these but
not {\tt interaction-environment} can be written portably,
but can be better written by the implementor, since it can share code
with the default evaluator or compiler.''
Here ``Pascal-like'' refers to implementations that are restricted to
static compilation and linking. Because an {\tt eval} that doesn't
support
\penalty0
{\tt interaction-\discretionary{}{}{}environment} can be written
entirely in the Scheme language described by the rest of the report,
it raises no troublesome questions about its formal semantics.
\piece{Macros}
The consensus of the meeting was that {\tt define-syntax}, {\tt
syntax-rules}, {\tt let-\discretionary{}{}{}syntax}, and {\tt
letrec-syntax} should be moved out of the report's appendix into the
main body of the report. Although everyone agrees that a low-level
macro facility is important, the subject is too contentious at
present, with three or more competing proposals at present. The
disposition of the rest of the appendix and of the other low-level
proposals will be left up to the report's editor.
\piece{Committee work}
There is a strong sense that some kind of exception system is needed.
However, no specific proposal was ready at the time of the meeting. A
committee has been formed to work on one. What seems to be in the
air might be described as a highly distilled version of the condition
system that Kent Pitman developed for Common Lisp. I hope that I'll
be able to report on this in a future column.
On the subject of libraries, Will Clinger's minutes report that
``the authors perceive a need to give some library official status. In
fact, we need to give official sanction to multiple libraries. There
is reason to distinguish between accepted (or standard) libraries,
experimental libraries, and proposals. The accepted libraries can
reduce the intellectual size of the language by removing things like
{\tt string->list} from the report. The experimental libraries would
contain solid implementations of experimental features, including
things that might never deserve to be in the report. The proposal
libraries could contain anything implemented in portable Scheme.''
Among the content of the accepted libraries, some features (such as
those that may be moved out of the body of the report) may be required
to be built in to implementations, while others will be expected to be
available on demand (perhaps using something similar to, but not the
same as, {\tt require} as found in Common Lisp and GNU Emacs).
A librarian was appointed (Rees), and a library committee is
developing proposals for the charter, structure, and content of the
libraries.
\separator
I would like to acknowledge Will Clinger, who prepared the minutes of
the meeting, and the various people who contributed proposals,
including Bill Rozas and John Ramsdell. Any errors here are my
responsibility, however. Thanks also to Norman Adams and Richard
Kelsey for corrections to a draft of this article.
I would also like to belatedly acknowledge Norman Adams, Pavel
Curtis, Bruce Donald, and Richard Kelsey for their comments on drafts of
my previous column.
For future columns, I am entertaining various topic possibilities,
including {\tt eval}, threads, {\tt amb}, and monads.
If you have other ideas, and particularly if you think the written
record on the language is particularly poor in certain areas, please
write and let me know.
\vspace{2ex}
%\newpage
%\bgroup \small
\piece{Appendix: An implementation of {\tt dynamic-wind}}
This program is based on my vague recollection of an ancient
manuscript by Chris Hanson and John Lamping. I apologize for the lack
of data abstraction, but the code is more concise this way.
A state space is a tree with the current state at the root. Each node other
than the root is a triple $\langle\var{before}, \var{after},
\var{parent}\rangle$, represented in this implementation as two pairs
{\tt((\var{before} .\ \var{after}) .\ \var{parent})}.
Navigating between states requires re-rooting the tree by reversing
parent-child links.
Since {\tt dynamic-wind} interacts with {\tt
call-with-current-continuation}, this implementation must replace the
usual definition of the latter.
\begin{code}
(define *here* (list #f))
\codeskip
(define original-cwcc call-with-current-continuation)
\codeskip
(define (call-with-current-continuation proc)
(let ((here *here*))
(original-cwcc (lambda (cont)
(proc (lambda results
(reroot! here)
(apply cont results)))))))
\codeskip
(define (dynamic-wind before during after)
(let ((here *here*))
(reroot! (cons (cons before after) here))
(call-with-values during
(lambda results
(reroot! here)
(apply values results)))))
\codeskip
(define (reroot! there)
(if (not (eq? *here* there))
(begin (reroot! (cdr there))
(let ((before (caar there))
(after (cdar there)))
(set-car! *here* (cons after before))
(set-cdr! *here* there)
(set-car! there #f)
(set-cdr! there '())
(set! *here* there)
(before)))))
\end{code}
%\egroup
\end{document}

83
doc/src/summary.tex
View File

@ -1,83 +0,0 @@
\documentstyle[11pt]{article}
\pagestyle{empty}
\setlength{\textheight}{9in}
\setlength{\footheight}{0.0in}
\setlength{\topmargin}{0in}
%Defaults from art10.sty:
%\textwidth 345pt \columnsep 10pt \columnseprule 0pt
%\oddsidemargin 63pt
\advance\textwidth by 0.5in
\advance\oddsidemargin by -0.25in
\begin{document}
\vspace*{-0.3in}
\begin{center}
{\large\bf Scheme 48} \\
\vspace{1ex}
Richard Kelsey ({\tt kelsey@corwin.ccs.northeastern.edu}) \\
Jonathan Rees ({\tt jar@cs.cornell.edu}) \\
June 1992
\end{center}
\vspace{1ex}
Scheme 48 is an implementation of the Scheme programming language based
on a virtual machine architecture. The following is an overview of
the project.
\paragraph{Goals}
\begin{itemize}
\setlength{\itemsep}{0pt}
\item Straightforward, minimal implementation.
\item Flexible experimental apparatus for research in programming
language design and implementation.
\item Easy to make changes to internal data representations, memory
management, and compilation strategy.
\item High reliability.
\item Fast and complete enough to be a good
development environment for Scheme programs.
\end{itemize}
\paragraph{Virtual machine}
The virtual machine executes a simple byte-code instruction set
similar to the target of the Scheme 311 compiler [Clinger, LFP 1984].
The interpreter for the virtual instruction set is itself written in
PreScheme, a systems programming dialect of Scheme. A PreScheme
compiler applies intensive source-to-source rewrites to the
interpreter source code and emits low-level C code. When the output
is then compiled by an optimizing C compiler such as gcc, the result
is a very efficient and portable emulator.
\paragraph{Run-time system}
The virtual machine is initialized from a specified memory image
containing byte-compiled Scheme code and data. Images (including
small stand-alone applications) are built either by a linker or by
writing out the state of an executing program. A standard memory
image contains a Scheme run-time library ({\tt append}, {\tt read},
{\tt write}, etc.), a compiler from Scheme to the virtual instruction
set, and a command processor and debugger. In this way Scheme 48 can
be configured to look like a conventional Lisp interpreter.
In addition to the Scheme run-time library and development
environment, library software includes support for multitasking,
modules (packages), hygienic macros (as described in the Revised$^4$
Scheme report), records, and exception handling.
\paragraph{Applications}
The Scheme 48 system is being used at several sites for research in
memory management, embedded systems, multiprocessing, and computer
system verification. Scheme 48 was chosen as the platform for these
projects because of its internal tractability and flexibility.
\end{document}

87
doc/threads.txt
View File

@ -1,87 +0,0 @@
Threads
The following are exported by the THREADS structure.
(SPAWN thunk)
(SPAWN thunk name)
Create and schedule a new thread that will execute <thunk>. The optional
name is used when printing the thread.
(RELINQUISH-TIMESLICE)
Let other threads run for a while.
(SLEEP time)
Sleep for <time> milliseconds.
(TERMINATE-CURRENT-THREAD)
Kill the current thread.
(THREAD? thing)
#T if thing is a thread, #F otherwise.
(THREAD-NAME thread)
(THREAD-UID thread)
For printing debugging information.
-----
The following are exported by the LOCKS structure.
(MAKE-LOCK) => lock
(OBTAIN-LOCK lock)
(RELEASE-LOCK lock)
Locks are semaphores.
-----
The following are exported by the PLACEHOLDERS structure.
(MAKE-PLACEHOLDER) => placeholder
(PLACEHOLDER-VALUE placeholder) => value of placeholder
(PLACEHOLDER-SET! placeholder value)
(PLACEHOLDER? thing) => #t or #f
Attempts to reference a placeholder before it has been set cause the
referencing thread to block. Setting a placeholder to two different
values is an error. (Previous versions of Scheme 48 called these
`condition variables', which turn out to be somewhat different.)
-----
Threads and the command interpreter.
Each level of the command interpreter has its own set of active
threads. Moving to a new level, for example when an error occurs,
halts all threads belonging to the previous level. Resuming the
a level causes its associated threads to continue running.
The ,threads command inspects the threads running in the stopped
command level.
> ,open threads
> (define (foo) (sleep 1000) (display "Hi") (newline) (foo))
> (spawn foo 'my-thread)
> Hi
(begin (sleep 10000) (display "Done") (newline))
Hi
Interrupt: keyboard
1> (sleep 5000)
; note that the Hi thread doesn't run in this command level
1> ,proceed 0
Hi
; but it resumes when we resume this level
Hi
Done
> Hi
Hi
Hi
Interrupt: keyboard
1> ,threads
'(#{Thread 28 my-thread} #{Thread 27 command-loop})
[0] '#{Thread 28 my-thread}
[1] '#{Thread 27 command-loop}
inspect:

243
doc/todo.txt
View File

@ -1,243 +0,0 @@
--*- Mode: Indented-text; -*-
Scheme 48: list of bugs and things to do.
Last update by RAK on 28 April 1998.
Run-time system bugs:
Shadowing can fail sometimes for macro-referenced variables. E.g.
the following sequence will lose if entered interactively as
three separate forms:
(define (foo x) `(a ,x))
(define cons list)
(foo 1) => (a (1 ()))
Programming environment:
Fuller on-line documentation.
Error recovery. Can do better than ,proceed. LOAD should set up
restart continuations.
Types in scheme-interface (and elsewhere) aren't as tight as they
could be.
LET continuation "pessimization" to retain the environment longer.
Have the disassembler display local variable names.
This ought to be recoverable, but isn't always:
> (let loop ((x '())) (loop (cons 3 x)))
not enough room in heap for stack
The get-cont-from-heap instruction should have an exception
discloser that indicates the actual error (returning a
non-fixnum from application top level).
Separate compilation (compile a module, writing object code to a
file). (Rudiments in misc/separate.scm)
Semicolon comments don't quite work after commands (extra newline
required).
Command (and procedure) to change current directory.
Some procedure in EXEC to take the place of ## in moving values from
one package to another: (transport <from-package> <exp> <to-package>
[<id>]), and/or have eval etc. commands return the value
Batch mode should write error messages to (error-output).
Performance:
Generational GC.
More compact representation for debugging data?
Leaf procedure compilation (RK's rts/no-leaf-env.scm): if no
continuations or lambdas, skip the make-env and access locals
using stack-ref. Expected to gain about 6% in speed.
Optimize loops somehow (maybe using call-template opcode and/or
opportunistic compilation).
The CAML light implementation has good documentation and patches
for optimizing the interpreter's switch (*pc++); perhaps we
could lift some of it. (Range check isn't necessary.)
Floating point support in VM.
Bignum support in VM: use MIT Scheme bignums or GNU Multiple
Precision Arithmetic Library (Torbjorn Granlund <tege@sics.se>).
Faster bignum printer (e.g. the one Richard wrote - but it would be
nice if it were an option tied to bignums, not built in to the
initial image).
Ratnum multiplication and division might be made more efficient by
taking cross-GCD's.
Native code compiler...
Big Scheme bugs / features:
It would be nice to be able to simulate control-C interrupts on
a port other than the initial input port - e.g., on a socket.
This would require creating a new thread to act as a front end.
The new thread would read characters eagerly, buffering
everything except control-C's for the thread that is doing the
real work, and converting control-C's into interrupts.
How about deleting entries from tables?
RPC.
Add call/gcc (invokes the Gnu C compiler).
Module system bugs:
,untrace should undefine as well if the variable wasn't bound
before.
Compound signatures don't get updated when a component signature
changes. They contain a list of signatures with no reinitialization
thunk a la structures and packages.
Module system features:
Check for name conflicts between opened structures.
Implement interface subtraction as a way of dealing with such
conflicts: (WITHOUT (<name> ...) <interface>)
Check for cycles in structure inheritance.
An ,access command, similar to ,open.
Deal with package system state better (for linker). Maybe each
package should point to a data structure containing
*location-uid*, location-name-table, *package-uid*,
package-name-table, and perhaps the compiler-state as well (see
segment.scm).
VM:
Heaps that can grow larger.
Add a test to configure.in that can determine whether ld -A works.
If both it and dlopen() work, then both kinds of dynamic loading
should be made available.
Merge in Olin's changes and extensions (command line processing,
the #! syntax for scripts, external function call, etc.).
Interrupt while writing out image causes an exit. [Fixed?]
A jump-back instruction? Might be easier to use than call-template.
Scrutinize all VM fatal errors to see if any can be recovered
from. E.g. "out of ports" shouldn't cause a VM halt, it should
just cause open-port to return #f or an error code. [Fixed?]
Get VM interp.scm-without-gc.scm working again.
Documentation:
Describe (optimize auto-integrate).
How to use the static linker.
How initial.image and scheme48.image get built, really.
Techniques for debugging the runtime system (debug/for-debugging.scm).
Cleanup:
VM:
Rename "unassigned" to "uninitialized"? Or phase it out entirely.
In unix.c, use getrusage(), when available, to get run time.
Run-time / features / development environment:
A DIVIDE procedure (maybe an instruction as well) that returns two
values.
Figure out how to merge the two type systems (META-METHODS and
META-TYPES). The generic function system could make use of the
SUBTYPE? and INTERSECT? predicates.
Correct floating point, esp. reading and printing. And
(= 1/3 (/ 1. 3.)) returns #t, but ought to return #f.
Parameterize over file name syntax somehow. Currently
big/filename.scm assumes Unix (cf. DIRECTORY-COMPONENT-SEPARATOR,
FILE-NAME-PREFERRED-CASE). Perhaps there should be VM support for
this.
Make sure that the disassembler and assembler are inverses of one
another.
Disassembler should generate S-expression first, and then print
it independently.
Combine conditions, signals, and handle into a single structure?
Figure out a better way to implement ##.
Be consistent about "filename" versus "file-name".
Compiler / linker / module system:
The "reflective tower" isn't really a reflective tower, it's a
syntactic tower. Rename it.
The scanner (file loader) should operate on streams, not lists.
This would result in more uniform and flexible internal
protocols for reading files, scanning for DEFINEs, compiling,
and running - passes could be interleaved or separated easily.
Flush link/data.scm. Linker should instead open the VM module
that includes vm/data.scm.
Flush (optimize ...) clause in DEFINE-STRUCTURE in favor of
optimizer argument to SCAN-STRUCTURES.
Vector patterns and templates ought to be supported in
SYNTAX-RULES.
The DEFINE-INTERFACE forms should contain types for every exported
variable; the code in cprim.scm (and recon.scm?) shouldn't have
to worry about setting up types.
Add ENVIRONMENT-DEFINED? ?
Make USUAL-TRANSFORM return a transform?
Add enough to the node signature to make it usable on its own?
make-c-header-file should put definitions for the interrupt
enumeration into scheme48.h, and unix.c et al should use them.
Flatloading and loading are very different operations, so FLATLOAD
shouldn't do SET-PACKAGE-LOADED?!; instead it should maintain its
own list of flatloaded packages (in a global variable, say).
Etc:
Start using a source control system (like rcs).
There ought to be a sanity check to ensure that the size of the
area as computed by static.scm agrees with the size as computed
by C's sizeof() operator.
What should (syntax-rules (x) ((foo ?body) (let ((x 1)) ?body))) do?
To: jar@cs.cornell.edu
Subject: Not a bug this time. :-)
Date: Tue, 22 Feb 94 19:13:37 -0500
From: Paul Stodghill <stodghil@cs.cornell.edu>
The result of ,expand can be confusing. In particular, it doesn't
distinguish between different identifiers that have the same name.
For instance, in the example below, it would be more useful if the result
of the ,expand was something like,
'((lambda (.x.1) (set! x (- .x.1))) x)
Welcome to Scheme 48 0.31 (made by jar on Sun Feb 13 18:33:57 EST 1994).
Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
Please report bugs to scheme-48-bugs@altdorf.ai.mit.edu.
Type ,? (comma question-mark) for help.
> (define-syntax foo
(syntax-rules ()
((foo var) ((lambda (x) (set! var (- x))) var))))
> (define x 1)
> ,expand (foo x)
'((lambda (x) (set! x (- x))) x)
>
Date: Mon, 14 Jun 93 18:33:30 HKT
From: shivers@csd.hku.hk
To: kelsey@flora.ccs.neu.edu
Cc: jar@cs.cornell.edu
Subject: Scheme 48
...
All true. My major motivation was portability. I also found the module system
to be a big win. Other things that influenced me were (1) elegance and
modularity -- I felt I could comprehend and mung the system as needed (2)
reasonable efficiency and small size and (3) real, full R4RS+ support (most
small systems do it partly).
Actually, I wouldn't say the programming environment is particularly
exceptional, unless you count the module system.
A small thing lacking in other Schemes that really reduced my debug times: the
loader would complain about undefined free var refs in my code. This
frequently picked out variable spelling errors, inconsistent name linkages,
and forgotten procedure defs. Not a big thing, but really effective.
Another win was simply having the implementors around for detailed
explanations and support.
Problems I had with S48:
- Inability to mess with the VM, as it is written in a language that can
be compiled by only 1 person in the world.
- The foreign-function support was quite limited, and the foreign-data support
was basically non-existent. Exporting gc'd data to C, gc'ing data allocated
in C, hooks into the GC, importing C data into Scheme -- no support. Elk
handles this better, as that is critical to the type of applications at
which elk is targeted.
I fixed some of this myself -- helped by your general, portable low-level ff
interface, which was well-designed in terms of those goals -- but I couldn't
do much about foreign-data support.
- No support currently for linking static heap data into a text-pages
area to reduce gc copying and shrink the dynamic heap.
- The module system was frequently frustrating. The non-uniform , command
language, bugs, the restrictions of living with a module system,
being blocked from accessing primitives whose bindings had been
gc'd away at link time, and awkwardnesses in the user interface really
slowed me down.
The module system was also a great help; these are simply the problems
of life with an experimental system, as opposed to a polished final
product.
[But] all in all, S48 was the best choice I could have made.

240
doc/type.txt
View File

@ -1,240 +0,0 @@
The Type System
Scheme 48 has a rudimentary type system. Its main purpose is to
generate helpful compile-time diagnostics.
Currently you don't get much checking beyond wrong number of arguments
warnings unless you're compiling a package that has an (OPTIMIZE ...)
clause in its definition (e.g. (OPTIMIZE EXPAND) or (OPTIMIZE
AUTO-INTEGRATE)). The reason that type checking is disabled most of
the time is that it increases compilation time by about 33%.
A design goal is to assign types to all valid Scheme programs. That
is, type warnings should not be generated for programs that could work
according to Scheme's dynamic semantics. For example, no warning
should be produced for
(define (foo x y) (if x (+ y 1) (car y)))
Warnings could in principle be produced for particular calls to FOO
that would definitely go wrong, such as (foo #t 'a).
The type system assumes that all code is potentially reachable. This
means that there will be some warnings for programs that cannot go
wrong, e.g. (if #t 3 (car 7)).
Additionally, it's assumed that in a (BEGIN ...) or combination, every
argument or command will always be executed. This won't be the case
if there can be a throw out of the middle. For example, in
(call-with-current-continuation
(lambda (k)
(if (not (number? x))
(k #f))
(+ x 1)))
the type system might deduce that X must be a number (which is false).
The type reconstruction algorithm (such as it is) is in
bcomp/recon.scm. The implementation finds some specific procedure
types for LAMBDA expressions, but generally gives up pretty quickly.
Notation
--------
F : T means that form F has static type T. T1 <= T2, or T1 is under
T2, means that T1 is a subtype of T2; that is, if a form of type T2 is
acceptable in some context, then so is a form of type T1.
Non-expressions
---------------
Not every valid Scheme form is an expression. Forms that are not
expressions are syntactic keywords, definitions, types, and structure
names.
If a name is bound to a macro or special operator, then an occurrence
of that name has type :SYNTAX. E.g.
cond : :syntax
Definitions have type :DEFINITION. E.g.
(begin (define x 1) (define y 2)) : :definition
Thus type checking subsumes syntax checking.
Types (other than :TYPE itself?) have type :TYPE.
The type of a structure is its interface. E.g.
(define-structure foo (export a b) ...)
foo : (export a b)
Values
------
All expressions have type :VALUES. They may have more specific
types as well.
If E1 ... En have types T1 ... Tn with Ti <= :VALUE, then
the expression (VALUES E1 ... En) has type (SOME-VALUES T1 ... Tn).
If T <= :VALUE then (SOME-VALUES T) is equivalent to T.
Procedure types
---------------
Procedure types have the form (PROCEDURE T1 T2), where T1 and T2 are
under :VALUES. Examples:
(lambda (x) (values x 1)) :
(procedure (some-values :value) (some-values :value :number))
cons : (procedure (some-values :value :value) :pair)
Fixed-arity procedure types (PROCEDURE (SOME-VALUES T1 ... TN) T) are
so common that the abbreviated syntax (PROC (T1 ... Tn) T) is
defined to mean the same thing. E.g.
cons : (proc (:value :value) :pair)
E : (PROCEDURE T1 T2) means that in a call to a value of E, if the
argument sequence has any type other than T1, then the call can be
expected to "go wrong" (provoke a type error) at run time. This is
not to say it will definitely go wrong, but that it is just a matter
of luck if it doesn't. If the argument sequence does have type T1,
then the call might or might not go wrong, and any return value(s)
will have type T2.
For example,
(lambda (x) (+ (begin (set! x '(3)) 5) (car x))) :
(proc (:pair) :value),
because if the arguments to + are evaluated from right to left, and X
is not a pair, then there will be a run time type error.
Some primitive procedures have their own special typing rules.
Examples include VALUES, CALL-WITH-VALUES, and PRIMITIVE-CATCH.
Variable types
--------------
Assignable variables have type (VARIABLE T), where T for now will
always be :VALUE. In (SET! V E), V must have type (VARIABLE T) for
some T.
Loopholes
---------
The construct (loophole T E) is considered to have type T no matter
what type E has. Among other things, this allows a rudimentary static
abstract data type facility. For example, record types defined using
DEFINE-RECORD-TYPE (rts/bummed-jar-defrecord.scm) are established as
new base types.
Type lattice
------------
The subtype relation is implemented by the procedure COMPATIBLE-TYPES?
(in bcomp/mtypes.scm). If (COMPATIBLE-TYPES? T1 T2) is 'definitely,
then T1 <= T2. If it's #T, then T1 and T2 intersect.
The type lattice has no bottom or top elements.
The types :SYNTAX, :VALUES, :DEFINITION, :STRUCTURE, and :TYPE are
incomparable and maximal.
The following are a comprehensive set of subtyping rules for the type
system as it stands. Additional rules may be added in the future.
- (SOME-VALUES T1 ... Tn) <= :VALUES.
- If T1 <= T1', ..., Tn <= Tn' then (SOME-VALUES T1 ... Tn) <=
(SOME-VALUES T1' ... Tn').
- T <= (SOME-VALUES T).
- Basic value types, which include :NUMBER, :CHAR, :BOOLEAN, :PAIR,
:STRING, and :UNSPECIFIC, are all under :VALUE.
- If T1' <= T1 and T2 <= T2', then (PROCEDURE T1 T2) <= (PROCEDURE
T1' T2').
- (VARIABLE T) <= T.
- :ZERO, the result type of infinite loops and calls to
continuations, is under :VALUE, but perhaps shouldn't be. (E.g.
maybe it should be just under :VALUES instead.)
- (EXPORT (<name> T) ...) is under :STRUCTURE.
[Not yet implemented.]
Type well-formedness
--------------------
In (SOME-VALUES T1 ... Tn), T1 ... Tn must be under :VALUE.
In (PROCEDURE T1 T2), T1 and T2 must be under :VALUES.
In (VARIABLE T), T must be under :VALUE.
Module system
-------------
The rules for interfaces and structures are not yet very well worked
out.
Interfaces are types. The type of a structure is its interface.
(Compare with Pebble's "bindings" and "declarations".)
An interface has the basic form (EXPORT (<name> <type>) ...).
There are two kinds of abbreviations:
- (EXPORT ... <name> ...) means the same as
(EXPORT ... (<name> :VALUE) ...)
- (EXPORT ... ((<name1> <name2> ...) <type>) ...) means the same as
(EXPORT ... (<name1> <type>) (<name2> <type>) etc. ...)
Distinct interfaces are not comparable.
If a form S has type (EXPORT ... (name T) ...), then the form
(STRUCTURE-REF S name) has type T. Note that T needn't be a :VALUE
type; e.g.
(structure-ref scheme cond) : :syntax
When a package is loaded or otherwise compiled, the type that is
reconstructed or inherited for each exported name is checked against
the type specified in the signature. (Cf. procedure SCAN-STRUCTURES
in bcomp/scan.scm.)
<explain the role of the expander in type checking... compile-call
doesn't do much checking if the arguments aren't expanded...>
Future work
-----------
There probably ought to be dependent sums and products and/or
universal and existential types. In particular, it would be nice to
be able to get static checking for abstract types, even if they're not
implemented using records.
Type constructors (like STREAM-OF or COMPUTATION-OF) would be nice.
There are many loose ends in the implementation. For example, type
and type constructor names aren't always lexically scoped; sometimes
their scope is global. Packages that open the LOOPHOLES structure
(which exports LOOPHOLE) don't always open TYPES (which would be a bad
idea given the way TYPES is currently defined); LOOPHOLE works in
spite of that.
Figure out whether :TYPE : :TYPE.
-----
Original by JAR, 20 July 93.
Updated by JAR, 5 December 93.

47
emacs/README
View File

@ -1,47 +0,0 @@
Date: Thu, 9 Jul 92 13:26:05 HKT
From: shivers@csd.hku.hk (Olin G. Shivers)
To: jar@cs.cornell.edu
In-Reply-To: Jonathan Rees's message of Wed, 8 Jul 92 22:15:22 -0400 <9207090215.AA00991@sindri.cs.cornell.edu>
Subject: cmulisp
It's also in Ozan's repository, but I don't know how up-to-date it is.
It's always useful to list his repository as a possible location, tho.
-Olin
/afs/cs.cmu.edu/user/shivers/lib/Readme:
This directory contains the following subdirectories:
emacs Gnu emacs packages.
papers My papers, in .dvi and postscript form.
tex LaTeX packages.
All of these files can be anonymously ftp'd.
-Olin
July 3, 1991
===============================================================================
Directions for anonymous ftp:
1. ftp to any CMU machine with access to the /afs network file system.
Almost any machine will do; some possibilities are:
cs.cmu.edu 128.2.222.173
a.gp.cs.cmu.edu 128.2.242.7
f.gp.cs.cmu.edu 128.2.250.164
h.gp.cs.cmu.edu 128.2.254.156
k.gp.cs.cmu.edu 128.2.254.137
2. login as anonymous
You are supposed to provide username@host as the password. The CMU
ftp demon actually checks to ensure there's an "@" in the password.
So you can't just say "foo"; you have to say "foo@bar".
3. cd /afs/cs.cmu.edu/user/shivers/lib
CMU ftp restricts the directories you can access anonymously,
so you must cd straight to the .../lib directory or its descendants.
4. If you are transfering .dvi or other binary files, set the file transfer
mode to raw binary with one of the following commands:
type image
type binary
image
binary
If you don't do this, the files may be garbled.
5. Use dir or ls to list the directory.
6. Transfer the files you want.

99
emacs/cmuscheme48.el
View File

@ -1,99 +0,0 @@
;;; cmuscheme48.el -- Scheme process in a buffer. Adapted from cmuscheme.el.
(provide 'cmuscheme48)
(require 'cmuscheme)
(define-key scheme-mode-map "\M-\C-x" 'scheme48-send-definition);gnu convention
(define-key scheme-mode-map "\C-x\C-e" 'scheme48-send-last-sexp);gnu convention
(define-key scheme-mode-map "\C-ce" 'scheme48-send-definition)
(define-key scheme-mode-map "\C-c\C-e" 'scheme48-send-definition-and-go)
(define-key scheme-mode-map "\C-cr" 'scheme48-send-region)
(define-key scheme-mode-map "\C-c\C-r" 'scheme48-send-region-and-go)
(define-key scheme-mode-map "\C-cl" 'scheme48-load-file)
(defun scheme48-send-region (start end)
"Send the current region to the inferior Scheme process."
(interactive "r")
(comint-send-string (scheme-proc)
(concat ",from-file "
(enough-scheme-file-name
(buffer-file-name (current-buffer)))
"\n"))
(comint-send-region (scheme-proc) start end)
(comint-send-string (scheme-proc) " ,end\n"))
; This assumes that when you load things into Scheme 48, you type
; names of files in your home directory using the syntax "~/".
; Similarly for current directory. Maybe we ought to send multiple
; file names to Scheme and let it look at all of them.
(defun enough-scheme-file-name (file)
(let* ((scheme-dir
(save-excursion
(set-buffer scheme-buffer)
(expand-file-name default-directory)))
(len (length scheme-dir)))
(if (and (> (length file) len)
(string-equal scheme-dir (substring file 0 len)))
(substring file len)
(if *scheme48-home-directory-kludge*
(let* ((home-dir (expand-file-name "~/"))
(len (length home-dir)))
(if (and (> (length file) len)
(string-equal home-dir (substring file 0 len)))
(concat "~/" (substring file len))
file))
file))))
(defvar *scheme48-home-directory-kludge* t)
(defun scheme48-send-definition (losep)
"Send the current definition to the inferior Scheme48 process."
(interactive "P")
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(if losep
(let ((loser "/tmp/s48lose.tmp"))
(write-region (point) end loser)
(scheme48-load-file loser))
(scheme48-send-region (point) end)))))
(defun scheme48-send-last-sexp ()
"Send the previous sexp to the inferior Scheme process."
(interactive)
(scheme48-send-region (save-excursion (backward-sexp) (point)) (point)))
(defun scheme48-send-region-and-go (start end)
"Send the current region to the inferior Scheme48 process,
and switch to the process buffer."
(interactive "r")
(scheme48-send-region start end)
(switch-to-scheme t))
(defun scheme48-send-definition-and-go (losep)
"Send the current definition to the inferior Scheme48,
and switch to the process buffer."
(interactive "P")
(scheme48-send-definition losep)
(switch-to-scheme t))
(defun scheme48-load-file (file-name)
"Load a Scheme file into the inferior Scheme48 process."
(interactive (comint-get-source "Load Scheme48 file: "
scheme-prev-l/c-dir/file
scheme-source-modes t)) ; T because LOAD
; needs an exact name
(comint-check-source file-name) ; Check to see if buffer needs saved.
(setq scheme-prev-l/c-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(comint-send-string (scheme-proc)
(concat ",load "
(enough-scheme-file-name file-name)
"\n")))
; For Pertti Kellom\"aki's debugger.
; Cf. misc/psd-s48.scm.
(defvar psd-using-slib nil "Scheme 48, not SLIB.")

91
emacs/jar-hacks.el
View File

@ -1,91 +0,0 @@
; Comment out region
(defun comment-out-region (arg)
"Insert comment string at beginning of each line in the region."
(interactive "P")
(let (start end)
(if (< (point) (mark))
(setq start (point) end (mark-marker))
(setq start (mark) end (point-marker)))
(save-excursion
(untabify start (marker-position end))
(goto-char start)
(if (not (bolp))
(progn (end-of-line) (forward-char)))
(while (< (point) (marker-position end))
(if (eq arg '-)
(if (looking-at comment-start)
(delete-char (length comment-start)))
(insert comment-start))
(end-of-line)
(forward-char)))))
;(defun uncomment-out-region (arg)
; (interactive nil)
; (comment-out-region '-))
; Mini-Find Tag
(defvar last-mini-tag "" "Last tag sought by mini-find-tag.")
(defun mini-find-tag (tagname &optional next)
"Search for a definition of TAGNAME in current buffer.
If TAGNAME is a null string, the expression in the buffer
around or before point is used as the tag name.
If second arg NEXT is non-nil (interactively, with prefix arg),
searches for the next definition in the buffer
that matches the tag name used in the previous mini-find-tag."
(interactive (if current-prefix-arg
'(nil t)
(list (read-string "Mini-find tag: "))))
(if (equal tagname "") ;See definition of find-tag.
(setq tagname (save-excursion
(buffer-substring
(progn (backward-sexp 1) (point))
(progn (forward-sexp 1) (point))))))
(let ((pt (save-excursion
(if (not next)
(goto-char (point-min))
(setq tagname last-mini-tag))
(setq last-mini-tag tagname)
(if (re-search-forward
(concat "^(def.*" tagname)
nil t)
(point)
nil))))
(if pt
(progn (set-mark-command nil)
(goto-char pt))
(signal 'search-failed '()))))
; indent-differently
(defun indent-differently ()
"Make the current line indent like the body of a special form by
changing the operator's scheme-indent-hook appropriately."
(interactive nil)
(let ((here (point)))
(save-excursion
(back-to-indentation)
(backward-up-list 1)
(forward-char 1)
(let ((i -1)
(function nil)
(p (point)))
(while (<= (point) here)
(setq i (+ i 1))
(forward-sexp 1)
(if (= i 0)
(setq function (buffer-substring p (point)))))
(setq i (- i 1))
(let ((name (intern (downcase function))))
(cond ((equal (get name 'scheme-indent-hook) i)
(message "Indent %s nil" name)
(put name 'scheme-indent-hook nil))
(t
(message "Indent %s %d" name i)
(put name 'scheme-indent-hook i))))))
(scheme-indent-line)))

238
install-sh
View File

@ -1,238 +0,0 @@
#! /bin/sh
#
# install - install a program, script, or datafile
# This comes from X11R5.
#
# Calling this script install-sh is preferred over install.sh, to prevent
# `make' implicit rules from creating a file called install from it
# when there is no Makefile.
#
# This script is compatible with the BSD install script, but was written
# from scratch.
#
# set DOITPROG to echo to test this script
# Don't use :- since 4.3BSD and earlier shells don't like it.
doit="${DOITPROG-}"
# put in absolute paths if you don't have them in your path; or use env. vars.
mvprog="${MVPROG-mv}"
cpprog="${CPPROG-cp}"
chmodprog="${CHMODPROG-chmod}"
chownprog="${CHOWNPROG-chown}"
chgrpprog="${CHGRPPROG-chgrp}"
stripprog="${STRIPPROG-strip}"
rmprog="${RMPROG-rm}"
mkdirprog="${MKDIRPROG-mkdir}"
transformbasename=""
transform_arg=""
instcmd="$mvprog"
chmodcmd="$chmodprog 0755"
chowncmd=""
chgrpcmd=""
stripcmd=""
rmcmd="$rmprog -f"
mvcmd="$mvprog"
src=""
dst=""
dir_arg=""
while [ x"$1" != x ]; do
case $1 in
-c) instcmd="$cpprog"
shift
continue;;
-d) dir_arg=true
shift
continue;;
-m) chmodcmd="$chmodprog $2"
shift
shift
continue;;
-o) chowncmd="$chownprog $2"
shift
shift
continue;;
-g) chgrpcmd="$chgrpprog $2"
shift
shift
continue;;
-s) stripcmd="$stripprog"
shift
continue;;
-t=*) transformarg=`echo $1 | sed 's/-t=//'`
shift
continue;;
-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
shift
continue;;
*) if [ x"$src" = x ]
then
src=$1
else
# this colon is to work around a 386BSD /bin/sh bug
:
dst=$1
fi
shift
continue;;
esac
done
if [ x"$src" = x ]
then
echo "install: no input file specified"
exit 1
else
true
fi
if [ x"$dir_arg" != x ]; then
dst=$src
src=""
if [ -d $dst ]; then
instcmd=:
else
instcmd=mkdir
fi
else
# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
# might cause directories to be created, which would be especially bad
# if $src (and thus $dsttmp) contains '*'.
if [ -f $src -o -d $src ]
then
true
else
echo "install: $src does not exist"
exit 1
fi
if [ x"$dst" = x ]
then
echo "install: no destination specified"
exit 1
else
true
fi
# If destination is a directory, append the input filename; if your system
# does not like double slashes in filenames, you may need to add some logic
if [ -d $dst ]
then
dst="$dst"/`basename $src`
else
true
fi
fi
## this sed command emulates the dirname command
dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
# Make sure that the destination directory exists.
# this part is taken from Noah Friedman's mkinstalldirs script
# Skip lots of stat calls in the usual case.
if [ ! -d "$dstdir" ]; then
defaultIFS='
'
IFS="${IFS-${defaultIFS}}"
oIFS="${IFS}"
# Some sh's can't handle IFS=/ for some reason.
IFS='%'
set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
IFS="${oIFS}"
pathcomp=''
while [ $# -ne 0 ] ; do
pathcomp="${pathcomp}${1}"
shift
if [ ! -d "${pathcomp}" ] ;
then
$mkdirprog "${pathcomp}"
else
true
fi
pathcomp="${pathcomp}/"
done
fi
if [ x"$dir_arg" != x ]
then
$doit $instcmd $dst &&
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
else
# If we're going to rename the final executable, determine the name now.
if [ x"$transformarg" = x ]
then
dstfile=`basename $dst`
else
dstfile=`basename $dst $transformbasename |
sed $transformarg`$transformbasename
fi
# don't allow the sed command to completely eliminate the filename
if [ x"$dstfile" = x ]
then
dstfile=`basename $dst`
else
true
fi
# Make a temp file name in the proper directory.
dsttmp=$dstdir/#inst.$$#
# Move or copy the file name to the temp name
$doit $instcmd $src $dsttmp &&
trap "rm -f ${dsttmp}" 0 &&
# and set any options; do chmod last to preserve setuid bits
# If any of these fail, we abort the whole thing. If we want to
# ignore errors from any of these, just make sure not to ignore
# errors from the above "$doit $instcmd $src $dsttmp" command.
if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
# Now rename the file to the real destination.
$doit $rmcmd -f $dstdir/$dstfile &&
$doit $mvcmd $dsttmp $dstdir/$dstfile
fi &&
exit 0

27
ps-compiler/compile-vm-no-gc.scm
View File

@ -1,27 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
(config '(load "../scheme/vm/macro-package-defs.scm"))
(load-package 'vm-architecture)
(in 'forms '(run (set! *duplicate-lambda-size* 30)))
(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
(in 'prescheme-compiler
'(run (prescheme-compiler
'(vm external-gc-roots)
'("../scheme/vm/interfaces.scm"
"../scheme/vm/ps-package-defs.scm"
"../scheme/vm/package-defs.scm"
"../scheme/vm/no-gc-package-defs.scm")
's48-init
"../scheme/vm/scheme48vm.c"
'(header "#include \"scheme48vm-prelude.h\"")
'(copy (interpreter push-continuation-on-stack))
'(no-copy (interpreter interpret
application-exception
handle-interrupt
uuo)
;(vm restart)
(interpreter-gc collect-saving-temp
collect-saving-temps)))))
; '(shadow ((interpreter restart)
; (interpreter *val* *code-pointer*)
; (stack *stack* *env*))))))

29
ps-compiler/compile-vm.scm
View File

@ -1,29 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
(config '(load "../scheme/vm/macro-package-defs.scm"))
(load-package 'vm-architecture)
(in 'forms '(run (set! *duplicate-lambda-size* 30)))
(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
(in 'prescheme-compiler
'(run (prescheme-compiler
'(interpreter heap-init)
'("../scheme/vm/interfaces.scm"
"../scheme/vm/ps-package-defs.scm"
"../scheme/vm/package-defs.scm")
'scheme48-init
"../scheme/vm/scheme48vm.c"
'(header "#include \"scheme48vm-prelude.h\"")
'(copy (heap walk-over-type-in-area)
(fixnum-arithmetic quotient-carefully))
'(no-copy (interpreter interpret
application-exception
handle-interrupt
uuo
collect-saving-temp
do-gc))
'(integrate (copy-next do-gc)
(copy-object do-gc))
'(shadow ((interpreter do-gc) (heap *hp*))
((interpreter restart)
(interpreter *val* *code-pointer*)
(stack *stack* *env*))))))

340
ps-compiler/doc/node.txt
View File

@ -1,340 +0,0 @@
In the compiler `continuation' means a continuation that is a lambda node.
Non-lambda continuation arguments, such as the argument to a RETURN, are
not referred to as continuations (the argument isn't a continuation, it
is a variable that is bound to a continuation).
Every node has the following fields:
variant ; one of LITERAL, REFERENCE, LAMBDA, or CALL
parent ; parent node
index ; index of this node in parent, if parent is a call node
simplified? ; true if it has already been simplified; if this is #F
; then all of this node's ancestors must also be unsimplified
flag ; useful flag, all users must leave this is #F
Literal nodes:
value ; the value
type ; the type of the value (important for statically typed languages,
; not so useful for Scheme)
Reference nodes:
variable ; the referenced variable; the binder of the variable must be
; an ancestor of the reference node
Call nodes:
primop ; the primitive being called
args ; vector of argument nodes
exits ; the number of arguments that are continuations; the continuation
; arguments come before the non-continuation ones
source ; source info; used for error messages
Primops are either trivial or nontrivial. Trivial primops only return a value
and have no side effects. Calls to trivial primops never have continuation
arguments and are always arguments to other calls. Calls to nontrivial primops
may or may not have continuations and are always the body of a lambda node.
Lambda nodes:
type ; one of PROC, CONT, or JUMP (and maybe THROW at some point)
name ; symbol (for debugging)
id ; unique integer (for debugging)
body ; the call-node that is the body of the lambda
variables ; a list of variable records, with #Fs for ignored positions
source ; source info; used for error messages
protocol ; calling protocol from the source language
block ; for use during code generation
env ; for use when adding explicit environments
PROC's are general procedures. The first variable of a PROC will be bound
to the PROC's continuation.
CONT's are continuation arguments to calls.
JUMP's are continuations bound by LET or LETREC, whose calling points are
known, and which are created and called within a single PROC.
Variables:
name ; source code name for variable (used for debugging only)
id ; unique numeric identifier (used for debugging only)
type ; type of variable's value
binder ; LAMBDA node which binds this variable (or #F if none)
refs ; list of reference nodes n for which (REFERENCE-VARIABLE n)
; = this variable
flag ; useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
; all users must leave this is #F
flags ; list of various annotations, e.g. IGNORABLE
generate ; for whatever code generation wants
----------------------------------------------------------------
The node tree has a very regular lexical structure:
The body of every lambda node is a non-trivial call.
The parent of every non-trivial call is a lambda node.
Every CONT lambda is a continuation of a non-trivial call.
Every JUMP lambda is an argument to either the LET or the LETREC
primops (described below).
The lambda node that binds a variable is an ancestor of every reference
to that variable.
If you start from any leaf node and follow the parent pointers up through the
node tree, you first go through some number, possible zero, of trivial calls
until a non-trivial call is reached. From that point on non-trivial calls
alternate with CONT nodes until a PROC or JUMP lambda is reached. Going up
from a PROC lambda is the same as going up from a leaf, while JUMP lambdas
are always arguments to LET or LETREC, both of which are non-trivial.
A basic block appears as a sequence of non-trivial calls with a single
continuation apiece. The block begins with a PROC or JUMP lambda, or
with a CONT lambda that is an argument to a call with two or more
continuations, and ends with a call that has either no continuations,
or two or more.
Basic blocks are grouped into trees. The root of every tree is either
a PROC or JUMP lambda, the branch points are calls with two or more
continuations, and the leaves are jumps or returns. Within a tree
the control flow follows the lexical structure of the program from
parent to child (if we ignore calls to other PROCs).
Every JUMP lambda is called from within only one PROC lambda, so a PROC
can be considered to consist of a set of trees, the leaves of which either
return from that PROC or jump to the top of another tree in the set.
----------------------------------------------------------------
Primops:
id ; unique symbol identifying this primop
trivial? ; #t if this primop has does not accept a continuation
side-effects ; one of #F, READ, WRITE, ALLOCATE, or IO
simplify-call-proc ; simplify method
primop-cost-proc ; cost of executing this operation
; (in some undisclosed metric)
return-type-proc ; the type of the value returned (for trivial primops only)
proc-data ; more data for the procedure primops
cond-data ; more data for conditional primops
code-data ; code generation data
`procedure' primops are those that call one of their values.
`conditional' primops are those that have more than one continuation.
Below is a list of the standard primops. All but the last two are non-trivial.
For the following the five primops the lambda node being called, jumped to,
or whatever has been identified by the compiler, and the number of variables
that the lambda node has matches the number of arguments.
(CALL <cont> <proc> . <args>)
(TAIL-CALL <cont-var> <proc> . <args>)
(RETURN <cont-var> . <args>)
(JUMP <jump-var> . <args>)
; (THROW <throw-var> . <args>) not yet implemented
These are the same as the above except that the procedure has not been
identified by the compiler. There is no UNKNOWN-JUMP because all calls
to JUMP lambdas must be known.
(UNKNOWN-CALL <cont> <proc> . <args>)
(UNKNOWN-TAIL-CALL <cont> <proc> . <args>)
(UNKNOWN-RETURN <cont-var> . <args>)
PROC lambdas are called with either CALL or TAIL-CALL if all of their call
sites have been identified, or with UNKNOWN-CALL or UNKNOWN-TAIL-CALL if not.
JUMP lambdas are called using JUMP.
LET binds random values, such as lambda nodes or the results of trivial
calls, to variables. This primop only exists because of the requirement
that every call have a primop; all it does is apply <cont> to <args>
(it is called LET instead of APPLY because LET forms in the source code
become calls to this primop).
(LET <cont> . <args>)
Recursive binding:
(LETREC1 <cont>)
(LETREC2 <cont> <id-var> <lambda1> <lambda2> ...)
These are always used together, with the body of the continuation to LETREC1
being a call to LETREC2. The two calls together look like:
(LETREC1 (lambda (<id-var> <var1> ... <varN>)
(LETREC2 <cont> <id-var> <lambda1> ... <lambdaN>)))
which the CPS pretty-printer prints as:
(let* (...
((id-var var1 ... varN) (letrec1))
(() (letrec2 id-var lambda1 ... lambdaN))
...)
...)
The end result is to bind <varI> to <lambdaI>. The point to the excercise
is that lambdas occur within the scope of the variables.
Undefined effect. This takes a continuation variable as an argument only
so that the continuation variable is always reached.
(UNDEFINED-EFFECT <cont-var> ...)
Accessing and mutating the store.
Cells are used to implement SET! on lexically bound variables. GLOBAL-SET!
and GLOBAL-REF are used for module variables that may be set.
(CELL-SET! <cont> <cell> <value>)
(GLOBAL-SET! <cont> <global-var> <value>)
(CELL-REF <cell>) ; trivial
(GLOBAL-REF <global-var>) ; trivial
----------------------------------------------------------------
Printing out the node tree.
The following procedure:
(define (fact n)
(let loop ((n n) (r 1))
(if (< n 2)
r
(loop (- n 1) (* n r)))))
when converted into nodes is:
(LAMBDAp (c_6 n_1)
(letrec1 (LAMBDAc (x_13 loop_2)
(letrec2 (LAMBDAc ()
(unknown-tail-call c_6 loop_2 n_1 '1))
x_13
(LAMBDAp (c_8 n_3 r_4)
(test
(LAMBDAc ()
(unknown-return c_8 r_4))
(LAMBDAc ()
(unknown-tail-call c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
(< n_3 '2)))))))
where LAMBDAp is a PROC lambda and LAMBDAc is a CONT lambda. Lexically bound
variables are printed as <name>_<id> and constants as '<value>. This is not
very readable, and larger procedures are much worse. The first step in making
it more comprehensible is to print each lambda node separately with a marker
to indicate where it appears in the tree.
(LAMBDAp fact_7 (c_6 n_1)
(letrec1 1 ^c_14))
(LAMBDAc c_14 (x_13 loop_2)
(letrec2 1 ^c_12 x_13 ^loop_9))
(LAMBDAc c_12 ()
(unknown-tail-call 0 c_6 loop_2 n_1 '1))
(LAMBDAp loop9 (c_8 n_3 r_4)
(test 2 ^g_10 ^g_11 (< n_3 '2)))
(LAMBDAc g_10 ()
(unknown-return 0 c_8 r_4))
(LAMBDAc g_11 ()
(unknown-tail-call 0 c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
The labels used are the names and id's of the lambda nodes, with a ^ in front
to distinguish them from variables. The code for each lambda is indented
slightly more than the lambda in which it actually occurs. To make the
distinction between continuation and non-continuation lambdas clearer the
number of continuation arguments to a call is printed just after the primop
(for example the first two arguments to TEST are continuations).
The first three calls form a basic block because the first two calls have
exactly one continuation apiece. To make this more easily seen these
calls can be printed using a more condensed notation:
(LAMBDAp fact_7 (c_6 n_1)
(LET* (((x_13 loop_2) (letrec1))
(() (letrec2 x_13 ^loop_9)))
(unknown-tail-call 0 c_6 loop_2 n_1 '1)))
The continuations are not printed as arguments but instead their variables
are printed to the left of the call in a parody of Scheme's LET*. The results
of the LETREC1 are bound to the variables X_13 and LOOP_2 as would happen with
the real LET* (if it allowed calls to return multiple values).
Finally, here is the way the code for FACT is actually printed:
7 (P fact_7 (c_6 n_1)
14 (LET* (((x_13 loop_2)
(letrec1))
12 (() (letrec2 x_13 ^loop_9)))
(unknown-tail-call 0 c_6 loop_2 n_1 '1)))
9 (P loop_9 (c_8 n_3 r_4)
(test 2 ^g_10 ^g_11 (< n_3 '2)))
10 (C g_10 ()
(unknown-return 0 c_8 r_4))
11 (C g_11 ()
(unknown-tail-call 0 c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
The ID number of every lambda node is printed out at the beginning of the
line on which the code for the lambda appears. This is redundant for the
lambdas that are not printed as part of a LET*. The word `LAMBDA' is not
printed. The (letrec1) call appears on a new line because the printer
indents the calls in LET* a fixed amount.
The reason for printing the ID numbers is so that the actual nodes can be
obtained. Once a lambda has been printed (either by the pretty printer or
by the regular printer), (NODE-UNHASH <id>) will return it:
scheme-compiler> (node-unhash 9)
'#{Node lambda loop 9}
scheme-compiler> ,inspect ##
'#{Node lambda loop 9}
[0: variant] 'lambda
[1: parent] '#{Node call letrec2}
[2: index] 2
[3: simplified?] #t
[4: flag] #f
[5: stuff-0] '#{Node call test}
[6: stuff-1] '(#{Variable n 3} #{Variable r 4})
[7: stuff-2] '(#{Name #} (n r) (if # r #))
[8: stuff-3] '#{Lambda-data}
----------------------------------------------------------------
Simplification.
The factorial procedure above is how it looks when originally translated
into a node tree. The next step in compilation is to simplify the tree,
doing constant folding, identifying call points, and so on. The simplified
version of FACT is:
7 (P fact_7 (c_6 n_1)
14 (LET* (((x_13 loop_2)
(letrec1))
12 (() (letrec2 x_13 ^loop_9)))
(jump 0 loop_2 n_1 '1)))
9 (J loop_9 (n_3 r_4)
(test 2 ^g_10 ^g_11 (< n_3 '2)))
10 (C g_10 ()
(unknown-return 0 c_6 r_4))
11 (C g_11 ()
(jump 0 loop_2 (+ '-1 n_3) (* n_3 r_4)))
The only change is that the loop has been turned into a JUMP lambda.
----------------------------------------------------------------
Still to describe:
protocol determination
simplifier moving stuff down, duplicating, later passes move values back up

15
ps-compiler/doc/todo.txt
View File

@ -1,15 +0,0 @@
There is a question about the simplifier for -.
Also, should (- x x) be checked for?
Join substitute is not quite right: might have (some-test cont1 cont2 V <huge>)
where V is being tested. As it stands we'll duplicate <huge>. Should check
that it is either small or contains no references to V (in which case we lift
it with the conts).
Need to come up with good numbers for the maximum size of procs and jumps
that should be duplicated.
Can join-substitute move stuff above a test?
Pre-Scheme type checker dies on (car '()) if a LET has more variables
than values.

124
ps-compiler/front/cps.scm
View File

@ -1,124 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; (cps-call <primop> <exits> <first-arg-index> <args> <cps>) ->
; <call-node> + <top-call-node> + <bottom-lambda-node>
;
; (cps-sequence <nodes> <cps>) -> <last-node> + <top-call> + <bottom-lambda>
;
; (<cps> <node>) -> <value-node> + <top-call-node> + <bottom-lambda-node>
(define (cps-call primop exits first-arg-index args cps)
(let ((call (make-call-node primop
(+ (length args) first-arg-index)
exits))
(arguments (make-arg-nodes args first-arg-index cps)))
(let loop ((args arguments) (first #f) (last #f))
(if (null? args)
(values call first last)
(let ((arg (car args)))
(attach call (arg-index arg) (arg-value arg))
(if (and last (arg-first arg))
(attach-body last (arg-first arg)))
(loop (cdr args)
(or first (arg-first arg))
(or (arg-last arg) last)))))))
; Record to hold information about arguments to calls.
(define-record-type arg :arg
(make-arg index rank value first last)
arg?
(index arg-index) ; The index of this argument in the call.
(rank arg-rank) ; The estimated cost of executing this node at run time.
(value arg-value) ; What CPS returned for this argument.
(first arg-first)
(last arg-last))
; Convert the elements of EXP into nodes (if they aren't already) and put
; them into an ARG record. Returns the list of ARG records sorted
; by ARG-RANK.
(define (make-arg-nodes exp start cps)
(do ((index start (+ index 1))
(args exp (cdr args))
(vals '() (cons (receive (value first last)
(cps (car args))
(make-arg index (node-rank first) value first last))
vals)))
((null? args)
(sort-list vals
(lambda (v1 v2)
(> (arg-rank v1) (arg-rank v2)))))))
; Complexity analysis used to order argument evaluation. More complex
; arguments are to be evaluated first. This just counts reference nodes.
; It is almost certainly a waste of time.
(define (node-rank first)
(if (not first)
0
(complexity-analyze-vector (call-args first))))
(define (complexity-analyze node)
(cond ((empty? node)
0)
((reference-node? node)
1)
((lambda-node? node)
(if (not (empty? (lambda-body node)))
(complexity-analyze-vector (call-args (lambda-body node)))
0))
((call-node? node)
(complexity-analyze-vector (call-args node)))
(else
0)))
(define (complexity-analyze-vector vec)
(do ((i 0 (+ i 1))
(q 0 (+ q (complexity-analyze (vector-ref vec i)))))
((>= i (vector-length vec))
q)))
;----------------------------------------------------------------
; (cps-sequence <nodes> <values-cps>) ->
; <last-node> + <top-call> + <bottom-lambda>
; <values-cps> is the same as the <cps> used above, except that it returns
; a list of value nodes instead of exactly one.
(define (cps-sequence nodes values-cps)
(if (null? nodes)
(bug "CPS: empty sequence"))
(let loop ((nodes nodes) (first #f) (last #f))
(if (null? (cdr nodes))
(values (car nodes) first last)
(receive (exp-first exp-last)
(cps-sequent (car nodes) values-cps)
(if (and last exp-first)
(attach-body last exp-first))
(loop (cdr nodes) (or first exp-first) (or exp-last last))))))
(define (cps-sequent node values-cps)
(receive (vals exp-first exp-last)
(values-cps node)
(receive (calls other)
(partition-list call-node? vals)
(map erase other)
(if (null? calls)
(values exp-first exp-last)
(insert-let calls exp-first exp-last)))))
(define (insert-let calls exp-first exp-last)
(let* ((vars (map (lambda (call)
(make-variable 'v (trivial-call-return-type call)))
calls))
(cont (make-lambda-node 'c 'cont vars))
(call (make-call-node (get-primop (enum primop let))
(+ 1 (length calls))
1)))
(attach-call-args call (cons cont calls))
(cond (exp-first
(attach-body exp-last call)
(values exp-first cont))
(else
(values call cont)))))

319
ps-compiler/front/jump.scm
View File

@ -1,319 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Code to turn PROC lambdas into JUMP lambdas.
(define (integrate-jump-procs!)
(receive (hits useless)
(find-jump-procs (filter proc-lambda? (make-lambda-list)) find-calls)
(remove-unused-procedures! useless)
(for-each (lambda (p)
(procs->jumps (cdr p)
(map bound-to-variable (cdr p))
(car p)))
hits)
(not (and (null? hits) (null? useless)))))
; Make a call graph with extra nodes inserted for continuations:
;
; If F calls G tail-recursively, add an edge F->G
; If F calls G ... with continuation K, add a node K and edges F->K, K->G ...
;
; Then FIND-JOINS will return a list of the nodes that are passed two or
; more distinct continuations. The rest can be merged with their callers.
;
; Need a root node, so make one that points to all procs with unknown calls.
(define-record-type node :node
(really-make-node proc cont successors join? merged?)
node?
(proc node-proc) ; lambda node (or #f for continuation holders)
(cont node-cont) ; lambda node (or #f for procs)
(successors node-successors set-node-successors!)
(temp node-temp set-node-temp!)
(join? node-join? set-node-join?!)
(merged? node-merged? set-node-merged?!))
(define (make-node proc cont)
(really-make-node proc cont '() #f #f))
(define-record-discloser :node
(lambda (node)
(list 'node (node-proc node) (node-cont node))))
(define (add-child! parent child)
(if (not (memq? child (node-successors parent)))
(set-node-successors! parent (cons child (node-successors parent)))))
; We want to find subsets of ALL-PROCS such that all elements of a subset
; are always called with the same continuation. (PROC->USES <proc>) returns
; the references to <proc> that are calls, or #f if there are references that
; are not calls.
;
; We proceed as follows:
; 1. Partition the procs depending on whether all their calls are known or not.
; 2. Build a call graph:
; Nodes represent either procedures or continuations. If there is a
; tail-recursive call to procedure B in procedure A, then there is an
; edge from A to B. For continuation C such that there is a call in
; procedure A to procedure B with that continuation, there are edges
; from A to C and from C to B.
; In other words, it is a call graph where the edges that represent
; non-tail-recursive calls are replaced by two edges, with a node for
; the continuation in between.
; There is a special root node (representing `outside'), that has
; edges to the nodes representing procedures whose call sites have not
; been identified.
; 3. Determine the dominance frontiers in the graph.
; 4. Find the nodes in the graph that are reachable from more than one
; continuation (the joins).
; 5. Starting from each node that represents a continuation (the joins,
; procs whose calls aren't known, and the continuations themselves),
; find the set of nodes reachable from that node without going through
; some other continuation node.
(define (find-jump-procs all-procs proc->uses)
(for-each (lambda (l)
(set-lambda-block! l (make-node l #f)))
all-procs)
(receive (known unknown)
(partition-list calls-known? all-procs)
(let ((root (make-node #f #f))
(conts-cell (list '()))
(known-blocks (map lambda-block known))
(procs-cell (list (map lambda-block unknown))))
(note-calls! known conts-cell procs-cell proc->uses)
(let ((unknown-blocks (car procs-cell))
(conts (car conts-cell)))
(set-node-successors! root unknown-blocks)
(graph->ssa-graph! root node-successors node-temp set-node-temp!)
(let ((joins (find-joins (append conts unknown-blocks) node-temp)))
(for-each (lambda (n)
(set-node-join?! n #t))
joins)
(let* ((mergable (filter-map find-mergable
(append joins unknown-blocks conts)))
(useless (filter (lambda (p)
(not (or (node-join? (lambda-block p))
(node-merged? (lambda-block p)))))
known)))
(for-each (lambda (p)
(set-lambda-block! p #f))
all-procs)
(values mergable useless)))))))
; Walk KNOWN-PROCS adding edges to the call graph.
(define (note-calls! known-procs conts-cell procs-cell proc->uses)
(for-each (lambda (proc)
(for-each (lambda (ref)
(note-call! (lambda-block proc)
ref
conts-cell procs-cell))
(proc->uses proc)))
known-procs))
; Add an edge from the node containing REF to PROC-NODE. Tail calls add an
; edge directly from the calling node, non-tail calls add an edge from the
; successor to the calling node that represents the call's continuation.
(define (note-call! proc-node ref conts-cell procs-cell)
(let ((caller (get-lambda-block (containing-procedure ref) procs-cell)))
(add-child! (if (calls-this-primop? (node-parent ref) 'tail-call)
caller
(get-cont-block caller
(call-arg (node-parent ref) 0)
conts-cell))
proc-node)))
; Get the block for lambda-node PROC, making a new one if necessary.
(define (get-lambda-block proc procs-cell)
(let ((block (lambda-block proc)))
(if (node? block)
block
(let ((new (make-node proc #f)))
(set-lambda-block! proc new)
(set-car! procs-cell (cons new (car procs-cell)))
new))))
; Get the successor to CALLER containing CONT, making it if necessary.
(define (get-cont-block caller cont conts-cell)
(or (any (lambda (node)
(and (node-cont node)
(node-equal? cont (node-cont node))))
(node-successors caller))
(let ((cont-node (make-node #f cont)))
(set-car! conts-cell (cons cont-node (car conts-cell)))
(add-child! caller cont-node)
cont-node)))
;----------------
(define (find-mergable node)
(let ((mergable (really-find-mergable node)))
(if (null? mergable)
#f
(cons (or (node-cont node)
(car (variable-refs (car (lambda-variables (node-proc node))))))
mergable))))
(define (really-find-mergable node)
(let recur ((nodes (node-successors node)) (res '()))
(if (null? nodes)
res
(recur (cdr nodes)
(let ((node (car nodes)))
(cond ((or (node-join? node) ; gets two or more continuations
(node-merged? node) ; already merged
(node-cont node)) ; different continuation
res)
; ((node-cont node) ; not a lambda
; (recur (node-successors node) res))
(else
(set-node-merged?! node #t)
(recur (node-successors node)
(cons (node-proc node) res)))))))))
;=============================================================================;
; Part 2. PROCS is a list of procedures that are only called by each other;
; with no entry point they are useless and can be removed.
(define (remove-unused-procedures! procs)
(for-each (lambda (proc)
(let ((var (bound-to-variable proc)))
(if (not var)
(bug "known procedure has no variable ~S" proc))
(format #t "Removing unused procedure: ~S~%"
(variable-name var)) ; would LAMBDA-NAME be better?
(mark-changed (node-parent proc))
(detach-bound-value var proc)
(erase proc)))
procs))
;=============================================================================;
; Part 3. Turn JUMP-PROCS from procs to jumps. CONT is the continuation they
; all receive, and is also turned into a jump.
; This creates a LETREC to bind all CONT and any of JUMP-PROCS that are
; passed CONT directly and are bound abouve the LCA of all calls to JUMP-PROCS
; that use CONT. Then every jump-proc is changed from a proc lambda to a
; jump lambda and has its continuation removed. Returns are replaced with
; jumps to CONT. If CONT is not a variable some protocol adjustment may be
; required.
(define (procs->jumps jump-procs vars cont)
(receive (called-vars called-procs lca)
(find-cont-uses cont vars jump-procs)
(let ((proc (containing-procedure cont))
(lca (if (call-node? lca) lca (node-parent lca)))
(cvar (if (lambda-node? cont)
(make-variable 'w (node-type cont))
#f)))
(receive (called-vars called-procs)
(bound-above? lca called-vars called-procs)
(for-each detach-bound-value called-vars called-procs)
(cond ((lambda-node? cont)
(determine-continuation-protocol cont jump-procs)
(move cont (lambda (ignore) (make-literal-node '#f '#f)))
(put-in-letrec (cons cvar called-vars)
(cons cont called-procs)
lca)
(change-lambda-type cont 'jump))
(else
(put-in-letrec called-vars called-procs lca))))
(for-each proc-calls->jumps jump-procs)
(for-each (lambda (p)
(let* ((v (car (lambda-variables p)))
(refs (variable-refs v)))
(set-variable-refs! v '())
(for-each (lambda (r)
(if (lambda-node? cont)
(return->jump (node-parent r) cvar cont)
(replace r (make-reference-node
(car (lambda-variables proc))))))
refs)
(remove-variable p v)))
jump-procs)
(values))))
; Returns those of VALS and VARS where there is a call to the variable that
; passes CONT as a continuation, or where the variable is not bound. The
; third values returned is the least-common-ancestor of all calls to VARS
; that use CONT.
(define (find-cont-uses cont vars vals)
(let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()) (uses '()))
(if (null? vars)
(values r-vars r-vals (least-common-ancestor uses))
(let ref-loop ((refs (variable-refs (car vars))) (my-uses uses))
(cond ((not (null? refs))
(ref-loop (cdr refs)
(if (node-equal? cont
(call-arg (node-parent (car refs)) 0))
(cons (car refs) my-uses)
my-uses)))
((and (variable-binder (car vars))
(eq? my-uses uses))
(loop (cdr vars) (cdr vals) r-vars r-vals uses))
(else
(loop (cdr vars) (cdr vals)
(cons (car vars) r-vars)
(cons (car vals) r-vals)
my-uses)))))))
; Return the list of VARS and VALS where the variable is either global
; or bound above CALL.
(define (bound-above? call vars vals)
(set-node-flag! call #t)
(let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()))
(cond ((null? vars)
(set-node-flag! call #f)
(values r-vars r-vals))
((and (variable-binder (car vars))
(marked-ancestor (variable-binder (car vars))))
(loop (cdr vars) (cdr vals) r-vars r-vals))
(else
(loop (cdr vars) (cdr vals)
(cons (car vars) r-vars)
(cons (car vals) r-vals))))))
(define (detach-bound-value var node)
(if (variable-binder var)
(let ((binder (variable-binder var))
(parent (node-parent node))
(index (node-index node)))
(set-lambda-variables! binder (delq! var (lambda-variables binder)))
(detach node)
(remove-call-arg parent index))))
; Turn all calls to PROC into jumps.
(define (proc-calls->jumps proc)
(for-each (lambda (n)
(call->jump (node-parent n)))
(find-calls proc))
(change-lambda-type proc 'jump))
; Change a call to a jump by changing the primop and removing the continuation.
(define (call->jump call)
(case (primop-id (call-primop call))
((call tail-call)
(set-call-primop! call (get-primop (enum primop jump)))
(remove-call-arg call 0))
(else
(bug "odd call primop ~S" (call-primop call)))))
; Change a return to a jump. VAR is a variable bound to JUMP, the lambda
; being jumped to.
(define (return->jump call var jump)
(case (primop-id (call-primop call))
((return)
(set-call-primop! call (get-primop (enum primop jump)))
(replace (call-arg call 0) (make-reference-node var)))
(else
(bug "odd return primop ~S" (call-primop call)))))

224
ps-compiler/front/special.scm
View File

@ -1,224 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; This file is obsolete and no longer used.
;----------------------------------------------------------------------------
; SPECIAL FORMS
;
; QUOTE CALL RETURN BLOCK LAMBDA LETREC
; + LET for reasons of type-checking
;
;----------------------------------------------------------------------------
(define-record-type quote-exp :quote-exp
(make-quote-exp value type)
quote-exp?
(value quote-exp-value)
(type quote-exp-type set-quote-exp-type!))
(define-record-type call-exp :call-exp
(make-call-exp! proc exits type args source)
call-exp?
(proc call-exp-proc)
(exits call-exp-exits)
(type call-exp-type set-call-exp-type!)
(args call-exp-args)
(source call-exp-source))
(define-record-type let-exp :let-exp
(make-let-exp vars vals body source)
let-exp?
(vars let-exp-vars)
(vals let-exp-vals)
(body let-exp-body set-let-exp-body!)
(source let-exp-source))
(define-record-type return-exp :return-exp
(make-return-exp protocol type args)
return-exp?
(protocol return-exp-protocol)
(type return-exp-type)
(args return-exp-args))
(define-record-type block-exp :block-exp
(make-block-exp exps)
block-exp?
(exps block-exp-exps))
(define-record-type lambda-exp :lambda-exp
(make-lambda-exp id return-type protocol vars body source)
lambda-exp?
(id lambda-exp-id)
(return-type lambda-exp-return-type set-lambda-exp-return-type!)
(protocol lambda-exp-protocol)
(vars lambda-exp-vars)
(body lambda-exp-body set-lambda-exp-body!)
(source lambda-exp-source))
(define (make-continuation-exp vars body)
(make-lambda-exp #f #f #f vars body #f))
(define-record-type letrec-exp :letrec-exp
(make-letrec-exp vars vals body source)
letrec-exp?
(vars letrec-exp-vars)
(vals letrec-exp-vals)
(body letrec-exp-body set-letrec-exp-body!)
(source letrec-exp-source))
(define-record-type external-value :external-value
(make-external-value type)
external-value?
(type external-value-type set-external-value-type!))
; Creating nodes and CPS converting calls and blocks.
;-------------------------------------------------------------------------------
; (CPS expression) => value + first-call + last-lambda
; = the value of the expression
; + the first of any calls that must be executed to get the value
; + the continuation lambda of the last of the necessary calls
; The first call and the last lambda will be #F if the value is trivial.
;
; (TAIL-CPS expression continuation-variable) => call
; = the first call to execute to return the value of the expression to
; the continuation variable
(define (cps exp)
(let ((value (cps-value exp)))
(if value
(values value #f #f)
(generic-cps exp #f))))
(define (tail-cps exp cont-var)
(receive (value type)
(cps-value+type exp)
(if value
(make-value-return cont-var value type)
(generic-cps exp cont-var))))
(define (cps-value exp)
(receive (value type)
(cps-value+type exp)
value))
(define (cps-value+type exp)
(cond ((variable? exp)
(values (make-reference-node exp) (variable-type exp)))
((quote-exp? exp)
(values (make-literal-node (quote-exp-value exp)
(quote-exp-type exp))
(quote-exp-type exp)))
((lambda-exp? exp)
(let ((node (lambda-exp->node exp)))
(values node (lambda-node-type node))))
(else
(values #f #f))))
(define (generic-cps exp cont-var)
(cond ((block-exp? exp)
(make-block (block-exp-exps exp) cont-var))
((return-exp? exp)
(make-return-call exp cont-var))
((call-exp? exp)
(make-primop-call exp cont-var))
((let-exp? exp)
(make-lambda-call exp cont-var))
((letrec-exp? exp)
(letrec-exp->node exp cont-var))
(else
(bug "unknown syntax~% ~S" exp))))
(define (lambda-exp->node exp)
(let* ((cvar (make-variable 'c (lambda-exp-return-type exp)))
(node (make-lambda-node (lambda-exp-id exp)
'proc
(cons cvar (copy-list (lambda-exp-vars exp))))))
(set-lambda-protocol! node (lambda-exp-protocol exp))
(set-lambda-source! node (lambda-exp-source exp))
(attach-body node (tail-cps (lambda-exp-body exp) cvar))
node))
(define (letrec-exp->node exp cont-var)
(let ((vals (map cps-value (letrec-exp-vals exp)))
(vars (letrec-exp-vars exp))
(cont (make-lambda-node 'c 'cont '())))
(let-nodes ((top (letrec1 1 l1))
(l1 ((x #f) . vars) call2)
(call2 (letrec2 1 cont (* x) . vals)))
(set-call-source! top (letrec-exp-source exp))
(happens-after top cont (letrec-exp-body exp) cont-var))))
; (CATCH id . body)
; (THROW primop rep id . args)
(define (make-undefined-value)
(make-quote-exp the-undefined-value #f))
(define (exp->s-exp exp)
(cond ((variable? exp)
(format #f "~S_~S" (variable-name exp) (variable-id exp)))
((quote-exp? exp)
(list 'quote (quote-exp-value exp)))
((block-exp? exp)
(cons 'begin (map exp->s-exp (block-exp-exps exp))))
((return-exp? exp)
(cons 'return (map exp->s-exp (return-exp-args exp))))
((call-exp? exp)
`(,(primop-id (call-exp-proc exp))
,(call-exp-exits exp)
. ,(map exp->s-exp (call-exp-args exp))))
((let-exp? exp)
`(let ,(map list
(map exp->s-exp (let-exp-vars exp))
(map exp->s-exp (let-exp-vals exp)))
,(exp->s-exp (let-exp-body exp))))
((lambda-exp? exp)
`(lambda ,(map exp->s-exp (lambda-exp-vars exp))
,(exp->s-exp (lambda-exp-body exp))))
((letrec-exp? exp)
`(letrec ,(map list
(map exp->s-exp (letrec-exp-vars exp))
(map exp->s-exp (letrec-exp-vals exp)))
,(exp->s-exp (letrec-exp-body exp))))
(else
(error '"unknown syntax~% ~S" exp))))
(define (exp-source exp)
(cond ((call-exp? exp)
(call-exp-source exp))
((let-exp? exp)
(let-exp-source exp))
((letrec-exp? exp)
(letrec-exp-source exp))
((lambda-exp? exp)
(lambda-exp-source exp))
(else
#f)))
(define (find-some-source top-exp exp)
(or (exp-source exp)
(call-with-current-continuation
(lambda (exit)
(let recur ((at top-exp))
(let ((hit? (cond ((eq? at exp)
#t)
((call-exp? at)
(or (recur (call-exp-proc at))
(any recur (call-exp-args at))))
((let-exp? at)
(or (recur (let-exp-body at))
(any recur (let-exp-vals at))))
((letrec-exp? at)
(or (recur (letrec-exp-body at))
(any recur (letrec-exp-vals at))))
((return-exp? at)
(any recur (return-exp-args at)))
((lambda-exp? at)
(recur (lambda-exp-body at)))
((block-exp? at)
(any recur (block-exp-exps at)))
(else #f))))
(if (and hit? (exp-source at))
(exit (exp-source at)))
hit?))))))

91
ps-compiler/front/top.scm
View File

@ -1,91 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Debugging aids
(define *bad-ids* '())
(define *all-procs?* #f)
(define *checkpoints* '())
(define all-checkpoints
'(node-made
simplify1
protocols
simplify2
node->vector
pre-simplify-proc
envs-added
))
(define (debug-breakpoint loc id data)
(if (and (memq? loc *checkpoints*)
(or (not id)
*all-procs?*
(memq? id *bad-ids*)))
(breakpoint "~S at ~S is ~S" id loc data)))
(define (add-checks . locs)
(receive (okay wrong)
(partition-list (lambda (l) (memq? l all-checkpoints))
locs)
(set! *checkpoints* (union okay *checkpoints*))
(for-each (lambda (l)
(format #t '"~&~S is not a checkpoint~%" l))
wrong)
*checkpoints*))
(define (clear-checks . locs)
(set! *checkpoints*
(if (null? locs)
'()
(set-difference *checkpoints* locs))))
(define (add-procs . locs)
(if (null? locs)
(set! *all-procs?* #t)
(set! *bad-ids* (union locs *bad-ids*))))
(define (clear-procs . locs)
(cond ((null? locs)
(set! *all-procs?* #f)
(set! *bad-ids* '()))
(else
(set! *bad-ids*
(if (null? locs)
'()
(set-difference *bad-ids* locs))))))
(define add-check add-checks)
(define clear-check clear-checks)
(define add-proc add-procs)
(define clear-proc clear-procs)
;------------------------------------------------------------------------------
(define *remove-cells?* #f)
(define *flow-values?* #f)
(define (simplify-all node id)
(debug-breakpoint 'node-made id node)
(simplify-node node)
(debug-breakpoint 'simplify1 id node)
(determine-protocols)
(debug-breakpoint 'protocols id node)
(if (integrate-jump-procs!)
(simplify-node node))
(cond (*remove-cells?*
(remove-cells-from-tree node (make-lambda-list))
(simplify-node node)))
(cond (*flow-values?*
(flow-values node (make-lambda-list))
(simplify-node node)))
(debug-breakpoint 'simplify2 id node)
(values))
(define (determine-protocols)
(walk-lambdas (lambda (l)
(cond ((and (eq? 'proc (lambda-type l))
(node? (node-parent l))
(find-calls l))
=> (lambda (calls)
(determine-lambda-protocol l calls)))))))

258
ps-compiler/interfaces.scm
View File

@ -1,258 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
(define-interface utilities-interface
(export bug
user-error
user-warning
true false
or-map
remove-similar-elts
select-from-table
table->list table->entry-list
table-push table-pop
merge-lists
vector-every?
make-ignorable
sub-vector->list
flag-assq
enforce
writec
mem?
walk-vector
vector-replace
copy-list
copy-vector
symbol-hash
string-hash
char->ascii
object-hash
union intersection set-difference
make-xvector xvector-length xvector-ref xvector-set! xvector->vector
(define-subrecord :syntax)
;(define-simple-record-type :syntax)
(define-local-syntax :syntax)
))
(define-interface primop-interface
(export primop? make-primop make-proc-primop make-conditional-primop
all-primops get-primop
primop-id primop-trivial? primop-side-effects
primop-cost
simplify-call
primop-procedure? primop-call-index
primop-conditional?
expand-to-conditional
simplify-conditional?
primop-code-data set-primop-code-data!
trivial-call-return-type
(primop :syntax)
))
(define-interface variable-interface
(export variable? make-variable
global-variable? make-global-variable
variable-name set-variable-name!
variable-id
variable-type set-variable-type!
variable-binder set-variable-binder!
variable-refs set-variable-refs!
variable-flag set-variable-flag!
variable-flags set-variable-flags!
variable-generate set-variable-generate!
erase-variable
variable-index copy-variable used? unused?
variable-known-value
add-variable-known-value!
remove-variable-known-value!
variable-simplifier
add-variable-simplifier!
remove-variable-simplifier!
note-known-global-lambda!
))
(define-interface node-interface
(compound-interface
primop-interface
variable-interface
(export reset-node-id node-hash node-unhash
node? node-variant
node-parent set-node-parent!
node-index set-node-index!
node-simplified? set-node-simplified?!
node-flag set-node-flag!
empty empty? proclaim-empty
erase
detach detach-body
attach attach-body
move move-body
insert-body
replace replace-body
mark-changed
leaf-node?
literal-node? make-literal-node
literal-value set-literal-value!
literal-type set-literal-type!
copy-literal-node
reference-node? make-reference-node
reference-variable set-reference-variable!
call-node? make-call-node
call-primop set-call-primop!
call-args set-call-args!
call-exits set-call-exits!
call-source set-call-source!
call-arg call-arg-count
lambda-node? make-lambda-node
lambda-body set-lambda-body!
lambda-variables set-lambda-variables!
lambda-name set-lambda-name!
lambda-id
lambda-type
lambda-block set-lambda-block!
lambda-env set-lambda-env!
lambda-protocol set-lambda-protocol!
lambda-source set-lambda-source!
lambda-variable-count
calls-known? set-calls-known?!
proc-lambda?
initialize-lambdas add-lambda add-lambdas
change-lambda-type
walk-lambdas make-lambda-list
loc/owner loc/type loc/rep
set/owner set/type set/rep set/value
node-base containing-procedure
trivial? nontrivial?
nontrivial-ancestor
calls-this-primop?
bound-to-variable
walk-refs-safely
small-node?
side-effects?
called-node? called-node
called-lambda
get-lambda-value
;set-reference?
attach-call-args remove-call-args replace-call-args
remove-null-arguments
shorten-call-args insert-call-arg remove-call-arg
append-call-arg
remove-body
put-in-letrec
remove-lambda-variable remove-variable remove-unused-variables
substitute substitute-vars-in-node-tree
replace-call-with-value
copy-node-tree
mark-ancestors marked-ancestor? unmarked-ancestor?
node-ancestor? marked-ancestor least-common-ancestor
proc-ancestor
hoistable-node?
find-scoping
(let-nodes :syntax)
node-equal?
no-free-references?
find-calls
node-type
the-undefined-value
undefined-value?
undefined-value-node?
make-undefined-literal
)))
(define-interface simplify-internal-interface
(export simplify-node
default-simplifier
simplify-arg
simplify-args
simplify-lambda-body
simplify-known-lambda
(pattern-simplifier :syntax)
simplify-allocation
simplify-known-call
simplify-known-tail-call
simplify-unknown-call
simplify-return
simplify-jump
; simplify-undefined-value
simplify-test expand-test simplify-test?
))
(define-interface front-debug-interface
(export debug-breakpoint
add-checks add-check clear-checks clear-check
add-procs add-proc clear-procs clear-proc))
(define-interface front-interface
(export simplify-all
integrate-jump-procs! ; for debugging
))
(define-interface annotated-read-interface
(export read-and-annotate
pair-annotation
annotated-cons
annotation?
annotation-file
annotation-form
annotation-row
annotation-column
))
(define-interface compiler-byte-vector-interface
(export make-byte-vector byte-vector? byte-vector-length
byte-vector-ref byte-vector-word-ref byte-vector-half-word-ref
byte-vector-set! byte-vector-word-set! byte-vector-half-word-set!
byte-vector-endianess set-byte-vector-endianess!
))
(define-interface parameter-interface
(export lookup-primop
lookup-imported-variable
type/unknown
type-eq?
lambda-node-type
true-value
false-value
determine-lambda-protocol
determine-continuation-protocol
))

40
ps-compiler/load-ps-compiler.scm
View File

@ -1,40 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; -*- Mode: Scheme; -*-
; To load the Pre-Scheme compiler into Scheme 48:
; ,exec ,load load-ps-compiler.scm
; It needs a larger than default sized heap. 4000000 is big enough to
; load the pre-scheme compiler but not big enough to compile the VM,
; 12000000 is enough to compile the VM.
;
; compile-vm.exec is an exec script to compile the Scheme 48 virtual machine.
;
; This requires that Pre-Scheme already be loaded.
(user '(run (let ((minor-number (call-with-input-file
"minor-version-number"
(lambda (in)
(read in)))))
(newline)
(newline)
(display "Pre-Scheme compiler version 0.")
(display minor-number)
(newline)
(display "Copyright (c) 1994-1999 by Richard Kelsey.")
(newline)
(display "Please report bugs to pre-scheme@martigny.ai.mit.edu.")
(newline)
(newline))))
(config)
(structure 'reflective-tower-maker
'(export-reflective-tower-maker))
(load "interfaces.scm")
(load "package-defs.scm")
(load "prescheme/interfaces.scm")
(load "prescheme/package-defs.scm")
(load-package 'let-nodes) ; used in FOR-SYNTAX
(load-package 'simp-patterns) ; used in FOR-SYNTAX
(load-package 'prescheme-compiler)

11
ps-compiler/load-scheme.scm
View File

@ -1,11 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Load the Scheme front-end
(config)
(load "interfaces.scm")
(load "package-defs.scm")
(load "scheme-to-c/package-defs.scm")
(load-package 'let-nodes) ; used in FOR-SYNTAX
(load-package 'simp-patterns) ; used in FOR-SYNTAX
(load-package 'scheme-test)

1
ps-compiler/minor-version-number
View File

@ -1 +0,0 @@
5

40
ps-compiler/node/arch.scm
View File

@ -1,40 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; These are all of the primitives that are known to the compiler.
; The enumeration is needed by the expander for LET-NODES so it ends up
; being loaded into two separate packages.
(define-enumeration primop
(
; Nontrivial Primops
call ; see below
tail-call
return
jump
throw
unknown-call
unknown-tail-call
unknown-return
dispatch ; (dispatch <cont1> ... <contN> <exp>)
let ; (let <lambda-node> . <args>)
letrec1 ; (letrec1 (lambda (x v1 v2 ...)
letrec2 ; (letrec2 <cont> x <lambda1> <lambda2> ...)))
cell-set!
global-set!
undefined-effect ; (undefined-effect . <maybe-args>)
; Trivial Primops
make-cell
cell-ref
global-ref
; Environment stuff, these are both trivial
closure
env-ref
))

23
ps-compiler/node/leftovers.scm
View File

@ -1,23 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Identifying values called by primops
; Is NODE the value being called by a primop?
(define (procedure-node? node)
(let ((parent (node-parent node)))
(and (node? parent)
(let ((primop (call-primop parent)))
(and (primop-procedure? primop)
(eq? (primop-call-index primop)
(node-index node)))))))
; Get the node called at CALL.
(define (called-procedure-node call)
(cond ((and (primop-procedure? (call-primop call))
(primop-call-index (call-primop call)))
=> (lambda (i)
(call-arg call i)))
(else '#f)))

280
ps-compiler/node/let-nodes.scm
View File

@ -1,280 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; This is a backquote-like macro for building nodes.
;
; One goal is to produce code that is as efficient as possible.
;
; (LET-NODES (<spec1> ... <specN>) . <body>)
;
; <spec> ::= (<ident> <real-call>) | ; call node
; (<ident> (<var1> ... <varN>) <call>) | ; lambda node
; (<ident> (<var1> ... <varN> . <last-vars>) <call>) ; lambda node
;
; <var> ::= #f | Ignored variable position
; <ident> | Evaluate <ident> and copy it, rebinding <ident>
; '<ident> | Evaluate <ident> to get the variable
; (<ident> <rep>) (MAKE-VARIABLE <ident> <rep>)
;
; <last-vars> ::= <ident>
;
; <call> ::= <ident> | <real-call>
;
; <real-call> ::= (<primop-id> <exits> . <arg-list>)
;
; <arg-list> ::= (<arg1> ... <argN>) | (<arg1> ... <argN> . <last-args>)
;
; <last-args> ::= <ident>
;
; <arg> ::= 'foo literal node containing the value of foo, no rep
; '(foo rep) " " " " " " " , using rep
; (* foo) reference to foo (which evaluates to a variable)
; (! foo) foo evaluates to a node
; foo short for (! foo) when foo is an atom
; #f put nothing here
; (<primop-id> . <args>) a nested call
;--------------------------------------
;
; Example:
;
; (let-nodes ((c1 (l1 1 cont))
; (l1 ((j type/pointer)) (proc 2 l2 l3 . rest))
; (l2 () ((jump cont (* j)) '(true-value type/boolean)))
; (l3 () ((jump cont (* j)) '(false-value type/boolean))))
; (replace-body node c1))
;
; ==>
;
; (LET ((J (CREATE-VARIABLE 'J TYPE/POINTER)))
; (LET ((C1 (CREATE-CALL-NODE '2 1))
; (C.1225 (CREATE-CALL-NODE (+ '3 (LENGTH REST)) '2))
; (L1 (CREATE-LAMBDA-NODE 'C 'CONT (FLIST1 J '())))
; (C.1224 (CREATE-CALL-NODE '4 0))
; (L2 (CREATE-LAMBDA-NODE 'C 'CONT '()))
; (C.1223 (CREATE-CALL-NODE '4 0))
; (L3 (CREATE-LAMBDA-NODE 'C 'CONT '())))
; (ATTACH 0 C1 L1)
; (ATTACH 1 C1 CONT)
; (ATTACH 0 C.1225 PROC)
; (ATTACH-CALL-ARGS C.1225 (APPEND (LIST L2 L3) REST))
; (ATTACH-BODY L1 C.1225)
; (ATTACH 0 C.1224 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
; (ATTACH-THREE-CALL-ARGS C.1224
; (CREATE-JUMP-MARKER CONT)
; (CREATE-REFERENCE-NODE J)
; (CREATE-LITERAL-NODE TRUE-VALUE TYPE/BOOLEAN))
; (ATTACH-BODY L2 C.1224)
; (ATTACH 0 C.1223 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
; (ATTACH-THREE-CALL-ARGS C.1223
; (CREATE-JUMP-MARKER CONT)
; (CREATE-REFERENCE-NODE J)
; (CREATE-LITERAL-NODE FALSE-VALUE TYPE/BOOLEAN))
; (ATTACH-BODY L3 C.1223)
; (REPLACE-BODY NODE C1)))
;
(define (expand-let-nodes form rename compare)
(destructure (((#f specs . body) form))
(receive (vars nodes code)
(parse-node-specs specs rename compare)
`(,(rename 'let) ,vars
(,(rename 'let) ,nodes
,@code
,@body)))))
(define (test form)
(destructure (((#f specs . body) form))
(receive (vars nodes code)
(parse-node-specs specs identity eq?)
`(let ,vars
(let ,nodes
,@code
,@body)))))
; Parse the specs, returning a list of variable specs, a list of node specs,
; and a list of construction forms. An input spec is either a call or a
; lambda, each is parsed by an appropriate procedure.
(define (parse-node-specs specs r c)
(let loop ((specs (reverse specs)) (vars '()) (nodes '()) (codes '()))
(if (null? specs)
(values vars nodes codes)
(destructure ((((name . spec) . rest) specs))
(cond ((null? (cdr spec))
(receive (node code)
(construct-call name (car spec) r c)
(loop rest vars
`((,name ,node) . ,nodes) (append code codes))))
((= 2 (length spec))
(receive (vs node new-spec call)
(construct-lambda (car spec) (cadr spec) r c)
(loop (if new-spec (cons new-spec rest) rest)
(append vs vars)
`((,name ,node) . ,nodes)
(if call
`((attach-body ,name ,call) . ,codes)
codes))))
(else
(error "illegal spec in LET-NODES ~S" (cons name spec))))))))
; The names of the call-arg relation procedures, indexed by the number of
; arguments handled.
(define call-attach-names
'#(#f
#f
attach-two-call-args
attach-three-call-args
attach-four-call-args
attach-five-call-args))
; Return the node spec and construction forms for a call. This dispatches
; on whether the argument list is proper or not.
;
; <real-call> ::= (<arg0> <exits> <arg1> ... <argN>) |
; (<arg0> <exits> <arg1> ... <argN> . <last-args>))
; ((JUMP l-node value) <arg1> ... <argN>)
; ((JUMP l-node value) <arg1> ... <argN> . <last-args>)
(define (construct-call name specs r c)
(destructure (((proc . args) specs))
(really-construct-call name proc (car args) '() (cdr args) r c)))
(define (construct-nested-call specs r c)
(destructure (((primop-id . args) specs))
(let ((name (r 'call)))
(receive (node code)
(really-construct-call name primop-id 0 '() args r c)
`(,(r 'let) ((,name ,node)) ,@code ,name)))))
(define (really-construct-call name primop-id exits extra args r c)
(receive (arg-count arg-code)
(parse-call-args name extra args r c)
(let ((primop-code (get-primop-code primop-id r)))
(values `(,(r 'make-call-node) ,primop-code ,arg-count ,exits)
arg-code))))
(define (get-primop-code id r)
(cond ((name->enumerand id primop)
=> (lambda (n)
`(,(r 'get-primop) ,n)))
(else
`(,(r 'lookup-primop) ',id))))
; NAME = the call node which gets the arguments
; EXTRA = initial, already expanded arguments
; ARGS = unexpanded arguments
; LAST-ARG = an atom whose value is added to the end of the arguments
; Returns ARG-COUNT-CODE and ARG-CODE
(define (parse-call-args name extra args r c)
(receive (args last-arg)
(decouple-improper-list args)
(let* ((args (append extra (map (lambda (a) (construct-node a r c)) args)))
(count (length args)))
(if (not (null? last-arg))
(values `(,(r '+) ,count (,(r 'length) ,last-arg))
`((,(r 'attach-call-args)
,name
,(if (null? args)
last-arg
`(,(r 'append) (,(r 'list) . ,args) ,last-arg)))))
(values count
(cond ((= count 0)
'())
((and (= count 1) (car args))
`((,(r 'attach) ,name 0 ,(car args))))
((and (< count 6)
(every? identity args))
`((,(r (vector-ref call-attach-names count))
,name
,@args)))
(else
`((,(r 'attach-call-args) ,name (list . ,args))))))))))
; Return proper part of the list and its last-cdr separately.
(define (decouple-improper-list list)
(do ((list list (cdr list))
(res '() (cons (car list) res)))
((atom? list)
(values (reverse! res) list))))
; Dispatch on the type of the SPEC and return the appropriate code.
;
; <arg> ::= 'foo literal node containing the value of foo, no rep
; '(foo rep) literal node containing the value of foo
; (* foo) reference to foo (which evaluates to a variable)
; (! foo) foo evaluates to a node
; name short for (! name) when foo is an atom
(define (construct-node spec r c)
(cond ((atom? spec) spec)
(else
(destructure (((key data) spec))
(case key
((*) `(,(r 'make-reference-node) ,data))
((quote) (if (pair? data)
`(,(r 'make-literal-node) . ,data)
`(,(r 'make-literal-node) ,data type/unknown)))
((!) data)
(else
(construct-nested-call spec r c)))))))
; Parse a lambda spec. This returns a list of variable specs, code to
; construct the lambda node, a spec for the body if necessary, and
; the code needed to put it all together.
(define (construct-lambda vars call r c)
(receive (vars node)
(construct-vars vars r c)
(cond ((null? call)
(values vars node #f #f))
((atom? call)
(values vars node #f call))
(else
(let ((sym (r (generate-symbol 'c))))
(values vars node `(,sym ,call) sym))))))
; Returns the code needed to construct the variables and the code to make
; the lambda node that binds the variables.
;
; <var> ::= #f | Ignored variable position
; <ident> | Evaluate <ident> and copy it, rebinding <ident>
; '<ident> | Evaluate <ident> to get the variable
; (<ident> <rep>) (MAKE-VARIABLE <ident> <rep>)
(define (construct-vars vars r c)
(let loop ((vs vars) (vlist '()) (code '()))
(cond ((atom? vs)
(let ((vars (if (null? vs)
`(,(r 'list) . ,(reverse! vlist))
`(,(r 'append) (,(r 'list) . ,(reverse! vlist))
,vs))))
(values code `(,(r 'make-lambda-node) 'c 'cont ,vars))))
(else
(let ((spec (car vs))
(rest (cdr vs)))
(cond ((null? spec)
(loop rest (cons #f vlist) code))
((atom? spec)
(loop rest (cons spec vlist)
`((,spec (,(r 'copy-variable) ,spec)) . ,code)))
((c (car spec) 'quote)
(loop rest (cons (cadr spec) vlist) code))
(else
(loop rest (cons (car spec) vlist)
`((,(car spec)
(,(r 'make-variable) ',(car spec) ,(cadr spec)))
. ,code)))))))))
;------------------------------------------------------------------------------
; GENSYM utility
(define *generate-symbol-index* 0)
(define (generate-symbol sym)
(let ((i *generate-symbol-index*))
(set! *generate-symbol-index* (+ i 1))
(concatenate-symbol sym "." i)))

77
ps-compiler/node/node-equal.scm
View File

@ -1,77 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Determining if two nodes are functionally identical.
(define (node-equal? n1 n2)
(if (call-node? n1)
(and (call-node? n2)
(call-node-eq? n1 n2))
(value-node-eq? n1 n2)))
; Compare two call nodes. The arguments to the nodes are compared
; starting from the back to do leaf nodes first (usually).
(define (call-node-eq? n1 n2)
(and (= (call-arg-count n1) (call-arg-count n2))
(= (call-exits n1) (call-exits n2))
(eq? (call-primop n1) (call-primop n2))
(let ((v1 (call-args n1))
(v2 (call-args n2)))
(let loop ((i (- (vector-length v1) '1)))
(cond ((< i '0)
#t)
((node-equal? (vector-ref v1 i) (vector-ref v2 i))
(loop (- i '1)))
(else
#f))))))
; Compare two value nodes. Reference nodes are the same if they refer to the
; same variable or if they refer to corresponding variables in the two node
; trees. Primop and literal nodes must be identical. Lambda nodes are compared
; by their own procedure.
(define (value-node-eq? n1 n2)
(cond ((neq? (node-variant n1) (node-variant n2))
#f)
((reference-node? n1)
(let ((v1 (reference-variable n1))
(v2 (reference-variable n2)))
(or (eq? v1 v2) (eq? v1 (variable-flag v2)))))
((literal-node? n1)
(and (eq? (literal-value n1) (literal-value n2))
(eq? (literal-type n1) (literal-type n2))))
((lambda-node? n1)
(lambda-node-eq? n1 n2))))
; Lambda nodes are identical if they have identical variable lists and identical
; bodies. The variables of N1 are stored in the flag fields of the variables of
; N2 for the use of VALUE-NODE-EQ?.
(define (lambda-node-eq? n1 n2)
(let ((v1 (lambda-variables n1))
(v2 (lambda-variables n2)))
(let ((ok? (let loop ((v1 v1) (v2 v2))
(cond ((null? v1)
(if (null? v2)
(call-node-eq? (lambda-body n1) (lambda-body n2))
#f))
((null? v2) #f)
((variable-eq? (car v1) (car v2))
(loop (cdr v1) (cdr v2)))
(else #f)))))
(map (lambda (v) (if v (set-variable-flag! v #f))) v2)
ok?)))
(define (variable-eq? v1 v2)
(cond ((not v1)
(not v2))
((not v2) #f)
((eq? (variable-type v1) (variable-type v2))
(set-variable-flag! v2 v1)
#t)
(else #f)))

723
ps-compiler/node/node-util.scm
View File

@ -1,723 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; This file contains miscellaneous utilities for accessing and modifying the
; node tree.
; Get the root of the tree containing node.
(define (node-base node)
(do ((p node (node-parent p)))
((not (node? (node-parent p)))
p)))
; Find the procedure node that contains NODE. Go up one parent at a time
; until a lambda node is found, then go up two at a time, skipping the
; intervening call nodes.
(define (containing-procedure node)
(do ((node (node-parent node) (node-parent node)))
((lambda-node? node)
(do ((node node (node-parent (node-parent node))))
((proc-lambda? node) node)))))
; Trivial calls are those whose parents are call nodes.
(define (trivial? call)
(call-node? (node-parent call)))
(define (nontrivial? call)
(lambda-node? (node-parent call)))
(define (nontrivial-ancestor call)
(let loop ((call call))
(if (or (not (node? (node-parent call)))
(nontrivial? call))
call
(loop (node-parent call)))))
(define (calls-this-primop? call id)
(eq? id (primop-id (call-primop call))))
; Return the variable to which a value is bound by LET or LETREC.
(define (bound-to-variable node)
(let ((parent (node-parent node)))
(case (primop-id (call-primop parent))
((let)
(if (n= 0 (node-index node))
(list-ref (lambda-variables (call-arg parent 0))
(- (node-index node) 1))
#f))
((letrec2)
(if (< 1 (node-index node))
(list-ref (lambda-variables
(variable-binder
(reference-variable (call-arg parent 1))))
(- (node-index node) 1))
#f))
(else #f))))
; Return a list of all the reference to lambda-node L's value that call it.
; If not all can be identified then #F is returned.
(define (find-calls l)
(let ((refs (cond ((bound-to-variable l)
=> variable-refs)
((called-node? l)
(list l))
(else
#f))))
(cond ((and refs (every? called-node? refs))
refs)
((calls-known? l)
(bug "cannot find calls for known lambda ~S" l))
(else #f))))
; Walk (or map) a tree-modifying procedure down a variable's references.
(define (walk-refs-safely proc var)
(for-each proc (copy-list (variable-refs var))))
; Return #t if the total primop-cost of NODE is less than SIZE.
(define (small-node? node size)
(let label ((call (lambda-body node)))
(set! size (- size (primop-cost call)))
(if (>= size 0)
(walk-vector (lambda (n)
(cond ((lambda-node? n)
(label (lambda-body n)))
((call-node? n)
(label n))))
(call-args call))))
(>= size 0))
; True if executing NODE involves side-effects.
(define (side-effects? node . permissable)
(let ((permissable (cons #f permissable)))
(let label ((node node))
(cond ((not (call-node? node))
#f)
((or (n= 0 (call-exits node))
(not (memq (primop-side-effects (call-primop node))
permissable)))
#t)
(else
(let loop ((i (- (call-arg-count node) 1)))
(cond ((< i 0) #f)
((label (call-arg node i)) #t)
(else (loop (- i 1))))))))))
; A conservative check - is there only one SET-CONTENTS call for the owner and
; are all calls between CALL and the LETREC call that binds the owner calls to
; SET-CONTENTS?
;(define (single-letrec-set? call)
; (let ((owner (call-arg call set/owner)))
; (and (reference-node? owner)
; (every? (lambda (ref)
; (or (eq? (node-parent ref) call)
; (not (set-reference? ref))))
; (variable-refs (reference-variable owner))))))
;(define (set-reference? node)
; (and (eq? 'set-contents
; (primop-id (call-primop (node-parent node))))
; (= (node-index node) set/owner)))
;-------------------------------------------------------------------------------
(define the-undefined-value (list '*undefined-value*))
(define (undefined-value? x)
(eq? x the-undefined-value))
(define (undefined-value-node? x)
(and (literal-node? x)
(undefined-value? (literal-value x))))
(define (make-undefined-literal)
(make-literal-node the-undefined-value #f))
;-------------------------------------------------------------------------------
; Finding the lambda node called by CALL, JUMP, or RETURN
(define (called-node? node)
(and (node? (node-parent node))
(eq? node (called-node (node-parent node)))))
(define (called-node call)
(cond ((and (primop-procedure? (call-primop call))
(primop-call-index (call-primop call)))
=> (lambda (i)
(call-arg call i)))
(else '#f)))
(define (called-lambda call)
(get-lambda-value (call-arg call (primop-call-index (call-primop call)))))
(define (get-lambda-value value)
(cond ((lambda-node? value)
value)
((reference-node? value)
(get-variable-lambda (reference-variable value)))
(else
(error "peculiar procedure in ~S" value))))
(define (get-variable-lambda variable)
(if (global-variable? variable)
(or (variable-known-lambda variable)
(error "peculiar procedure variable ~S" variable))
(let* ((binder (variable-binder variable))
(index (node-index binder))
(call (node-parent binder))
(lose (lambda ()
(error "peculiar procedure variable ~S" variable))))
(case (primop-id (call-primop call))
((let)
(if (= 0 index)
(get-lambda-value (call-arg call (+ 1 (variable-index variable))))
(lose)))
((letrec1)
(if (= 0 index)
(get-letrec-variable-lambda variable)
(lose)))
((call)
(if (and (= 1 index)
(= 0 (variable-index variable))) ; var is a continuation var
(get-lambda-value (call-arg call 0))
(lose)))
(else
(lose))))))
; Some of the checking can be removed once I know the LETREC code works.
(define (get-letrec-variable-lambda variable)
(let* ((binder (variable-binder variable))
(call (lambda-body binder)))
(if (and (eq? 'letrec2 (primop-id (call-primop call)))
(reference-node? (call-arg call 1))
(eq? (car (lambda-variables binder))
(reference-variable (call-arg call 1))))
(call-arg call (+ 1 (variable-index variable)))
(error "LETREC is incorrectly organized ~S" (node-parent binder)))))
;(define (get-cell-variable-lambda variable)
; (let ((ref (first set-reference? (variable-refs variable))))
; (if (and ref
; (eq? 'letrec
; (literal-value (call-arg (node-parent ref) set/type))))
; (get-lambda-value (call-arg (node-parent ref) set/value))
; (error "peculiar lambda cell ~S" variable))))
;-------------------------------------------------------------------------------
; Attaching and detaching arguments to calls
; Make ARGS the arguments of call node PARENT. ARGS may contain #f.
(define (attach-call-args parent args)
(let ((len (call-arg-count parent)))
(let loop ((args args) (i 0))
(cond ((null? args)
(if (< i (- len 1))
(bug '"too few arguments added to node ~S" parent))
(values))
((>= i len)
(bug '"too many arguments added to node ~S" parent))
(else
(if (car args)
(attach parent i (car args)))
(loop (cdr args) (+ 1 i)))))))
; Remove all of the arguments of NODE.
(define (remove-call-args node)
(let ((len (call-arg-count node)))
(do ((i 1 (+ i 1)))
((>= i len))
(if (not (empty? (call-arg node i)))
(erase (detach (call-arg node i)))))
(values)))
; Replace the arguments of call node NODE with NEW-ARGS.
(define (replace-call-args node new-args)
(let ((len (length new-args)))
(remove-call-args node)
(if (n= len (call-arg-count node))
(let ((new (make-vector len empty))
(old (call-args node)))
(set-call-args! node new)))
(attach-call-args node new-args)))
; Remove all arguments to CALL that are EMPTY?. COUNT is the number of
; non-EMPTY? arguments.
(define (remove-null-arguments call count)
(let ((old (call-args call))
(new (make-vector count empty)))
(let loop ((i 0) (j 0))
(cond ((>= j count)
(values))
((not (empty? (vector-ref old i)))
(set-node-index! (vector-ref old i) j)
(vector-set! new j (vector-ref old i))
(loop (+ i 1) (+ j 1)))
(else
(loop (+ i 1) j))))
(set-call-args! call new)
(values)))
; Remove all but the first COUNT arguments from CALL.
(define (shorten-call-args call count)
(let ((old (call-args call))
(new (make-vector count empty)))
(vector-replace new old count)
(do ((i (+ count 1) (+ i 1)))
((>= i (vector-length old)))
(erase (vector-ref old i)))
(set-call-args! call new)
(values)))
; Insert ARG as the INDEXth argument to CALL.
(define (insert-call-arg call index arg)
(let* ((old (call-args call))
(len (vector-length old))
(new (make-vector (+ 1 len) empty)))
(vector-replace new old index)
(do ((i index (+ i 1)))
((>= i len))
(vector-set! new (+ i 1) (vector-ref old i))
(set-node-index! (vector-ref old i) (+ i 1)))
(set-call-args! call new)
(attach call index arg)
(values)))
; Remove the INDEXth argument to CALL.
(define (remove-call-arg call index)
(let* ((old (call-args call))
(len (- (vector-length old) 1))
(new (make-vector len)))
(vector-replace new old index)
(if (node? (vector-ref old index))
(erase (detach (vector-ref old index))))
(do ((i index (+ i 1)))
((>= i len))
(vector-set! new i (vector-ref old (+ i 1)))
(set-node-index! (vector-ref new i) i))
(set-call-args! call new)
(if (< index (call-exits call))
(set-call-exits! call (- (call-exits call) 1)))
(values)))
; Add ARG to the end of CALL's arguments.
(define (append-call-arg call arg)
(insert-call-arg call (call-arg-count call) arg))
; Replace CALL with the body of its continuation.
(define (remove-body call)
(if (n= 1 (call-exits call))
(bug "removing a call with ~D exits" (call-exits call))
(replace-body call (detach-body (lambda-body (call-arg call 0))))))
; Avoiding N-Ary Procedures
; These are used in the expansion of the LET-NODES macro.
(define (attach-two-call-args node a0 a1)
(attach node 0 a0)
(attach node 1 a1))
(define (attach-three-call-args node a0 a1 a2)
(attach node 0 a0)
(attach node 1 a1)
(attach node 2 a2))
(define (attach-four-call-args node a0 a1 a2 a3)
(attach node 0 a0)
(attach node 1 a1)
(attach node 2 a2)
(attach node 3 a3))
(define (attach-five-call-args node a0 a1 a2 a3 a4)
(attach node 0 a0)
(attach node 1 a1)
(attach node 2 a2)
(attach node 3 a3)
(attach node 4 a4))
;-------------------------------------------------------------------------------
; Bind VARS to VALUES using letrec at CALL. If CALL is already a letrec
; call, just add to it, otherwise make a new one.
(define (put-in-letrec vars values call)
(cond ((eq? 'letrec2 (primop-id (call-primop call)))
(let ((binder (node-parent call)))
(mark-changed call)
(for-each (lambda (var)
(set-variable-binder! var binder))
vars)
(set-lambda-variables! binder
(append (lambda-variables binder) vars))
(for-each (lambda (value)
(append-call-arg call value))
values)))
(else
(move-body
call
(lambda (call)
(let-nodes ((c (letrec1 1 l2))
(l2 ((x #f) . vars) (letrec2 1 l3 (* x) . values))
(l3 () call))
c))))))
;-------------------------------------------------------------------------------
; Changing lambda-nodes' variable lists
(define (remove-lambda-variable l-node index)
(remove-variable l-node (list-ref (lambda-variables l-node) index)))
(define (remove-variable l-node var)
(if (used? var)
(bug '"cannot remove referenced variable ~s" var))
(erase-variable var)
(let ((vars (lambda-variables l-node)))
(if (eq? (car vars) var)
(set-lambda-variables! l-node (cdr vars))
(do ((vars vars (cdr vars)))
((eq? (cadr vars) var)
(set-cdr! vars (cddr vars)))))))
; Remove all of L-NODES' unused variables.
(define (remove-unused-variables l-node)
(set-lambda-variables! l-node
(filter! (lambda (v)
(cond ((used? v)
#t)
(else
(erase-variable v)
#f)))
(lambda-variables l-node))))
;------------------------------------------------------------------------------
; Substituting Values For Variables
; Substitute VAL for VAR. If DETACH? is true then VAL should be detached
; and so can be used instead of a copy for the first substitution.
;
; If VAL is a reference to a variable named V, it was probably introduced by
; the CPS conversion code. In that case, the variable is renamed with the
; name of VAR. This helps considerably when debugging the compiler.
(define (substitute var val detach?)
(if (and (reference-node? val)
(eq? 'v (variable-name (reference-variable val)))
(not (global-variable? (reference-variable val))))
(set-variable-name! (reference-variable val)
(variable-name var)))
(let ((refs (variable-refs var)))
(set-variable-refs! var '())
(cond ((not (null? refs))
(for-each (lambda (ref)
(replace ref (copy-node-tree val)))
(if detach? (cdr refs) refs))
(if detach? (replace (car refs) (detach val))))
(detach?
(erase (detach val))))))
; Walk the tree NODE replacing references to variables in OLD-VARS with
; the corresponding variables in NEW-VARS. Uses VARIABLE-FLAG to mark
; the variables being replaced.
(define (substitute-vars-in-node-tree node old-vars new-vars)
(for-each (lambda (old new)
(set-variable-flag! old new))
old-vars
new-vars)
(let tree-walk ((node node))
(cond ((lambda-node? node)
(walk-vector tree-walk (call-args (lambda-body node))))
((call-node? node)
(walk-vector tree-walk (call-args node)))
((and (reference-node? node)
(variable-flag (reference-variable node)))
=> (lambda (new)
(replace node (make-reference-node new))))))
(for-each (lambda (old)
(set-variable-flag! old #f))
old-vars))
; Replaces the call node CALL with VALUE.
; (<proc> <exit> . <args>) => (<exit> <value>)
(define (replace-call-with-value call value)
(cond ((n= 1 (call-exits call))
(bug '"can only substitute for call with one exit ~s" call))
(else
(let ((cont (detach (call-arg call 0))))
(set-call-exits! call 0)
(replace-call-args call (if value (list cont value) (list cont)))
(set-call-primop! call (get-primop (enum primop let)))))))
;------------------------------------------------------------------------------
; Copying Node Trees
; Copy the node-tree NODE. This dispatches on the type of NODE.
; Variables which have been copied have the copy in the node-flag field.
(define (copy-node-tree node)
(let ((new (cond ((lambda-node? node)
(copy-lambda node))
((reference-node? node)
(let ((var (reference-variable node)))
(cond ((and (variable-binder var)
(variable-flag var))
=> make-reference-node)
(else
(make-reference-node var)))))
((call-node? node)
(copy-call node))
((literal-node? node)
(copy-literal-node node)))))
new))
; Copy a lambda node and its variables. The variables' copies are put in
; their VARIABLE-FLAG while the lambda's body is being copied.
(define (copy-lambda node)
(let* ((vars (map (lambda (var)
(if var
(let ((new (copy-variable var)))
(set-variable-flag! var new)
new)
#f))
(lambda-variables node)))
(new-node (make-lambda-node (lambda-name node)
(lambda-type node)
vars)))
(attach-body new-node (copy-call (lambda-body node)))
(set-lambda-protocol! new-node (lambda-protocol node))
(set-lambda-source! new-node (lambda-source node))
(for-each (lambda (var)
(if var (set-variable-flag! var #f)))
(lambda-variables node))
new-node))
(define (copy-call node)
(let ((new-node (make-call-node (call-primop node)
(call-arg-count node)
(call-exits node))))
(do ((i 0 (+ i 1)))
((>= i (call-arg-count node)))
(attach new-node i (copy-node-tree (call-arg node i))))
(set-call-source! new-node (call-source node))
new-node))
;------------------------------------------------------------------------------
; Checking the scoping of identifers
; Mark all ancestors of N with FLAG
(define (mark-ancestors n flag)
(do ((n n (node-parent n)))
((not (node? n)) (values))
(set-node-flag! n flag)))
; Does N have an ancestor with a non-#f flag?
(define (marked-ancestor? n)
(do ((n n (node-parent n)))
((or (not (node? n))
(node-flag n))
(node? n))))
; Does N have an ancestor with a #f flag?
(define (unmarked-ancestor? n)
(do ((n n (node-parent n)))
((or (not (node? n))
(not (node-flag n)))
(node? n))))
; Is ANC? an ancestor of NODE?
(define (node-ancestor? anc? node)
(set-node-flag! anc? #t)
(let ((okay? (marked-ancestor? node)))
(set-node-flag! anc? #f)
okay?))
; Find the lowest ancestor of N that has a non-#f flag
(define (marked-ancestor n)
(do ((n n (node-parent n)))
((or (not (node? n))
(node-flag n))
(if (node? n) n #f))))
; Mark the ancestors of START with #f, stopping when END is reached
(define (unmark-ancestors-to start end)
(do ((node start (node-parent node)))
((eq? node end))
(set-node-flag! node #f)))
; Return the lowest node that is above all NODES
(define (least-common-ancestor nodes)
(mark-ancestors (car nodes) #t)
(let loop ((nodes (cdr nodes)) (top (car nodes)))
(cond ((null? nodes)
(mark-ancestors top #f)
top)
(else
(let ((new (marked-ancestor (car nodes))))
(unmark-ancestors-to top new)
(loop (cdr nodes) new))))))
; Can TO be moved to FROM without taking variables out of scope.
; This first marks all of the ancestors of FROM, and then unmarks all of the
; ancestors of TO. The net result is to mark every node that is above FROM but
; not above TO. Then if any reference-node below FROM references a variable
; with a marked binder, that node, and thus FROM itself, cannot legally be
; moved to TO.
; This is not currently used anywhere, and it doesn't know about trivial
; calls.
(define (hoistable-node? from to)
(let ((from (if (call-node? from)
(node-parent (nontrivial-ancestor from))
from)))
(mark-ancestors (node-parent from) #t)
(mark-ancestors to #f)
(let ((okay? (let label ((n from))
(cond ((lambda-node? n)
(let* ((vec (call-args (lambda-body n)))
(c (vector-length vec)))
(let loop ((i 0))
(cond ((>= i c) #t)
((label (vector-ref vec i))
(loop (+ i 1)))
(else #f)))))
((reference-node? n)
(let ((b (variable-binder (reference-variable n))))
(or (not b) (not (node-flag b)))))
(else #t)))))
(mark-ancestors (node-parent from) #f)
okay?)))
; Mark all of the lambda nodes which bind variables referenced below NODE.
(define (mark-binders node)
(let label ((n node))
(cond ((lambda-node? n)
(walk-vector label (call-args (lambda-body n))))
((reference-node? n)
(let ((b (variable-binder (reference-variable n))))
(if b (set-node-flag! b #f))))))
(values))
;------------------------------------------------------------------------------
; For each lambda-node L this sets (PARENT L) to be the enclosing PROC node
; of L and, if L is a PROC node, sets (KIDS L) to be the lambda nodes it
; encloses.
(define (find-scoping lambdas parent set-parent! kids set-kids!)
(receive (procs others)
(partition-list proc-lambda? lambdas)
(for-each (lambda (l)
(set-parent! l #f)
(set-kids! l '()))
procs)
(for-each (lambda (l)
(set-parent! l #f))
others)
(letrec ((set-lambda-parent!
(lambda (l)
(cond ((parent l)
=> identity)
((proc-ancestor l)
=> (lambda (p)
(let ((p (if (proc-lambda? p)
p
(set-lambda-parent! p))))
(set-kids! p (cons l (kids p)))
(set-parent! l p)
p)))
(else #f)))))
(for-each set-lambda-parent! lambdas))
(values procs others)))
(define (proc-ancestor node)
(let ((p (node-parent node)))
(if (not (node? p))
#f
(let ((node (do ((p p (node-parent p)))
((lambda-node? p)
p))))
(do ((node node (node-parent (node-parent node))))
((proc-lambda? node)
node))))))
(define (no-free-references? node)
(if (call-node? node)
(error "NO-FREE-REFERENCES only works on value nodes: ~S" node))
(let label ((node node))
(cond ((reference-node? node)
(let ((b (variable-binder (reference-variable node))))
(or (not b)
(node-flag b))))
((lambda-node? node)
(set-node-flag! node #t)
(let* ((vec (call-args (lambda-body node)))
(res (let loop ((i (- (vector-length vec) 1)))
(cond ((< i 0) #t)
((not (label (vector-ref vec i))) #f)
(else (loop (- i 1)))))))
(set-node-flag! node #f)
res))
(else
#t))))
(define (node-type node)
(cond ((literal-node? node)
(literal-type node))
((reference-node? node)
(variable-type (reference-variable node)))
((lambda-node? node)
(lambda-node-type node))
((and (call-node? node)
(primop-trivial? (call-primop node)))
(trivial-call-return-type node))
(else
(error "node ~S does not represent a value" node))))
;----------------------------------------------------------------
; Debugging utilities
(define (show-simplified node)
(let loop ((n node) (r '()))
(if (node? n)
(loop (node-parent n) (cons (node-simplified? n) r))
(reverse r))))
(define (show-flag node)
(let loop ((n node) (r '()))
(if (node? n)
(loop (node-parent n) (cons (node-flag n) r))
(reverse r))))
(define (reset-simplified node)
(let loop ((n node))
(cond ((node? n)
(set-node-simplified?! n #f)
(loop (node-parent n))))))

544
ps-compiler/node/node.scm
View File

@ -1,544 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; This file contains the definitions of the node tree data structure.
;---------------------------------------------------------------------------
; Records to represent variables.
(define-record-type variable
((name) ; Source code name for variable (used for debugging only)
(id) ; Unique numeric identifier (used for debugging only)
(type) ; Type for variable's value
)
(binder ; LAMBDA node which binds this variable
(refs '()) ; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
(flag #f) ; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
; all users must leave this is #F
(flags '()) ; For various annotations, e.g. IGNORABLE
(generate #f) ; For whatever code generation wants
))
(define-record-discloser type/variable
(lambda (var)
(node-hash var)
(list 'variable (variable-name var) (variable-id var))))
(define (make-variable name type)
(variable-maker name (new-id) type))
(define (make-global-variable name type)
(let ((var (make-variable name type)))
(set-variable-binder! var #f)
var))
(define (global-variable? var)
(not (variable-binder var)))
; Every variable has a unique numeric identifier that is used for printing.
(define *variable-id* 0)
(define (new-id)
(let ((id *variable-id*))
(set! *variable-id* (+ 1 *variable-id*))
id))
(define (erase-variable var)
(cond ((eq? (variable-id var) '<erased>)
(bug "variable ~S already erased" var))
(else
(set-variable-id! var '<erased>))))
(define *node-hash-table* #f)
(define (reset-node-id)
(set! *variable-id* 0)
(set! *node-hash-table* (make-table)))
(define (node-hash var-or-lambda)
(let ((id (if (variable? var-or-lambda)
(variable-id var-or-lambda)
(lambda-id var-or-lambda))))
(table-set! *node-hash-table* id var-or-lambda)))
(define (node-unhash n)
(table-ref *node-hash-table* n))
; The index of VAR in the variables bound by its binder.
(define (variable-index var)
(let ((binder (variable-binder var)))
(if (not binder)
(bug "VARIABLE-INDEX called on global variable ~S" var)
(do ((i 0 (+ i 1))
(vs (lambda-variables binder) (cdr vs)))
((eq? (car vs) var)
i)))))
; Copy an old variable.
(define (copy-variable old)
(let ((var (make-variable (variable-name old) (variable-type old))))
(set-variable-flags! var (variable-flags old))
var))
; An unused variable is either #F or a variable with no references.
(define (used? var)
(and var
(not (null? (variable-refs var)))))
(define (unused? var)
(not (used? var)))
; known values for top-level variables
(define (flag-accessor flag)
(lambda (var)
(let ((p (flag-assq flag (variable-flags var))))
(if p (cdr p) #f))))
(define (flag-setter flag)
(lambda (var value)
(set-variable-flags! var
(cons (cons flag value)
(variable-flags var)))))
(define (flag-remover flag)
(lambda (var)
(set-variable-flags! var (filter (lambda (x)
(or (not (pair? x))
(not (eq? (car x) flag))))
(variable-flags var)))))
(define variable-known-value (flag-accessor 'known-value))
(define add-variable-known-value! (flag-setter 'known-value))
(define remove-variable-known-value! (flag-remover 'known-value))
(define variable-simplifier (flag-accessor 'simplifier))
(define add-variable-simplifier! (flag-setter 'simplifier))
(define remove-variable-simplifier! (flag-remover 'simplifier))
(define variable-known-lambda (flag-accessor 'known-lambda))
(define note-known-global-lambda! (flag-setter 'known-lambda))
;----------------------------------------------------------------------------
; The main record for the node tree
(define-record-type node
((variant) ; One of LAMBDA, CALL, REFERENCE, LITERAL
)
((parent empty) ; Parent node
(index '<free>) ; Index of this node in parent
(simplified? #f) ; True if it has already been simplified.
(flag #f) ; Useful flag, all users must leave this is #F
stuff-0 ; Variant components - each type of node has a different
stuff-1 ; use for these fields
stuff-2
stuff-3
))
(define-record-discloser type/node
(lambda (node)
`(node ,(node-variant node)
. ,(case (node-variant node)
((lambda)
(node-hash node)
(list (lambda-name node) (lambda-id node)))
((call)
(list (primop-id (call-primop node))))
((reference)
(let ((var (reference-variable node)))
(list (variable-name var) (variable-id var))))
((literal)
(list (literal-value node)))
(else
'())))))
(define make-node node-maker)
;--------------------------------------------------------------------------
; EMPTY is used to mark empty parent and child slots in nodes.
(define empty
(list 'empty))
(define (empty? obj) (eq? obj empty))
(define (proclaim-empty probe)
(cond ((not (empty? probe))
(bug "not empty - ~S" probe))))
;----------------------------------------------------------------------------
; This walks the tree rooted at NODE and removes all pointers that point into
; this tree from outside.
(define (erase node)
(let label ((node node))
(cond ((empty? node)
#f)
(else
(case (node-variant node)
((lambda)
(label (lambda-body node)))
((call)
(walk-vector label (call-args node))))
(really-erase node)))))
; This does the following:
; Checks that this node has not already been removed from the tree.
;
; Reference nodes are removed from the refs list of the variable they reference.
;
; For lambda nodes, the variables are erased, non-CONT lambdas are removed from
; the *LAMBDAS* list (CONT lambdas are never on the list).
;
; Literal nodes whose values have reference lists are removed from those
; reference lists.
(define (really-erase node)
(cond ((empty? node)
#f)
(else
(cond ((eq? (node-index node) '<erased>)
(bug "node erased twice ~S" node))
((reference-node? node)
(let ((var (reference-variable node)))
(set-variable-refs! var
(delq! node (variable-refs var)))))
((lambda-node? node)
(for-each (lambda (v)
(if v (erase-variable v)))
(lambda-variables node))
(if (neq? (lambda-type node) 'cont)
(delete-lambda node))
(set-lambda-variables! node '())) ; safety
((literal-node? node)
(let ((refs (literal-refs node)))
(if refs
(set-literal-reference-list!
refs
(delq! node (literal-reference-list refs)))))))
; (erase-type (node-type node))
(set-node-index! node '<erased>))))
;---------------------------------------------------------------------------
; CONNECTING AND DISCONNECTING NODES
;
; There are two versions of each of these routines, one for value nodes
; (LAMBDA, REFERENCE, or LITERAL), and one for call nodes.
; Detach a node from the tree.
(define (detach node)
(vector-set! (call-args (node-parent node))
(node-index node)
empty)
(set-node-index! node #f)
(set-node-parent! node empty)
node)
(define (detach-body node)
(set-lambda-body! (node-parent node) empty)
(set-node-index! node #f)
(set-node-parent! node empty)
node)
; Attach a node to the tree.
(define (attach parent index child)
(proclaim-empty (node-parent child))
(proclaim-empty (vector-ref (call-args parent) index))
(vector-set! (call-args parent) index child)
(set-node-parent! child parent)
(set-node-index! child index)
(values))
(define (attach-body parent call)
(proclaim-empty (node-parent call))
(proclaim-empty (lambda-body parent))
(set-lambda-body! parent call)
(set-node-parent! call parent)
(set-node-index! call '-1)
(values))
; Replace node in tree with value of applying proc to node.
; Note the fact that a change has been made at this point in the tree.
(define (move node proc)
(let ((parent (node-parent node))
(index (node-index node)))
(detach node)
(let ((new (proc node)))
(attach parent index new)
(mark-changed new))))
(define (move-body node proc)
(let ((parent (node-parent node)))
(detach-body node)
(let ((new (proc node)))
(attach-body parent new)
(mark-changed new))))
; Put CALL into the tree as the body of lambda-node PARENT, making the current
; body of PARENT the body of lambda-node CONT.
(define (insert-body call cont parent)
(move-body (lambda-body parent)
(lambda (old-call)
(attach-body cont old-call)
call)))
; Replace old-node with new-node, noting that a change has been made at this
; point in the tree.
(define (replace old-node new-node)
(let ((index (node-index old-node))
(parent (node-parent old-node)))
(mark-changed old-node)
(erase (detach old-node))
(attach parent index new-node)
(set-node-simplified?! new-node #f)
(values)))
(define (replace-body old-node new-node)
(let ((parent (node-parent old-node)))
(mark-changed old-node)
(erase (detach-body old-node))
(attach-body parent new-node)
(set-node-simplified?! new-node #f)
(values)))
; Starting with the parent of NODE, set the SIMPLIFIED? flags of the
; ancestors of NODE to be #F.
(define (mark-changed node)
(do ((p (node-parent node) (node-parent p)))
((or (empty? p)
(not (node-simplified? p))))
(set-node-simplified?! p #f)))
;-------------------------------------------------------------------------
; Syntax for defining the different types of nodes.
(define-syntax define-node-type
(lambda (form rename compare)
(let ((id (cadr form))
(slots (cddr form)))
(let ((pred (concatenate-symbol id '- 'node?)))
`(begin (define (,pred x)
(eq? ',id (node-variant x)))
. ,(do ((i 0 (+ i 1))
(s slots (cdr s))
(r '() (let ((n (concatenate-symbol id '- (car s)))
(f (concatenate-symbol 'node-stuff- i)))
`((define-node-field ,n ,pred ,f)
. ,r))))
((null? s) (reverse r))))))))
; These are used to rename the NODE-STUFF fields of particular node variants.
(define-syntax define-node-field
(lambda (form rename compare)
(let ((id (cadr form))
(predicate (caddr form))
(field (cadddr form)))
`(begin
(define (,id node)
(,field (enforce ,predicate node)))
(define (,(concatenate-symbol 'set- id '!) node val)
(,(concatenate-symbol 'set- field '!)
(enforce ,predicate node)
val))))))
;-------------------------------------------------------------------------
; literals
(define-node-type literal
value ; the value
type ; the type of the value
refs ; either #F or a literal-reference record; only a few types of literal
) ; literal values require reference lists
(define-record-type literal-reference
()
((list '()) ; list of literal nodes that refer to a particular value
))
(define make-literal-reference-list literal-reference-maker)
(define (make-literal-node value type)
(let ((node (make-node 'literal)))
(set-literal-value! node value)
(set-literal-type! node type)
(set-literal-refs! node #f)
node))
(define (copy-literal-node node)
(let ((new (make-node 'literal))
(refs (literal-refs node)))
(set-literal-value! new (literal-value node))
(set-literal-type! new (literal-type node))
(set-literal-refs! new refs)
(if refs (set-literal-reference-list!
refs
(cons new (literal-reference-list refs))))
new))
(define (make-marked-literal value refs)
(let ((node (make-node 'literal)))
(set-literal-value! node value)
(set-literal-refs! node refs)
(set-literal-reference-list! refs
(cons node (literal-reference-list refs)))
node))
;-------------------------------------------------------------------------
; These just contain an identifier.
(define-node-type reference
variable
)
(define (make-reference-node variable)
(let ((node (make-node 'reference)))
(set-reference-variable! node variable)
(set-variable-refs! variable (cons node (variable-refs variable)))
node))
; Literal and reference nodes are leaf nodes as they do not contain any other
; nodes.
(define (leaf-node? n)
(or (literal-node? n)
(reference-node? n)))
;--------------------------------------------------------------------------
; Call nodes
(define-node-type call
primop ; the primitive being called
args ; vector of child nodes
exits ; the number of arguments that are continuations
source ; source info
)
; Create a call node with primop P, N children and EXITS exits.
(define (make-call-node primop n exits)
(let ((node (make-node 'call)))
(set-call-primop! node primop)
(set-call-args! node (make-vector n empty))
(set-call-exits! node exits)
(set-call-source! node #f)
node))
(define (call-arg call index)
(vector-ref (call-args call) index))
(define (call-arg-count call)
(vector-length (call-args call)))
;----------------------------------------------------------------------------
; LAMBDA NODES
(define-node-type lambda
body ; the call-node that is the body of the lambda
variables ; a list of variable records with #Fs for ignored positions
source ; source code for the lambda (if any)
data ; a LAMBDA-DATA record (lambdas have more associated data than
) ; the other node types.)
(define-subrecord lambda lambda-data lambda-data
((name) ; symbol (for debugging only)
id ; unique integer (for debugging only)
(type)) ; PROC, KNOWN-PROC, CONT, or JUMP (maybe ESCAPE at some point)
((block #f) ; either a basic-block (for flow analysis) or a code-block
; (for code generation).
(env #f) ; a record containing lexical environment data
(protocol #f) ; calling protocol from the source language
(prev #f) ; previous node on *LAMBDAS* list
(next #f) ; next node on *LAMBDAS* list
))
; Doubly linked list of all non-CONT lambdas
(define *lambdas* #f)
(define (initialize-lambdas)
(set! *lambdas* (make-lambda-node '*lambdas* 'cont '()))
(link-lambdas *lambdas* *lambdas*))
(define (link-lambdas node1 node2)
(set-lambda-prev! node2 node1)
(set-lambda-next! node1 node2))
(define (add-lambda node)
(let ((next (lambda-next *lambdas*)))
(link-lambdas *lambdas* node)
(link-lambdas node next)))
(define (delete-lambda node)
(link-lambdas (lambda-prev node) (lambda-next node))
(set-lambda-prev! node #f)
(set-lambda-next! node #f))
(define (walk-lambdas proc)
(do ((n (lambda-next *lambdas*) (lambda-next n)))
((eq? n *lambdas*))
(proc n))
(values))
(define (make-lambda-list)
(do ((n (lambda-next *lambdas*) (lambda-next n))
(l '() (cons n l)))
((eq? n *lambdas*)
l)))
(define (add-lambdas nodes)
(for-each add-lambda nodes))
; Create a lambda node. NAME is used as the name of the lambda node's
; self variable. VARS is a list of variables. The VARIABLE-BINDER slot
; of each variable is set to be the new lambda node.
(define (make-lambda-node name type vars)
(let ((node (make-node 'lambda))
(data (lambda-data-maker name (new-id) type)))
(set-lambda-body! node empty)
(set-lambda-variables! node vars)
(set-lambda-data! node data)
(set-lambda-source! node #f)
(for-each (lambda (var)
(if var (set-variable-binder! var node)))
vars)
(if (neq? type 'cont)
(add-lambda node))
node))
; Change the type of lambda-node NODE to be TYPE. This may require adding or
; deleting NODE from the list *LAMBDAS*.
(define (change-lambda-type node type)
(let ((has (lambda-type node)))
(cond ((neq? type (lambda-type node))
(set-lambda-type! node type)
(cond ((eq? type 'cont)
(delete-lambda node))
((eq? has 'cont)
(add-lambda node)))))
(values)))
(define (lambda-variable-count node)
(length (lambda-variables node)))
(define (calls-known? node)
(neq? (lambda-type node) 'proc))
(define (set-calls-known?! node)
(set-lambda-type! node 'known-proc))
(define (proc-lambda? node)
(or (eq? 'proc (lambda-type node))
(eq? 'known-proc (lambda-type node))))

355
ps-compiler/node/pp-cps.scm
View File

@ -1,355 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Pretty-printing the node tree
; Sample output:
; 34 (F_12 (C_11 UNIT_0)
; (SET-CONTENTS 1 C_11 UNIT_0 UNIT '0 ^F_14))
;
; 35 (F_14 (C_13 N_1)
; 36 (LET* (((LOOP_73) (CONS CELL '0))
; 37 (() (SET-CONTENTS LOOP_73 CELL '0 ^F_34))
; 38 ((V_77) (CONTENTS LOOP_73 CELL '0)))
; (V_77 1 C_13 N_1 '1)))
;
; 39 (F_34 (C_33 I_9 R_7)
; 40 (LET* (((V_61) (CONTENTS UNIT_0 UNIT '3))
; 41 ((V_63) (V_61 I_9 '0)))
; (TRUE? 2 ^C_58 ^C_41 V_63)))
;
; 42 (C_58 ()
; (C_33 0 R_7))
;
; 43 (C_41 ()
; 44 (LET* (((V_46) (CONTENTS UNIT_0 UNIT '2))
; 45 ((V_56) (V_46 I_9 R_7))
; 46 ((V_44) (CONTENTS UNIT_0 UNIT '1))
; 47 ((V_54) (V_44 I_9 '1))
; 48 ((V_52) (CONTENTS LOOP_73 CELL '0)))
; (V_52 1 C_33 V_54 V_56)))
; What it means:
; Variables `<name>_<id>' V_61
; Primops `<primop name>' CONTENTS
; Lambdas `^<self variable>' ^F_34
; Literals `'<value>' '0
; 35 (F_14 (C_13 N_1)
; This is the header for a lambda node. `35' is the object hash of the node.
; `F_14' is the LAMBDA-NAME and LAMBDA-ID, `(C_13 N_1)' is the variable list. The
; start of this line (not counting the object hash) is indented one column
; more than the start of the lexically superior lambda.
; 36 (LET* (((LOOP_73) (CONS CELL '0))
; 37 (() (SET-CONTENTS LOOP_73 CELL '0 ^F_34))
; 38 ((V_77) (CONTENTS LOOP_73 CELL '0)))
; (V_77 1 C_13 N_1 '1)))
; This is the body of the lambda. It is a block consisting of three simple
; calls and then a tail recursive call. The simple calls are in the form
; of a LET* that allows multiple value returns. The actual body of the
; lambda is the call `(CONS CELL '0)'. The continuation to this call is
; a lambda node `(LAMBDA (LOOP_73) (SET-CONTENTS ...))'. `36' is the
; object hash of this continuation lambda.
; After the block any lambdas in the block are printed. This lambda is
; followed by `F_34'.
; (PP-CPS node . port)
;---------------------------------------------------------------------------
; Print CPS node tree in linear form. Port defaults to the current output port.
; This just dispatches on the type of NODE.
(define (pp-cps node . port)
(let* ((port (if (null? port) (current-output-port) (car port)))
(port (if (current-column port)
port
(make-tracking-output-port port))))
(set! *rereadable?* #f)
(cond ((lambda-node? node)
(pp-cps-lambda node 4 port))
((call-node? node)
(write-non-simple-call node port))
(else
(write-node-value node port)))
(newline port)
((structure-ref i/o force-output) port)))
(define (rereadable-pp-cps node port)
(set! *rereadable?* #t)
(pp-cps-lambda node 4 port)
(values))
(define (indent port count)
(let ((count (cond ((<= (current-column port) count)
(- count (current-column port)))
(else
(newline port)
count))))
(do ((count count (- count 1)))
((>= 0 count))
(writec port #\space))))
(define *rereadable?* #f)
(define *next-pp-id* 0)
(define (reset-pp-cps)
(set! *next-pp-id* 0))
(define (next-pp-id)
(let ((id *next-pp-id*))
(set! *next-pp-id* (+ *next-pp-id* 1))
id))
; Print a lambda node by printing its identifiers, then its call, and finally
; any other lambdas that it includes.
(define (pp-cps-lambda node indent-to port)
(format port "~&~%")
(cond ((not *rereadable?*)
(node-hash node)
(format port "~D" (lambda-id node))))
(indent port indent-to)
(write-lambda-header node port)
(let ((internal (pp-cps-body (lambda-body node) indent-to port)))
(writec port #\))
(for-each (lambda (n)
(pp-cps-lambda n (+ indent-to 1) port))
internal)))
(define (write-lambda-header node port)
(writec port '#\()
(writec port (case (lambda-type node)
((proc known-proc) #\P)
((cont) #\C)
((jump) #\J)
((escape) #\E)))
(writec port #\space)
(print-lambda-name node port)
(writec port #\space)
(write-lambda-vars node port))
(define (write-lambda-vars node port)
(let ((vars (lambda-variables node)))
(cond ((not (null? vars))
(writec port '#\()
(print-variable-name (car vars) port)
(do ((v (cdr vars) (cdr v)))
((null? v))
(writec port '#\space)
(print-variable-name (car v) port))
(writec port '#\)))
(else
(format port "()")))))
; Print the body of a lambda node. A simple call is one that has exactly
; one exit. They and calls to lambda nodes are printed as a LET*.
(define (pp-cps-body call indent-to port)
(newline port)
(cond ((or (simple-call? call)
(let-call? call))
(write-let* call indent-to port))
(else
(indent port (+ '2 indent-to))
(write-non-simple-call call port))))
; Write out a series of calls as a LET*. The LET* ends when a call is reached
; that is neither a simple call or a call to a lambda.
(define (write-let* call indent-to port)
(cond ((not *rereadable?*)
(node-hash (call-arg call 0))
(format port "~D" (lambda-id (call-arg call '0)))))
(indent port (+ '2 indent-to))
(writec port '#\()
(format port "LET* ")
(writec port '#\()
(let loop ((call (next-call call))
(ns (write-simple-call call indent-to port)))
(cond ((or (simple-call? call)
(let-call? call))
(newline port)
(cond ((not *rereadable?*)
(format port "~D" (lambda-id (call-arg call '0)))
(node-hash (call-arg call 0))))
(indent port (+ '9 indent-to))
(loop (next-call call)
(append (write-simple-call call indent-to port) ns)))
(else
(writec port '#\))
(newline port)
(indent port (+ '4 indent-to))
(let ((ns (append (write-non-simple-call call port) ns)))
(writec port '#\))
ns)))))
(define (simple-call? call)
(and (= '1 (call-exits call))
(not (lambda-block (call-arg call 0)))))
(define (let-call? call)
(calls-this-primop? call 'let))
; Get the call that follows CALL in a LET*.
(define (next-call call)
(lambda-body (call-arg call '0)))
; Write out one line of a LET*.
(define (write-simple-call call indent-to port)
(if (let-call? call)
(write-let-call call indent-to port)
(really-write-simple-call call indent-to port)))
; Write the variables bound by the continuation and then the primop and
; non-continuation arguments of the call.
(define (really-write-simple-call call indent-to port)
(writec port '#\()
(write-lambda-vars (call-arg call '0) port)
(indent port (+ indent-to '21))
(writec port '#\()
(format port "~S" (primop-id (call-primop call)))
(write-call-args call '1 port)
(writec port '#\))
(find-lambda-nodes call 1))
; Write the variables of the lambda and then the values of the arguments.
(define (write-let-call call indent-to port)
(writec port '#\()
(write-lambda-vars (call-arg call '0) port)
(cond ((= '1 (vector-length (call-args call)))
(writec port '#\))
'())
(else
(writec port #\*)
(indent port (+ indent-to '21))
(write-node-value (call-arg call '1) port)
(write-call-args call '2 port)
(find-lambda-nodes call 1))))
(define (find-lambda-nodes call start)
(reverse (let label ((call call) (start start) (ls '()))
(do ((i start (+ i 1))
(ls ls (let ((arg (call-arg call i)))
(cond ((call-node? arg)
(label arg 0 ls))
((lambda-node? arg)
(cons arg ls))
(else ls)))))
((>= i (call-arg-count call))
ls)))))
; Write out a call that ends a LET* block.
(define (write-non-simple-call call port)
(writec port '#\()
(format port "~A ~D" (primop-id (call-primop call)) (call-exits call))
(write-call-args call '0 port)
(find-lambda-nodes call 0))
; Write out the arguments of CALL starting with START.
(define (write-call-args call start port)
(let* ((vec (call-args call))
(len (vector-length vec)))
(do ((i start (+ i '1)))
((>= i len))
(writec port '#\space)
(write-node-value (vector-ref vec i) port))
(writec port '#\))))
; Print out a literal value.
(define (cps-print-literal value port)
(format port "'~S" value))
; Dispatch on the type of NODE to get the appropriate printing method.
(define (write-node-value node port)
(cond ((not (node? node))
(format port "{not a node}"))
((lambda-node? node)
(writec port '#\^)
(print-lambda-name node port))
((call-node? node)
(format port "(~S" (primop-id (call-primop node)))
(write-call-args node '0 port))
((literal-node? node)
(cps-print-literal (literal-value node) port))
((reference-node? node)
(print-variable-name (reference-variable node) port))
(else
(bug "WRITE-NODE-VALUE got funny node ~S" node))))
; Printing variables and lambda nodes
; #T if variables are supposed to print as the name of the register containing
; them instead of their name.
(define *pp-register-names?* '#f)
; A whole bunch of different entry points for printing variables in slightly
; different ways.
(define (print-variable-name var port)
(cond ((not var)
(format port "#f"))
; ((and *pp-register-names?*
; (reg? (variable-register var)))
; (format port "~S" (reg-name (variable-register var))))
(else
(let ((id (cond ((not *rereadable?*)
(variable-id var))
((variable-flag var)
=> identity)
(else
(let ((id (next-pp-id)))
(set-variable-flag! var id)
id)))))
(format port "~S_~S" (variable-name var) id)))))
; Same as the above without the check for a register.
(define (print-variable-plain-name var port)
(cond ((not var)
(format port "#f"))
(else
(format port "~S_~D" (variable-name var) (variable-id var)))))
; Return the name as a string.
(define (variable-print-name var)
(print-variable-name var '#f))
; Return the name as a symbol.
(define (variable-unique-name var)
(string->symbol (variable-print-name var)))
; Printing lambda-nodes as variables
(define (print-lambda-name lnode port)
(let ((id (cond ((not *rereadable?*)
(lambda-id lnode))
((node-flag lnode)
=> identity)
(else
(let ((id (next-pp-id)))
(set-node-flag! lnode id)
id)))))
(format port "~S_~D" (lambda-name lnode) id)))
(define (lambda-print-name lnode)
(print-lambda-name lnode '#f))
(define (lambda-unique-name lnode)
(string->symbol (lambda-print-name lnode)))

128
ps-compiler/node/primop.scm
View File

@ -1,128 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; The information about a primitive operation.
(define-record-type primop
(id ; Symbol identifying this primop
trivial? ; #t if this primop has does not require a continuation
side-effects ; side-effects of this primop
simplify-call-proc ; Simplify method
primop-cost-proc ; Cost of executing this operation
; (in some undisclosed metric)
return-type-proc ; Give the return type (for trivial primops only)
proc-data ; Record containing more data for the procedure primops
cond-data ; Record containing more data for conditional primops
)
(code-data ; Code generation data
))
(define-record-discloser type/primop
(lambda (primop)
(list 'primop (object-hash primop) (primop-id primop))))
(define all-primops (make-vector primop-count))
(define (make-primop id trivial? side-effects simplify cost type)
(let ((enum (name->enumerand id primop))
(primop (primop-maker id trivial? side-effects simplify cost type #f #f)))
(if enum
(vector-set! all-primops enum primop))
primop))
(define (get-primop enum)
(vector-ref all-primops enum))
(define-local-syntax (define-primop-method id args)
`(define (,id . ,args)
((,(concatenate-symbol 'primop- id '- 'proc) (call-primop ,(car args)))
. ,args)))
(define-primop-method primop-cost (call))
(define-primop-method simplify-call (call))
(define (trivial-call-return-type call)
((primop-return-type-proc (call-primop call)) call))
;-------------------------------------------------------------------------------
; procedure primops
(define-subrecord primop primop-proc-data primop-proc-data
(call-index ; index of argument being called
)
())
(define (primop-procedure? primop)
(if (primop-proc-data primop) #t #f))
; (call <cont> <proc-var> . <args>)
; (tail-call <cont-var> <proc-var> . <args>)
; (return <proc-var> . <args>)
; (jump <proc-var> . <args>)
; (throw <proc-var> . <args>)
;
; (unknown-call <cont> <proc-var> . <args>)
; (unknown-tail-call <cont-var> <proc-var> . <args>)
; (unknown-return <proc-var> . <args>)
(define (make-proc-primop id side-effects simplify cost index)
(let* ((enum (name->enumerand id primop))
(data (primop-proc-data-maker index))
(primop (primop-maker id #f side-effects simplify cost #f data #f)))
(vector-set! all-primops enum primop)
primop))
;-------------------------------------------------------------------------------
; conditional primops
(define-subrecord primop primop-cond-data primop-cond-data
(expand-to-conditional-proc ; Expand this call to a conditional
simplify-conditional?-proc ; Can this conditional be simplified
)
())
(define-primop-method expand-to-conditional (call))
(define-primop-method simplify-conditional? (call index value))
(define (primop-conditional? primop)
(if (primop-cond-data primop) #t #f))
(define (make-conditional-primop id side-effects simplify cost expand simplify?)
(let* ((enum (name->enumerand id primop))
(data (primop-cond-data-maker expand simplify?))
(primop (primop-maker id #f side-effects simplify cost #f #f data)))
(if enum (vector-set! all-primops enum primop))
primop))
;-------------------------------------------------------------------------------
; Random constants for location calls:
; ($CONTENTS <thing> <type> <offset> <rep>)
; ($SET-CONTENTS <cont> <thing> <type> <offset> <rep> <value>)
; 0 1 2 3 4
(define loc/owner 0)
(define loc/type 1)
(define loc/rep 2)
(define set/owner 1)
(define set/type 2)
(define set/rep 3)
(define set/value 4)
; For slots that do not contain code pointers:
; ($CLOSURE <cont> <env> <slot>)
; ($SET-CLOSURE <cont> <env> <slot> <value>)
; For slots that do contain code pointers:
; ($MAKE-PROCEDURE <cont> <env> <slot>)
; ($SET-CODE <cont> <env> <slot> <value>)
; For known calls to slots that contain code pointers:
; ($ENV-ADJUST <cont> <env> <slot>)
; 0 1 2
(define env/owner 0)
(define env/offset 1)
(define env/value 2)

212
ps-compiler/node/vector.scm
View File

@ -1,212 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
;----------------------------------------------------------------------------
; STORING NODE TREES IN VECTORS
;----------------------------------------------------------------------------
; The use of OTHER and GLOBAL depends on whether NODE->VECTOR or VECTOR->NODE
(define-record-type vec
(vector ; an expanding vector (NODE->VECTOR) or just a vector (VECTOR->NODE)
(index) ; the index of the next empty slot or the next thing to read
locals ; vector of local variables (VECTOR->NODE only)
)
())
(define make-vec vec-maker)
; Add value as the next thing in the VEC.
(define (add-datum vec value)
(xvector-set! (vec-vector vec) (vec-index vec) value)
(set-vec-index! vec (+ 1 (vec-index vec))))
; Convert a node into a vector
;
; literal => QUOTE <literal> <rep>
; reference => <index of the variable's name in vector> if lexical, or
; GLOBAL <variable> if it isn't
; lambda => LAMBDA <stuff> #vars <variable names+reps> <call>
; call => CALL <source> <primop> <exits> <number of args> <args>
; Preserve the node as a vector.
(define (node->vector node)
(let ((vec (make-vec (make-xvector #f) 0 #f)))
(real-node->vector node vec)
(xvector->vector (vec-vector vec))))
; The main dispatch
(define (real-node->vector node vec)
(case (node-variant node)
((literal)
(literal->vector node vec))
((reference)
(reference->vector node vec))
((lambda)
(lambda->vector node vec))
((call)
(add-datum vec 'call)
(call->vector node vec))
(else
(bug "node->vector got funny node ~S" node))))
; VARIABLE-FLAGs are used to mark variables with their position in the
; vector.
(define (lambda->vector node vec)
(add-datum vec 'lambda)
(add-datum vec (lambda-name node))
(add-datum vec (lambda-type node))
(add-datum vec (lambda-protocol node))
(add-datum vec (lambda-source node))
(add-datum vec (lambda-variable-count node))
(for-each (lambda (var)
(cond ((not var)
(add-datum vec #f))
(else
(set-variable-flag! var (vec-index vec))
(add-datum vec (variable-name var))
(add-datum vec (variable-type var)))))
(lambda-variables node))
(call->vector (lambda-body node) vec)
(for-each (lambda (var)
(if var
(set-variable-flag! var #f)))
(lambda-variables node)))
; If VAR is bound locally, then put the index of the variable within the vector
; into the vector.
(define (reference->vector node vec)
(let ((var (reference-variable node)))
(cond ((not (variable-binder var))
(add-datum vec 'global)
(add-datum vec var))
((integer? (variable-flag var))
(add-datum vec (variable-flag var)))
(else
(bug "variable ~S has no vector location" var)))))
(define (literal->vector node vec)
(let ((value (literal-value node)))
(add-datum vec 'quote)
(add-datum vec (literal-value node))
(add-datum vec (literal-type node))))
; This counts down so that the continuation will be done after the arguments.
; Why does this matter?
(define (call->vector node vec)
(let* ((args (call-args node))
(len (vector-length args)))
(add-datum vec (call-source node))
(add-datum vec (call-primop node))
(add-datum vec (call-exits node))
(add-datum vec len)
(do ((i (- len 1) (- i 1)))
((< i 0))
(real-node->vector (vector-ref args i) vec))))
;----------------------------------------------------------------------------
; TURNING VECTORS BACK INTO NODES
;----------------------------------------------------------------------------
(define (vector->node vector)
(if (not (vector? vector))
(bug "VECTOR->NODE got funny value ~S~%" vector)
(let ((vec (make-vec vector -1 (make-vector (vector-length vector)))))
(real-vector->node vec))))
(define (vector->leaf-node vector)
(case (vector-ref vector 0)
((quote global)
(vector->node vector))
(else #f)))
; Pop the next thing off of the vector (which is really a (<vector> . <index>)
; pair).
(define (get-datum vec)
(let ((i (+ (vec-index vec) 1)))
(set-vec-index! vec i)
(vector-ref (vec-vector vec) i)))
; This prevents the (unecessary) resimplification of recreated nodes.
(define (real-vector->node vec)
(let ((node (totally-real-vector->node vec)))
(set-node-simplified?! node #t)
node))
; Dispatch on the next thing in VEC.
(define (totally-real-vector->node vec)
(let ((exp (get-datum vec)))
(cond ((integer? exp)
(make-reference-node (vector-ref (vec-locals vec) exp)))
(else
(case exp
((lambda)
(vector->lambda-node vec))
((quote)
(let* ((value (get-datum vec))
(rep (get-datum vec)))
(make-literal-node value rep)))
((global)
(make-reference-node (get-datum vec)))
((call)
(vector->call-node vec))
((import) ; global variable from a separate compilation
(make-reference-node (lookup-imported-variable (get-datum vec))))
(else
(no-op
(bug '"real-vector->node got an unknown code ~S" exp))))))))
(define (vector->lambda-node vec)
(let* ((name (get-datum vec))
(type (get-datum vec))
(protocol (get-datum vec))
(source (get-datum vec))
(count (get-datum vec))
(vars (do ((i 0 (+ i 1))
(v '() (cons (vector->variable vec) v)))
((>= i count) v)))
(node (make-lambda-node name type (reverse! vars))))
(set-lambda-protocol! node protocol)
(set-lambda-source! node source)
(attach-body node (vector->call-node vec))
(set-node-simplified?! (lambda-body node) #t)
node))
; Replace a variable name with a new variable.
(define (vector->variable vec)
(let ((name (get-datum vec)))
(if name
(let ((var (make-variable name (get-datum vec))))
(vector-set! (vec-locals vec) (+ -1 (vec-index vec)) var)
var)
#f)))
(define (vector->call-node vec)
(let* ((source (get-datum vec))
(primop (let ((p (get-datum vec)))
(if (primop? p)
p
(lookup-primop p))))
(exits (get-datum vec))
(count (get-datum vec))
(node (make-call-node primop count exits)))
(do ((i (- count 1) (- i 1)))
((< i 0))
(attach node i (real-vector->node vec)))
(set-call-source! node source)
node))

235
ps-compiler/package-defs.scm
View File

@ -1,235 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; The intermediate language (node tree)
; The structures VARIABLE and PRIMOP are contained in NODE. They are used
; in client language code where the NODE- names conflict.
(define-structures ((node node-interface)
(variable variable-interface)
(primop primop-interface))
(open scheme big-scheme comp-util arch parameters
defrecord)
(for-syntax (open scheme big-scheme let-nodes))
(begin
(define-syntax let-nodes
(lambda (form rename compare)
(expand-let-nodes form rename compare))))
(files (node node) ; variable and node data structures
(node primop) ; primop data structure
(node node-util) ; various small utilities
(node node-equal))) ; node equality
;(define node
; (let ()
; (define-structure let-nodes (export expand-let-nodes)
; (open scheme big-scheme arch)
; (files (node let-nodes)))
; (define-structures ((node node-interface)
; (variable variable-interface)
; (primop primop-interface))
; (open scheme big-scheme comp-util arch parameters)
; (for-syntax (open scheme big-scheme let-nodes))
; (begin
; (define-syntax let-nodes
; (lambda (form rename compare)
; (expand-let-nodes form rename compare))))
; (files (node node) ; variable and node data structures
; (node primop) ; primop data structure
; (node node-util) ; various small utilities
; (node node-equal) ; node equality
; (node leftovers))) ; more node utilities
; node))
; Pretty printer
(define-structure pp-cps (export pp-cps)
(open scheme big-scheme comp-util node structure-refs)
(access i/o) ; force-output
(files (node pp-cps)))
; Expander for LET-NODES, a macro for creating interconnected nodes.
(define-structure let-nodes (export expand-let-nodes)
(open scheme big-scheme arch)
(files (node let-nodes)))
; Compiler Parameters
; This allows client languages to supply parameters to the compiler
; without introducing circular module dependencies.
(define-structures ((parameters parameter-interface)
(set-parameters (export set-compiler-parameter!)))
(open scheme big-scheme)
(files param))
; An enumerated type defining the standard primops.
(define-structure arch (export (primop :syntax) primop-count)
(open scheme enumerated)
(files (node arch)))
; linearizing node trees for later reuse
(define-structure node-vector (export node->vector
vector->node
vector->leaf-node)
(open scheme big-scheme comp-util node parameters
defrecord)
(files (node vector)))
; Translating the input forms into simplified node trees
(define-structures ((front front-interface)
(front-debug front-debug-interface))
(open scheme big-scheme comp-util node simplify parameters jump
remove-cells flow-values)
(files (front top))) ; main entry points and debugging utilities
(define-structure cps-util (export cps-call cps-sequence)
(open scheme big-scheme comp-util node
define-record-types)
(files (front cps)))
; Converting tail-recursive calls to jumps
(define-structure jump (export integrate-jump-procs!
find-jump-procs
procs->jumps)
(open scheme big-scheme comp-util node parameters ssa
define-record-types)
(files (front jump)))
; Program simplification and partial evaluation
(define-structures ((simplify (export simplify-node))
(simplify-internal simplify-internal-interface))
(open scheme big-scheme comp-util node parameters node-vector)
(for-syntax (open scheme big-scheme simp-patterns))
(begin
(define-syntax pattern-simplifier
(lambda (form rename compare)
(make-pattern-simplifier (cdr form))))) ; from SIMP-PATTERNS
(files (simp simplify) ; main entry point and driver
(simp call))) ; simplifiers for some of the standard primops
; Simplifying calls to lambda nodes
(define-structure simplify-let (export simplify-let)
(open scheme big-scheme comp-util node parameters
simplify-join simplify-internal)
(files (simp let)))
; Substituting lambda nodes that are bound by calls to lambda nodes,
; trying to maximize the further simplification opportunites while
; minimizing code expansion.
(define-structure simplify-join (export substitute-join-arguments)
(open scheme big-scheme comp-util node)
(files (simp join)))
; The expander for PATTERN-SIMPLIFIER, a macro for writing algebraic
; transformations.
(define-structure simp-patterns (export make-pattern-simplifier)
(open scheme big-scheme defrecord)
(files (simp pattern)))
; Replacing cells with values passed as parameters, currently empty
; and unused (the code has not been made compatible with the current
; version of the compiler).
(define-structure remove-cells (export remove-cells-from-tree)
(open scheme big-scheme)
(begin
(define (remove-cells-from-tree . stuff)
(error "REMOVE-CELLS-FROM-TREE is undefined"))))
; Flow analysis, also currently empty and unused for the same reason.
(define-structure flow-values (export flow-values)
(open scheme big-scheme)
(begin
(define (flow-values . stuff)
(error "FLOW-VALUES is undefined"))))
; A random collection of utilities.
(define-structure comp-util utilities-interface
(open scheme big-scheme structure-refs expanding-vectors)
(for-syntax (open scheme big-scheme))
(access primitives features)
(files (util syntax) ; macro for defining subrecords
(util util))) ; random utilities
(define-structure expanding-vectors (export make-xvector
xvector-length
xvector-ref
xvector-set!
xvector-length
xvector->vector)
(open scheme define-record-types)
(files (util expand-vec)))
(define-interface transitive-interface
(export make-graph-from-predecessors
make-graph-from-successors
transitive-or! transitive-or-with-kill! transitive-or-with-pass!
transitive-and! transitive-and-with-kill! transitive-and-with-pass!))
(define-structure transitive transitive-interface
(open scheme big-scheme integer-sets defrecord)
(optimize auto-integrate)
(files (util transitive)))
(define-interface integer-set-interface
(export make-empty-integer-set
add-to-integer-set
integer-set-not
integer-set-ior
integer-set-and
integer-set-subtract
integer-set-equal?
map-over-integer-set))
(define-structure integer-sets integer-set-interface
(open scheme bitwise bigbit)
(optimize auto-integrate)
(files (util z-set)))
(define-structure strongly-connected (export strongly-connected-components)
(open scheme big-scheme defrecord)
(optimize auto-integrate)
(files (util strong)))
(define-structure dominators (export find-dominators!)
(open scheme big-scheme comp-util
define-record-types)
(optimize auto-integrate)
(files (util dominators)))
(define-structure ssa (export graph->ssa-graph! find-joins)
(open scheme big-scheme dominators
define-record-types)
(optimize auto-integrate)
(files (util ssa)))
; Vectors of bytes, a renaming of Scheme 48's code vectors.
(define-structure byte-vectors compiler-byte-vector-interface
(open scheme code-vectors bitwise signals)
(optimize auto-integrate)
(files (util byte-vector)))
; A version of READ that annotates pairs with source file, line, and
; column information.
(define-structure annotated-read annotated-read-interface
; this is correct for linking, but doesn't work when loading
;(open defrecord extended-ports primitives scheme assembler)
(open scheme big-scheme primitives fluids assembler)
(files (prescheme track-read)))

42
ps-compiler/param.scm
View File

@ -1,42 +0,0 @@
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Parameterizing the compiler.
(define lookup-primop 'unset-compiler-parameter)
(define lookup-imported-variable 'unset-compiler-parameter)
(define type/unknown 'unset-compiler-parameter)
(define type-eq? 'unset-compiler-parameter)
(define lambda-node-type 'unset-compiler-parameter)
(define true-value 'unset-compiler-parameter)
(define false-value 'unset-compiler-parameter)
(define determine-lambda-protocol 'unset-compiler-parameter)
(define determine-continuation-protocol 'unset-compiler-parameter)
(define (set-compiler-parameter! name value)
(case name
((lookup-primop)
(set! lookup-primop value))
((lookup-imported-variable)
(set! lookup-imported-variable value))
((type/unknown)
(set! type/unknown value))
((type-eq?)
(set! type-eq? value))
((lambda-node-type)
(set! lambda-node-type value))
((true-value)
(set! true-value value))
((false-value)
(set! false-value value))
((determine-lambda-protocol)
(set! determine-lambda-protocol value))
((determine-continuation-protocol)
(set! determine-continuation-protocol value))
(else
(error "unknown compiler parameter ~S ~S" name value))))

353
ps-compiler/prescheme/c-call.scm
View File

@ -1,353 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Generating C code for a call
(define (call->c node port indent)
(let loop ((node node))
(if (primop-call->c node port indent)
(loop (lambda-body (call-arg node 0))))))
(define (primop-call->c node port indent)
(let ((primop (call-primop node)))
(if (and (simple-c-primop? primop)
(= 0 (call-exits node)))
(generate-simple-assignment primop node port indent)
(primop-generate-c primop node port indent))
(and (= 1 (call-exits node))
(not (goto-call? node)))))
(define (c-value node port)
(cond ((string? node)
(display node port))
((not (node? node))
(display node port))
((reference-node? node)
(c-variable (reference-variable node) port))
((literal-node? node)
(c-literal-value (literal-value node) (literal-type node) port))
((call-node? node) ; must be simple
(let ((parens? (call-needs-parens? node)))
(if parens? (write-char #\( port))
(primop-generate-c (call-primop node) node port 0)
(if parens? (write-char #\) port))))
(else
(bug "odd node in C-VALUE ~S" node))))
(define (c-literal-value value type port)
(let ((value (cond ((integer? value) value)
((eq? value #f) 0)
((eq? value #t) 1)
((string? value) value)
((external-value? value) value)
((external-constant? value) value)
((char? value) (char->ascii value))
(else
(error "cannot translate literal to C ~A" value)))))
(cond ((integer? value)
(format port "~D" value))
((string? value)
(c-string-constant value port))
((external-value? value)
(display (external-value-string value) port))
((external-constant? value)
(display (external-constant-c-string value) port))
(else
(display value port)))))
(define (c-string-constant string port)
(write-char #\" port)
(do ((i 0 (+ i 1)))
((= i (string-length string)))
(let ((char (string-ref string i)))
(case char
((#\newline)
(write-char #\\ port)
(write-char #\n port))
((#\")
(write-char #\\ port)
(write-char #\" port))
((#\\)
(write-char #\\ port)
(write-char #\\ port))
(else
(write-char char port)))))
(write-char #\" port))
; (case (base-type-size (maybe-follow-uvar type))
; ((1)
; (let ((new-value (if (>= value 0)
; (bitwise-and value 255)
; (error "can't translate negative character constants to C ~S"
; value))))
; (format port "'\\~D~D~D'"
; (remainder (quotient new-value 64) 8)
; (remainder (quotient new-value 8) 8)
; (remainder new-value 8))))
; ((2)
; (format port "~D" value))
; ((4)
; (format port "~DL" value))
; (else
; (error "cannot translate literal type to C ~S" type)))
; Cut down on the number of unnecessary parentheses. We don't go so far as
; to pay attention to C's precedence rules.
(define (call-needs-parens? call)
(and (not (and (eq? 'contents (primop-id (call-primop call)))
(eq? 'global (literal-value (call-arg call loc/type)))))
(let ((parent (node-parent call)))
(and (node? parent)
(call-node? parent)
(not (eq? 'let
(primop-id (call-primop parent))))))))
; Each local variable has a unique integer used to disambiguate in the
; C code. Using our own, instead of what variables already have, keeps
; the numbers smaller and more readable.
(define *c-variable-id* '0)
(define (next-c-variable-id)
(let ((id *c-variable-id*))
(set! *c-variable-id* (+ *c-variable-id* 1))
id))
(define (c-variable-id var)
(if (integer? (variable-generate var))
(variable-generate var)
(let ((id (next-c-variable-id)))
(set! *local-vars* (cons var *local-vars*))
(set-variable-generate! var id)
id)))
(define (c-variable var port)
(really-c-variable var port #t))
(define (c-variable-no-shadowing var port)
(really-c-variable var port #f))
(define (really-c-variable var port shadow?)
(cond ((string? var)
(display var port))
((symbol? var)
(display var port))
((not (variable? var))
(bug "funny value for C-VARIABLE ~S" var))
((not (variable-binder var))
(cond ((and shadow?
(memq? 'shadowed (variable-flags var)))
(writec port '#\R))
((generated-top-variable? var)
(writec port '#\H)))
(write-c-identifier (variable-name var) port)
(if (generated-top-variable? var)
(display (c-variable-id var) port)))
(else
; (if (= (c-variable-id var) 944)
; (breakpoint "writing 944"))
(write-c-identifier (variable-name var) port)
(write-char '#\_ port)
(display (c-variable-id var) port)
(write-char '#\X port))))
;==============================================================================;
; Scheme identifiers contain many characters that are not legal in C
; identifiers. Luckily C is case-sensitive and Scheme is not.
(define char-translations
(let* ((count number-of-char-codes)
(string (make-string count)))
(do ((i '0 (+ i '1)))
((>= i count))
(let ((char (ascii->char i)))
(string-set! string i
(cond ((and (char-alphabetic? char)
(char=? char
(string-ref (symbol->string
(string->symbol
(list->string
(list char))))
0)))
(char-downcase char))
((char-numeric? char)
char)
(else
(ascii->char 0))))))
(string-set! string (char->ascii '#\+) '#\A)
(string-set! string (char->ascii '#\!) '#\B)
(string-set! string (char->ascii '#\:) '#\C)
(string-set! string (char->ascii '#\.) '#\D)
(string-set! string (char->ascii '#\=) '#\E)
(string-set! string (char->ascii '#\>) '#\G)
; used for flattened closures H
; precedes C keywords K
(string-set! string (char->ascii '#\<) '#\L)
(string-set! string (char->ascii '#\?) '#\P)
(string-set! string (char->ascii '#\%) '#\Q)
(string-set! string (char->ascii '#\*) '#\S)
; used for tail-recursive procedures T
(string-set! string (char->ascii '#\/) '#\U)
(string-set! string (char->ascii '#\#) '#\W)
; follows lexical identifiers X
; used by the multi-procedure block code Z
(string-set! string (char->ascii '#\-) '#\_)
string))
; This needs to check for C keywords (just precede with K)
(define (write-c-identifier symbol port)
(if (table-ref c-keywords symbol)
(writec port '#\K))
(let ((string (symbol->string symbol)))
(do ((i 0 (+ i 1)))
((>= i (string-length string)))
(let* ((char (string-ref string i))
(out (string-ref char-translations (char->ascii char))))
(if (= 0 (char->ascii out))
(bug "cannot translate ~S from ~A into C" char string)
(writec port out))))
(values)))
(define (c-ify symbol)
(call-with-string-output-port
(lambda (port)
(write-c-identifier symbol port))))
(define c-keywords (make-table))
(for-each (lambda (k)
(table-set! c-keywords k #t))
'(
auto double int struct
break else long switch
case enum register typedef
char extern return union
const float short unsigned
continue for signed void
default goto sizeof volatile
do if static while
))
;==============================================================================;
(define (simple-c-primop op call port)
(case (call-arg-count call)
((1)
(generate-simple-c-monop-call op (call-arg call 0) port))
((2)
(destructure ((#(arg1 arg2) (call-args call)))
(generate-simple-c-binop-call op arg1 arg2 port)))
(else
(bug "funny call to SIMPLE-C-PRIMOP ~S" call))))
(define (generate-simple-c-binop-call op arg1 arg2 port)
(c-value arg1 port)
(writec port '#\space)
(display op port)
(writec port '#\space)
(c-value arg2 port)
(values))
(define (generate-simple-c-monop-call op arg1 port)
(display op port)
(writec port '#\space)
(c-value arg1 port)
(values))
(define (generate-simple-assignment primop call port indent)
(let ((var (car (lambda-variables (call-arg call 0)))))
(c-assign-to-variable var port indent)
(primop-generate-c primop call port #f)
(writec port '#\;)
(values)))
(define (c-assignment var value port indent)
(c-assign-to-variable var port indent)
(c-value value port)
(writec port '#\;))
(define (c-assign-to-variable var port indent)
(indent-to port indent)
(cond ((or (not (variable? var))
(and (or (used? var)
(global-variable? var))
(not (eq? type/unit (final-variable-type var)))))
(c-variable var port)
(display " = " port))))
;==============================================================================;
(define (known-variable-reference node)
(cond ((reference-node? node)
(let ((var (reference-variable node)))
(if (global-variable? var) var #f)))
(else #f)))
(define (write-value-list args start port)
(writec port '#\()
(really-write-value-list args start '() port)
(writec port '#\)))
(define (write-value-list-with-extras args start extras port)
(writec port '#\()
(really-write-value-list args start extras port)
(writec port '#\)))
(define (really-write-value-list args start extras port)
(let ((len (vector-length args)))
(cond ((> len start)
(c-value (vector-ref args start) port)
(do ((i (+ start '1) (+ i '1)))
((>= i len) (values))
(writec port '#\,)
(writec port '#\space)
(c-value (vector-ref args i) port))
(write-comma-value-list extras port))
((not (null? extras))
(c-value (car extras) port)
(write-comma-value-list (cdr extras) port)))))
(define (write-comma-value-list args port)
(for-each (lambda (arg)
(writec port '#\,)
(writec port '#\space)
(c-value arg port))
args))
(define (write-value+result-var-list args start vars port)
(writec port '#\()
(really-write-value-list args start '() port)
(cond ((not (null? vars))
(if (> (vector-length args) start)
(display ", " port))
(writec port #\&)
(c-variable (car vars) port)
(for-each (lambda (var)
(display ", &" port)
(c-variable var port))
(cdr vars))))
(writec port #\)))
(define (c-system-call proc args port)
(display proc port)
(writec port '#\()
(if (not (null? args))
(let loop ((args args))
(c-value (car args) port)
(cond ((not (null? (cdr args)))
(writec port '#\,)
(writec port '#\space)
(loop (cdr args))))))
(writec port '#\))
(values))
(define (indent-to port indent)
(if (> (current-column port) indent)
(newline port))
(do ((c (current-column port) (+ c 1)))
((>= c indent))
(write-char #\space port)))

385
ps-compiler/prescheme/c-decl.scm
View File

@ -1,385 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; C variable declarations.
;
; (write-function-prototypes forms port)
;
; (write-variable-declarations vars port indent)
; Writing declarations.
(define (write-function-prototypes forms port)
(for-each (lambda (f)
(if (eq? (form-type f) 'lambda)
(if (form-tail-called? f)
(write-function-tail-prototype (form-c-name f)
(form-exported? f)
port)
(write-function-prototype (form-var f)
(form-c-name f)
(form-exported? f)
port))))
forms))
(define (write-function-tail-prototype name exported? port)
(if (not exported?)
(display "static " port))
(display "long T" port)
(display name port)
(display "(void);" port)
(newline port))
(define (write-function-prototype var name exported? port)
(if (not exported?)
(display "static " port))
(receive (result args)
(parse-arrow-type (final-variable-type var))
(display-c-type result
(lambda (port)
(display name port))
port)
(write-char #\( port)
(if (null? args)
(display "void" port)
(begin
(display-c-type (car args) #f port)
(let loop ((args (cdr args)))
(if (not (null? args))
(begin
(display ", " port)
(display-c-type (car args) #f port)
(loop (cdr args)))))))
(display ");" port)
(newline port)))
; Write declarations for global variables.
(define (write-global-variable-declarations forms port)
(for-each (lambda (form)
(if (memq (form-type form)
'(stob initialize alias))
(let* ((var (form-var form))
(type (final-variable-type var)))
(if (not (or (eq? type type/unit)
(eq? type type/null)))
(really-write-variable-declaration
var type (form-exported? form) port 0)))))
forms))
; Write general variable declarations.
(define (write-variable-declarations vars port indent)
(for-each (lambda (var)
(let ((type (final-variable-type var)))
(if (not (or (eq? type type/unit)
(eq? type type/null)))
(really-write-variable-declaration var type #t port indent))))
vars))
(define (really-write-variable-declaration var type exported? port indent)
(indent-to port indent)
(if (not exported?)
(display "static " port))
(display-c-type type
(lambda (port)
(c-variable-no-shadowing var port))
port)
(writec port #\;))
;----------------------------------------------------------------
; Writing C types
(define (display-c-type type name port)
(display-c-base-type (type->c-base-type type) port)
(if name (display " " port))
(display-c-type-modifiers type name port))
(define (write-c-coercion type out)
(write-char #\( out)
(display-c-type type #f out)
(write-char #\) out))
; Searches through the type modifiers until the base type is found.
; Unspecified result types are assumed to be `void'.
(define (type->c-base-type type)
(let ((type (maybe-follow-uvar type)))
(cond ((or (base-type? type)
(record-type? type))
type)
((pointer-type? type)
(type->c-base-type (pointer-type-to type)))
((arrow-type? type)
(let ((res (arrow-type-result type)))
(cond ((and (uvar? res)
(not (uvar-binding res)))
type/unit)
((not (tuple-type? res))
(type->c-base-type res))
((null? (tuple-type-types res))
type/unit)
(else
(type->c-base-type (car (tuple-type-types res)))))))
(else
(bug "don't know how to write ~S as a C type" type)))))
; Table of C names for base types.
(define c-decl-table (make-integer-table))
(define (add-c-type-declaration! type decl)
(table-set! c-decl-table (base-type-uid type) decl))
(for-each (lambda (p)
(let ((type (lookup-type (car p))))
(add-c-type-declaration! type (cadr p))))
'((boolean "char")
(char "char")
(integer "long")
(address "char *")
(input-port "FILE *")
(output-port "FILE *")
(unit "void")
(null "void")))
(define (display-c-base-type type port)
(cond ((record-type? type)
(display "struct " port)
(write-c-identifier (record-type-name type) port))
(else
(display (or (table-ref c-decl-table (base-type-uid type))
(bug "no C declaration for ~S" type))
port))))
; Writes out the modifiers of TYPE with NAME used when the base type is reached.
(define (display-c-type-modifiers type name port)
(let label ((type type) (name name))
(let ((type (maybe-follow-uvar type)))
(cond ((or (base-type? type)
(record-type? type))
(if name (name port)))
((pointer-type? type)
(label (pointer-type-to type)
(lambda (port)
(format port "*")
(if name (name port)))))
((arrow-type? type)
(format port "(*")
(receive (return-type args)
(parse-arrow-type type)
(label return-type name)
(format port ")(")
(cond ((null? args)
(display "void" port))
(else
(display-c-type (car args) #f port)
(do ((args (cdr args) (cdr args)))
((null? args))
(display ", " port)
(display-c-type (car args) #f port))))
(format port ")")))
(else
(bug "don't know how to write ~S as a C type" type))))))
(define (parse-arrow-type type)
(receive (first rest)
(parse-return-type (arrow-type-result type))
(values first
(append (arrow-type-args type)
(map make-pointer-type rest)))))
(define (parse-return-type type)
(cond ((not (tuple-type? type))
(values (if (and (uvar? type)
(not (uvar-binding type)))
type/unit
type)
'()))
((null? (tuple-type-types type))
(values type/unit '()))
(else
(values (car (tuple-type-types type))
(cdr (tuple-type-types type))))))
;------------------------------------------------------------
; Collecting local variables. Each is added to this list when it is first
; used.
(define *local-vars* '())
(define (declare-local-variables port)
(write-variable-declarations *local-vars* port 2))
; Some primops must be given continuations so that calls to them will
; be translated into separate C statements and so expand into arbitrarily
; complex chunks of C if necessary.
(define (fixup-nasty-c-primops! call)
(let ((top call))
(let label ((call call))
(cond ((call-node? call)
(if (and (= 0 (call-exits call))
(nasty-c-primop-call? call))
(set! top (expand-nasty-c-primop! call top)))
(walk-vector label (call-args call)))))
(do ((i 0 (+ i 1)))
((= i (call-arg-count top)))
(let ((arg (call-arg top i)))
(if (lambda-node? arg)
(fixup-nasty-c-primops! (lambda-body arg)))))))
(define (nasty-c-primop-call? call)
(case (primop-id (call-primop call))
((lshl ashl ashr) ; C does poorly when shifting by large amounts
(not (literal-node? (call-arg call 1))))
(else #f)))
; Give CALL a continuation and move it above TOP, replacing CALL
; with the continuation's variable.
;
; top = (p1 ... (p2 a1 ...) ...)
; =>
; (p2 (lambda (v) (p1 ... v ...)) a1 ...)
(define (expand-nasty-c-primop! call top)
(let* ((var (make-variable 'x (node-type call)))
(cont (make-lambda-node 'c 'cont (list var))))
(move call
(lambda (call)
(make-reference-node var)))
(insert-body call
cont
(node-parent top))
(set-call-exits! call 1)
(insert-call-arg call 0 cont)
call))
;------------------------------------------------------------
; Declare the variables used to pass arguments to procedures.
; This is done in each procedure so that the C compiler doesn't have to contend
; with the possibility of globally visible side-effects.
(define (write-arg-variable-declarations lambdas merged port)
(let ((lambdas (filter (lambda (l)
(eq? 'jump (lambda-type l)))
lambdas))
(merged (map form-value merged)))
(really-write-arg-variable-declarations lambdas "arg" port 2)
(really-write-arg-variable-declarations merged "merged_arg" port 2)))
(define (write-global-arg-variable-declarations forms port)
(let ((lambdas (filter-map (lambda (f)
(if (and (form-var f)
(memq? 'tail-called
(variable-flags (form-var f))))
(form-value f)
#f))
forms)))
(really-write-arg-variable-declarations lambdas "goto_arg" port 0)))
(define (really-write-arg-variable-declarations lambdas name port indent)
(for-each (lambda (data)
(destructure (((uid type . indicies) data))
(if (not (eq? type type/unit))
(for-each (lambda (i)
(indent-to port indent)
(declare-arg-variable type uid i name port))
indicies))))
(get-variable-decl-data lambdas)))
(define (get-variable-decl-data lambdas)
(let ((data '()))
(for-each (lambda (l)
(do ((vars (if (eq? 'jump (lambda-type l))
(lambda-variables l)
(cdr (lambda-variables l)))
(cdr vars))
(i 0 (+ i 1)))
((null? vars))
(let* ((type (final-variable-type (car vars)))
(uid (type->uid type))
(datum (assq uid data)))
(cond ((not datum)
(set! data (cons (list uid type i) data)))
((not (memq i (cddr datum)))
(set-cdr! (cdr datum) (cons i (cddr datum))))))))
lambdas)
data))
(define (declare-arg-variable type uid i name port)
(display-c-type type
(lambda (port)
(format port "~A~DK~D" name uid i))
port)
(format port ";~%"))
;------------------------------------------------------------
(define (write-argument-initializers arg-vars port indent)
(really-write-argument-initializers arg-vars "arg" #f port indent))
(define (write-merged-argument-initializers arg-vars port indent)
(really-write-argument-initializers arg-vars "merged_arg" #f port indent))
(define (write-global-argument-initializers arg-vars port indent)
(really-write-argument-initializers arg-vars "goto_arg" #t port indent))
(define (really-write-argument-initializers arg-vars name type? port indent)
(do ((i 0 (+ i 1))
(vars arg-vars (cdr vars)))
((null? vars) (values))
(if (used? (car vars))
(let* ((var (car vars))
(type (final-variable-type var)))
(cond ((not (eq? type/unit type))
(indent-to port indent)
(if type?
(display-c-type type
(lambda (port) (c-variable var port))
port)
(c-variable var port))
(display " = " port)
(display (c-argument-var name type i port) port)
(write-char '#\; port)))))))
(define (c-argument-var name type i port)
(format #f "~A~DK~D" name (type->uid type) i))
(define *type-uids* '())
(define *next-type-uid* 0)
(define (type->uid type)
(cond ((any (lambda (p)
(type-eq? type (car p)))
*type-uids*)
=> cdr)
(else
(let ((id *next-type-uid*))
(set! *next-type-uid* (+ id 1))
(set! *type-uids* (cons (cons type id) *type-uids*))
id))))
;----------------------------------------------------------------
; Random utility here for historical reasons.
(define (goto-call? call)
(and (calls-this-primop? call 'unknown-tail-call)
(goto-protocol? (literal-value (call-arg call 2)))))
;----------------------------------------------------------------
; random type stuff
(define (reference-type node)
(finalize-variable-type (reference-variable node)))
(define (finalize-variable-type var)
(let* ((type (finalize-type (variable-type var)))
(type (if (uvar? type)
type/null
type)))
(set-variable-type! var type)
type))
(define final-variable-type finalize-variable-type)

131
ps-compiler/prescheme/c-stuff
View File

@ -1,131 +0,0 @@
Put the case defn and the system-status enumeration in a file and load
it into the base package.
Have system status be a enumeration macro that doesn't give numbers
but instead calls to (named-c-constant "FOO") with the obvious translation.
Need a normal enumerated definition for running with Scheme.
Of course, if there is no overlap we can just use negative numbers for
the error numbers visible in Pre-Scheme.
PS_READ_CHAR(port_10X, Kchar_27X, eofP_15X, status_16X)
#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS)
{
FILE * TTport = PORT;
if (EOF == (RESULT = getc(TTport)))
RESULT = ps_read_char(TTport, &EOFP, &STATUS);
else {
EOFP = 0;
STATUS = 0; }
}
#define PS_GETC(PORT,RESULT) /* RESULT = getc(PORT); */ \
{ \
FILE * TTport = PORT; \
int errorp; \
while (EOF == (RESULT = getc(TTport)) \
&& (errorp = ferror(TTport), \
clearerr(TTport), \
(errorp && errno == EINTR))) \
; \
}
char
ps_read_char( FILE *filep, int *eofp )
{
int value;
while (TRUE) {
value = getc(filep);
if (EOF != value) {
*eofp = FALSE;
return value; }
if (ferror(filep)) {
clearerr(filep);
if (errno != EINTR) {
ps_status_errno = errno;
*eofp = FALSE;
return 0; } }
else {
*eofp = TRUE;
return 0; }}
}
/* Identical to ps_read_char except that we give the character back. */
char
ps_peek_char( FILE *filep )
{
int value;
while (TRUE) {
value = getc(filep);
if (EOF != value) {
ungetc(value);
return value;
}
if (ferror(filep)) {
clearerr(filep);
if (errno != EINTR) {
ps_status_errno = errno;
return 0;
}
}
else {
ps_status_errno = EOF_ERRNO;
return 0;
}
}
}
void
ps_write_char( char c; FILE *filep )
{
while (TRUE) {
if (EOF != putc(c, filep);
return;
if (ferror(filep)) {
clearerr(filep);
if (errno != EINTR) {
ps_status_errno = errno;
return;
}
}
else {
ps_status_errno = EOF_ERRNO;
return;
}
}
}
; no status
current-input-port current-output-port current-error-port
; -> port status
open-input-file open-output-file
; -> status
close-output-port close-input-port
; -> value eof? status
read-char peek-char read-integer
; -> status
write-char newline write-string write-integer force-output
Error status:
no-errors 0
parse-error EINVAL invalid argument
pending-i/o EAGAIN? resource temporarily unavailable
file-not-found ENOENT no such
EISDIR is a directory
out-of-memory ENOMEM not enough space
out-of-channels EMFILE too many open files
channel-closed EBADF bad file descriptor
no-such-channel EBADF bad file descriptor

467
ps-compiler/prescheme/c.scm
View File

@ -1,467 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Translating the node tree into C
(define (write-c-file init-name file header forms)
(set! *c-variable-id* 0)
(set! *type-uids* '())
(set! *next-type-uid* 0)
(let* ((real-out (open-output-file file))
(out (make-tracking-output-port real-out)))
(merge-forms forms)
(check-hoisting forms)
(format #t "Translating~%")
(write-c-header header out)
(write-function-prototypes forms out)
(write-global-arg-variable-declarations forms out)
(write-global-variable-declarations forms out)
(newline out)
(for-each (lambda (f)
(case (form-type f)
((lambda)
(compile-proc-to-c f out))
((alias constant integrate merged stob initialize unused)
(values))
(else
(bug "unknown type of form ~S" f))))
forms)
(write-c-main init-name out forms)
(newline out)
(set! *type-uids* '())
(close-output-port out)
(close-output-port real-out)))
(define (write-c-main init-name out forms)
(set! *doing-tail-called-procedure?* #f)
(set! *current-merged-procedure* #f)
(cond ((any? (lambda (f)
(or (eq? (form-type f) 'initialize)
(eq? (form-type f) 'stob)
(eq? (form-type f) 'alias)))
forms)
(write-c-main-header (if init-name init-name 'main) out)
(for-each (lambda (f)
(case (form-type f)
((initialize alias)
(write-initialize (form-var f) (form-value f) out))
((stob)
(write-stob (form-var f)
(form-value-type f)
(lambda-body (form-value f))
out))))
forms)
(write-c-main-end out))))
(define (write-c-header header out)
(format out "#include <stdio.h>~%")
(format out "#include \"prescheme.h\"~%")
(for-each (lambda (s)
(display s out)
(newline out))
header)
(for-each (lambda (rtype)
(declare-record-type rtype out))
(all-record-types))
(newline out)
(values))
(define (declare-record-type rtype out)
(format out "~%struct ")
(write-c-identifier (record-type-name rtype) out)
(format out " {~%")
(for-each (lambda (field)
(format out " ")
(display-c-type (record-field-type field)
(lambda (port)
(write-c-identifier (record-field-name field)
out))
out)
(format out ";~%"))
(record-type-fields rtype))
(format out "};"))
; Even when finished we need to keep the lambda around for help with
; calls to it.
(define (compile-proc-to-c form out)
(format #t " ~A~%" (form-c-name form))
(let ((name (form-c-name form)))
(proc->c name form (form-shadowed form) out #f)
(for-each make-form-unused! (form-merged form))
(erase (detach-body (lambda-body (form-value form))))
(suspend-form-use! form)))
(define (form-c-name form)
(let* ((var (form-var form))
(name (c-ify (variable-name var))))
(if (generated-top-variable? var)
(string-append "H" name (number->string (c-variable-id var)))
name)))
(define (no-value-node? node)
(or (undefined-value-node? node)
(and (reference-node? node)
(let ((type (final-variable-type (reference-variable node))))
(or (eq? type type/unit)
(eq? type type/null))))))
;------------------------------------------------------------
; Initialization procedure at the end of the file (often called `main').
; Header for initialization code
(define (write-c-main-header initname out)
(format out "void~%")
(write-c-identifier initname out)
(format out "(void)~%{"))
; Write the end of the initialization code
(define (write-c-main-end out)
(format out "~&}"))
(define (write-initialize var value out)
(let ((wants (maybe-follow-uvar (variable-type var))))
(receive (value has)
(cond ((variable? value)
(values value (final-variable-type value)))
((literal-node? value)
(values (literal-value value) (literal-type value)))
((reference-node? value)
(let ((var (reference-variable value)))
(values var (final-variable-type var))))
(else
(error "unknown kind of initial value ~S" value)))
(cond ((not (unspecific? value))
(c-assign-to-variable var out 0)
(if (not (type-eq? wants has))
(write-c-coercion wants out))
(cond ((input-port? value)
(display "0" out))
((output-port? value)
(display "1" out))
((variable? value)
(c-variable value out))
(else
(c-literal-value value has out)))
(writec out '#\;))))))
(define (write-stob var type call out)
(let ((value (literal-value (call-arg call 0)))
(wants (final-variable-type var)))
(c-assign-to-variable var out 0)
(cond ((vector? value)
(if (not (type-eq? type wants))
(write-c-coercion wants out))
(format out "malloc(~D * sizeof(" (vector-length value))
(display-c-type (pointer-type-to type) #f out)
(format out "));")
(do ((i 0 (+ i 1)))
((>= i (vector-length value)))
(let* ((elt (call-arg call (+ i 1)))
(has (finalize-type
(if (reference-node? elt)
(variable-type (reference-variable elt))
(literal-value-type (literal-value elt))))))
(newline out)
(c-variable var out)
(format out "[~D] = " i)
(if (not (type-eq? (pointer-type-to type) has))
(write-c-coercion (pointer-type-to type) out))
(c-value elt out)
(write-char #\; out))))
(else
(error "don't know how to generate stob value ~S" value)))))
;------------------------------------------------------------
; Writing out a procedure.
(define (proc->c name form rename-vars port maybe-merged-count)
(let ((top (form-value form))
(merged (form-merged form))
(tail? (form-tail-called? form))
(exported? (form-exported? form))
(lambda-kids lambda-block)) ; filled in by the hoist code
(let ((lambdas (filter (lambda (l)
(not (proc-lambda? l)))
(lambda-kids top))))
(if maybe-merged-count
(merged-proc->c name top lambdas merged maybe-merged-count port tail?)
(real-proc->c name (form-var form) top lambdas
merged rename-vars port tail? exported?))
(values))))
(define (write-merged-form form port)
(format #t " ~A~%" (form-c-name form))
(proc->c (form-c-name form)
form
'()
port
(length (variable-refs (form-var form)))))
;------------------------------------------------------------
; 1. write the header
; 2. declare the local variables
; 3. write out the body
; 4. write out all of the label lambdas
(define (real-proc->c id var top lambdas merged rename-vars port tail? exported?)
(let ((vars (cdr (lambda-variables top)))
(return-type (final-variable-type (car (lambda-variables top))))
(all-lambdas (append lambdas (gather-merged-lambdas merged)))
(merged-procs (gather-merged-procs merged)))
(set! *doing-tail-called-procedure?* tail?)
(set! *current-merged-procedure* #f)
(receive (first rest)
(parse-return-type return-type)
(set! *extra-tail-call-args*
(do ((i (length rest) (- i 1))
(args '() (cons (format #f "TT~D" (- i 1)) args)))
((= i 0)
args))))
(set! *jumps-to-do* '())
(write-procedure-header id return-type vars port tail? exported?)
(write-char '#\{ port)
(newline port)
(for-each (lambda (v)
(set-variable-flags! v (cons 'shadowed (variable-flags v))))
rename-vars)
(write-arg-variable-declarations all-lambdas merged port)
(write-rename-variable-declarations rename-vars port)
(write-merged-declarations merged port)
(fixup-nasty-c-primops! (lambda-body top))
(for-each (lambda (form)
(write-merged-decls form port))
merged)
(clear-lambda-generated?-flags lambdas)
(set! *local-vars* '())
(let ((body (call-with-string-output-port
(lambda (temp-port)
(let ((temp-port (make-tracking-output-port temp-port)))
(write-c-block (lambda-body top) temp-port 2)
(write-jump-lambdas temp-port 0)
(for-each (lambda (f)
(write-merged-form f temp-port))
(reverse merged)) ; makes for more readable output
(newline temp-port)
(force-output temp-port))))))
(declare-local-variables port)
(if tail?
(write-global-argument-initializers (cdr (lambda-variables top))
port 2))
(format port "~% {")
(display body port)
(write-char '#\} port))
(for-each (lambda (v)
(set-variable-flags! v (delq! 'shadowed (variable-flags v))))
rename-vars)
(values)))
; These global variables should be replaced with fluids.
(define *doing-tail-called-procedure?* #f)
(define *current-merged-procedure* #f)
(define *extra-tail-call-args* '())
(define (gather-merged-lambdas merged)
(let loop ((merged merged) (lambdas '()))
(if (null? merged)
lambdas
(loop (append (form-merged (car merged)) (cdr merged))
(append (form-lambdas (car merged)) lambdas)))))
(define (gather-merged-procs merged)
(let loop ((merged merged) (procs '()))
(if (null? merged)
procs
(loop (append (form-merged (car merged)) (cdr merged))
(cons (form-value (car merged)) procs)))))
(define (write-merged-decls form port)
(let ((top (form-value form))
(merged (form-merged form)))
(let ((vars (filter (lambda (var)
(and (used? var)
(not (eq? type/unit (final-variable-type var)))))
(cdr (lambda-variables top)))))
(write-variable-declarations vars port 2))
(write-merged-declarations merged port)))
(define (merged-proc->c name top lambdas merged return-count port tail?)
(let ((vars (cdr (lambda-variables top)))
(body (lambda-body top)))
(set! *doing-tail-called-procedure?* tail?)
(set! *current-merged-procedure* name)
(write-merged-header name top port)
(write-char '#\{ port)
(clear-lambda-generated?-flags lambdas)
(write-c-block body port 2)
(write-jump-lambdas port 0)
(if (not tail?)
(write-merged-return name return-count port))
(for-each (lambda (f)
(write-merged-form f port))
(reverse merged)) ; makes for more readable output
(write-char '#\} port)
(newline port)
(values)))
(define (write-merged-header name top port)
(format port "~% ~A: {~%" name)
(if (not (null? (cdr (lambda-variables top))))
(write-merged-argument-initializers (cdr (lambda-variables top)) port 2)))
; We use `default:' for the last tag so that the C compiler will
; know that the code following the switch is unreachable (to avoid
; a spurious warning if this is the end of the procedure).
(define (write-merged-return name return-count port)
(format port "~% ~A_return:~% switch (~A_return_tag) {~%" name name)
(do ((i 0 (+ i 1)))
((>= i (- return-count 1)))
(format port " case ~S: goto ~A_return_~S;~%" i name i))
(format port " default: goto ~A_return_~S;~%" name (- return-count 1))
(format port " }"))
(define (write-merged-declarations forms port)
(for-each (lambda (f)
(if (not (form-tail-called? f))
(write-merged-declaration f port)))
forms))
(define (write-merged-declaration form port)
(let ((name (form-c-name form))
(types (lambda-return-types (form-value form))))
(format port "~% int ~A_return_tag;" name)
(do ((i 0 (+ i 1))
(types types (cdr types)))
((null? types))
(let ((type (car types)))
(cond ((not (or (eq? type type/unit)
(eq? type type/null)))
(format port "~% ")
(display-c-type type
(lambda (port)
(format port "~A~D_return_value" name i))
port)
(writec port #\;)))))))
(define (lambda-return-types node)
(let ((type (final-variable-type (car (lambda-variables node)))))
(if (tuple-type? type)
(tuple-type-types type)
(list type))))
(define (write-procedure-header id return-type vars port tail? exported?)
(newline port)
(if (not exported?)
(display "static " port))
(receive (first rest)
(parse-return-type return-type)
(display-c-type (if tail? type/integer first)
(lambda (port)
(if tail? (write-char #\T port))
(display id port))
port)
(write-char '#\( port)
(if (not tail?)
(let ((args (append vars
(do ((i 0 (+ i 1))
(rest rest (cdr rest))
(res '() (cons (cons i (car rest)) res)))
((null? rest)
(reverse res))))))
(if (null? args)
(display "void" port)
(write-variables args port))))
(write-char '#\) port)
(newline port)))
; Write the names of VARS out to the port. VARS may contain pairs of the
; form (<integer> . <type>) as well as variables.
(define (write-variables vars port)
(let ((do-one (lambda (var)
(display-c-type (if (pair? var)
(make-pointer-type (cdr var))
(final-variable-type var))
(lambda (port)
(if (pair? var)
(format port "TT~D" (car var))
(c-variable var port)))
port))))
(cond ((null? vars)
(values))
((null? (cdr vars))
(do-one (car vars)))
(else
(do-one (car vars))
(do ((vars (cdr vars) (cdr vars)))
((null? vars)
(values))
(write-char '#\, port)
(write-char '#\space port)
(do-one (car vars)))))))
(define (write-rename-variable-declarations vars port)
(for-each (lambda (var)
(indent-to port 2)
(display-c-type (final-variable-type var)
(lambda (port)
(writec port #\R)
(write-c-identifier (variable-name var) port))
port)
(display " = " port)
(write-c-identifier (variable-name var) port)
(format port ";~%"))
vars))
(define (write-c-block body port indent)
(write-c-block-with-args body '() port indent))
(define (write-c-block-with-args body arg-vars port indent)
(if (not (null? arg-vars))
(write-argument-initializers arg-vars port indent))
(call->c body port indent)
(write-char '#\} port))
; Jump lambdas. These are generated more-or-less in the order they are
; referenced.
(define (clear-lambda-generated?-flags lambdas)
(for-each (lambda (l)
(set-lambda-block! l #f))
lambdas))
(define *jumps-to-do* '())
(define (note-jump-generated! proc)
(if (not (lambda-block proc))
(begin
(set! *jumps-to-do* (cons proc *jumps-to-do*))
(set-lambda-block! proc #t))))
(define (write-jump-lambdas port indent)
(let loop ()
(let ((jumps (reverse *jumps-to-do*)))
(set! *jumps-to-do* '())
(for-each (lambda (jump)
(jump-lambda->c jump port indent))
jumps)
(if (not (null? *jumps-to-do*))
(loop)))))
(define (jump-lambda->c node port indent)
(newline port)
(indent-to port indent)
(display " L" port)
(display (lambda-id node) port)
(display ": {" port)
(newline port)
(write-c-block-with-args (lambda-body node)
(lambda-variables node)
port
(+ '2 indent)))

224
ps-compiler/prescheme/display.scm
View File

@ -1,224 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Data must be done last as it may contain references to the other stuff.
(define (display-forms-as-scheme forms out)
(receive (data other)
(partition-list (lambda (f)
(and (node? (form-value f))
(literal-node? (form-value f))))
forms)
(for-each (lambda (f)
(display-form-as-scheme f (schemify (form-value f)) out))
other)
(for-each (lambda (f)
(display-data-form-as-scheme f out))
data)))
(define form-value (structure-ref forms form-value))
(define form-var (structure-ref forms form-var))
(define literal-node? (node-predicate 'literal #f))
(define (display-form-as-scheme f value out)
(cond ((unspecific? value)
(p `(define ,(get-form-name f)) out)
(newline out))
((or (external-value? value)
(memq 'closed-compiled-primitive (variable-flags (form-var f))))
(values))
(else
(p `(define ,(get-form-name f) ,value)
out)
(newline out))))
(define (display-data-form-as-scheme f out)
(let* ((value (clean-literal (node-form (form-value f))))
(value (if (and (quoted? value)
(not (or (list? (cadr value))
(vector? (cadr value)))))
(cadr value)
value)))
(display-form-as-scheme f value out)))
(define (get-form-name form)
(name->symbol (get-variable-name (form-var form))))
(define (schemify node)
(if (node? node)
((operator-table-ref schemifiers (node-operator-id node))
node)
(schemify-sexp node)))
(define unspecific?
(let ((x (if #f #t)))
(lambda (y)
(eq? x y))))
(define schemifiers
(make-operator-table (lambda (node)
(let ((form (node-form node)))
(if (list? form)
(map schemify form)
form)))))
(define (define-schemifier name type proc)
(operator-define! schemifiers name type proc))
(define-schemifier 'name 'leaf
(lambda (node)
(cond ((node-ref node 'binding)
=> (lambda (binding)
(let ((var (binding-place binding)))
(if (variable? var)
(get-variable-name var)
(desyntaxify (node-form node))))))
(else
(name->symbol (node-form node))))))
; Rename things that have differ in Scheme and Pre-Scheme
(define aliases
(map (lambda (s)
(cons s (string->symbol (string-append "ps-" (symbol->string s)))))
'(read-char peek-char write-char newline
open-input-file open-output-file
close-input-port close-output-port)))
(define (get-variable-name var)
(cond ((and (generated-top-variable? var)
(not (memq 'closed-compiled-primitive (variable-flags var))))
(string->symbol (string-append (symbol->string
(name->symbol (variable-name var)))
"."
(number->string (variable-id var)))))
((assq (variable-name var) aliases)
=> cdr)
(else
(variable-name var))))
(define (name->symbol name)
(if (symbol? name)
name
(string->symbol (string-append (symbol->string (generated-symbol name))
"."
(number->string (generated-uid name))))))
(define-schemifier 'quote #f
(lambda (node)
(list 'quote (cadr (node-form node)))))
(define-schemifier 'literal #f
(lambda (node)
(let ((form (node-form node)))
(cond ((primop? form)
(primop-id form))
((external-value? form)
(let ((string (external-value-string form)))
(if (string=? string "(long(*)())")
'integer->procedure
(string->symbol (external-value-string form)))))
((external-constant? form)
`(enum ,(external-constant-enum-name form)
,(external-constant-name form)))
(else
(schemify-sexp form))))))
(define-schemifier 'unspecific #f
(lambda (node)
''unspecific))
; Used for primitives in non-call position. The CDR of the form is a
; variable that will be bound to the primitive's closed-compiled value.
(define-schemifier 'primitive #f
(lambda (node)
(let ((form (node-form node)))
(cond ((pair? form)
(get-variable-name (cdr form))) ; non-call position
((assq (primitive-id form) aliases)
=> cdr)
(else
(primitive-id form))))))
; lambda, let-syntax, letrec-syntax...
(define-schemifier 'letrec #f
(lambda (node)
(let ((form (node-form node)))
`(letrec ,(map (lambda (spec)
`(,(schemify (car spec)) ,(schemify (cadr spec))))
(cadr form))
,@(map (lambda (f) (schemify f))
(cddr form))))))
(define-schemifier 'lambda #f
(lambda (node)
(let ((form (node-form node)))
`(lambda ,(let label ((vars (cadr form)))
(cond ((pair? vars)
(cons (schemify (car vars))
(label (cdr vars))))
((null? vars)
'())
(else
(schemify vars))))
,@(map schemify (cddr form))))))
(define-schemifier 'goto #f
(lambda (node)
(map schemify (cdr (node-form node)))))
(define (schemify-sexp thing)
(cond ((name? thing)
(desyntaxify thing))
((primop? thing)
(primop-id thing))
((primitive? thing)
(primitive-id thing))
((variable? thing)
(get-variable-name thing))
((pair? thing)
(let ((x (schemify-sexp (car thing)))
(y (schemify-sexp (cdr thing))))
(if (and (eq? x (car thing))
(eq? y (cdr thing)))
thing ;+++
(cons x y))))
((vector? thing)
(let ((new (make-vector (vector-length thing) #f)))
(let loop ((i 0) (same? #t))
(if (>= i (vector-length thing))
(if same? thing new) ;+++
(let ((x (schemify-sexp (vector-ref thing i))))
(vector-set! new i x)
(loop (+ i 1)
(and same? (eq? x (vector-ref thing i)))))))))
(else thing)))
(define (clean-literal thing)
(cond ((name? thing)
(desyntaxify thing))
((variable? thing)
(get-variable-name thing))
((external-constant? thing)
`(enum ,(external-constant-enum-name thing)
,(external-constant-name thing)))
((pair? thing)
(let ((x (clean-literal (car thing)))
(y (clean-literal (cdr thing))))
(if (and (quoted? x) (quoted? y))
`(quote (,(cadr x) . ,(cadr y)))
`(cons ,x ,y))))
((vector? thing)
(let ((elts (map clean-literal (vector->list thing))))
(if (every? quoted? elts)
`(quote ,(list->vector (map cadr elts)))
`(vector . ,elts))))
(else
`(quote ,thing))))
(define (quoted? x)
(and (pair? x)
(eq? (car x) 'quote)))

214
ps-compiler/prescheme/eval.scm
View File

@ -1,214 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Evaluator for nodes.
; This doesn't handle n-ary procedures.
; (NAME-NODE-BINDING name-node) is used as an EQ? key in local environments,
; and passed as-is to the global-environment arguments.
; Exports:
; (EVAL-NODE node global-ref global-set! eval-primitive)
; CLOSURE? (CLOSURE-NODE closure) (CLOSURE-ENV closure)
; (UNSPECIFIC? thing)
(define (eval-node node global-ref global-set! eval-primitive)
(eval node (make-env '()
(make-eval-data global-ref
global-set!
eval-primitive))))
(define-record-type eval-data :eval-data
(make-eval-data global-ref global-set! eval-primitive)
eval-data?
(global-ref eval-data-global-ref)
(global-set! eval-data-global-set!)
(eval-primitive eval-data-eval-primitive))
; Environments
(define-record-type env :env
(make-env alist eval-data)
env?
(alist env-alist)
(eval-data env-eval-data))
(define (env-ref env name-node)
(let ((cell (assq name-node (env-alist env))))
(if cell
(cdr cell)
((eval-data-global-ref (env-eval-data env)) name-node))))
(define (env-set! env name-node value)
(let ((cell (assq name-node (env-alist env))))
(if cell
(set-cdr! cell value)
((eval-data-global-set! (env-eval-data env))
name-node
value))))
(define (extend-env env ids vals)
(make-env (append (map cons ids vals)
(env-alist env))
(env-eval-data env)))
(define (eval-primitive primitive args env)
((eval-data-eval-primitive (env-eval-data env)) primitive args))
; Closures
(define-record-type closure :closure
(make-closure node env)
closure?
(node closure-node)
(env real-closure-env)
(temp closure-temp set-closure-temp!))
(define (closure-env closure) ; exported
(env-alist (real-closure-env closure)))
(define (make-top-level-closure exp)
(make-closure exp the-empty-env))
(define the-empty-env (make-env '() #f))
; Main dispatch
(define (eval node env)
((operator-table-ref evaluators (node-operator-id node))
node
env))
; Particular operators
(define evaluators
(make-operator-table
(lambda (node env)
(error "no evaluator for node ~S" node))))
(define (define-evaluator name proc)
(operator-define! evaluators name #f proc))
(define (eval-list nodes env)
(map (lambda (node)
(eval node env))
nodes))
(define-evaluator 'literal
(lambda (node env)
(node-form node)))
(define-evaluator 'unspecific
(lambda (node env)
(unspecific)))
(define-evaluator 'unassigned
(lambda (node env)
(unspecific)))
(define-evaluator 'real-external
(lambda (node env)
(let* ((exp (node-form node))
(type (expand-type-spec (cadr (node-form (caddr exp))))))
(make-external-value (node-form (cadr exp))
type))))
(define-evaluator 'quote
(lambda (node env)
(cadr (node-form node))))
(define-evaluator 'lambda
(lambda (node env)
(make-closure node env)))
(define (apply-closure closure args)
(let ((node (closure-node closure))
(env (real-closure-env closure)))
(eval (caddr (node-form node))
(extend-env env (cadr (node-form node)) args))))
(define-evaluator 'name
(lambda (node env)
(env-ref env node)))
(define-evaluator 'set!
(lambda (node env)
(let ((exp (node-form node)))
(env-set! env (cadr exp) (eval (caddr exp) env))
(unspecific))))
(define-evaluator 'call
(lambda (node env)
(eval-call (car (node-form node))
(cdr (node-form node))
env)))
(define-evaluator 'goto
(lambda (node env)
(eval-call (cadr (node-form node))
(cddr (node-form node))
env)))
(define (eval-call proc args env)
(let ((proc (eval proc env))
(args (eval-list args env)))
(if (closure? proc)
(apply-closure proc args)
(eval-primitive proc args env))))
(define-evaluator 'begin
(lambda (node env)
(let ((exps (cdr (node-form node))))
(if (null? exps)
(unspecific)
(let loop ((exps exps))
(cond ((null? (cdr exps))
(eval (car exps) env))
(else
(eval (car exps) env)
(loop (cdr exps)))))))))
(define-evaluator 'if
(lambda (node env)
(let* ((form (node-form node))
(test (cadr form))
(arms (cddr form)))
(cond ((eval test env)
(eval (car arms) env))
((null? (cdr arms))
(unspecific))
(else
(eval (cadr arms) env))))))
(define-evaluator 'loophole
(lambda (node env)
(eval (caddr (node-form node)) env)))
(define-evaluator 'letrec
(lambda (node env)
(let ((form (node-form node)))
(let ((vars (map car (cadr form)))
(vals (map cadr (cadr form)))
(body (caddr form)))
(let ((env (extend-env env
vars
(map (lambda (ignore)
(unspecific))
vars))))
(for-each (lambda (var val)
(env-set! env var (eval val env)))
vars
vals)
(eval body env))))))
(define (unspecific? x)
(eq? x (unspecific)))
; Used by our clients but not by us.
(define (constant? x)
(or (number? x)
(symbol? x)
(external-constant? x)
(external-value? x)
(boolean? x)))

77
ps-compiler/prescheme/expand.scm
View File

@ -1,77 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Expanding using the Scheme 48 expander.
(define (scan-packages packages)
(let ((definitions
(fold (lambda (package definitions)
(let ((cenv (package->environment package)))
(fold (lambda (form definitions)
(let ((node (expand-form form cenv)))
(cond ((define-node? node)
(cons (eval-define (expand node cenv)
cenv)
definitions))
(else
(eval-node (expand node cenv)
global-ref
global-set!
eval-primitive)
definitions))))
(call-with-values
(lambda ()
(package-source package))
(lambda (files.forms usual-transforms primitives?)
(scan-forms (apply append (map cdr files.forms))
cenv)))
definitions)))
packages
'())))
(reverse (map (lambda (var)
(let ((value (variable-flag var)))
(set-variable-flag! var #f)
(cons var value)))
definitions))))
(define package->environment (structure-ref packages package->environment))
(define define-node? (node-predicate 'define))
(define (eval-define node cenv)
(let* ((form (node-form node))
(value (eval-node (caddr form)
global-ref
global-set!
eval-primitive))
(lhs (cadr form)))
(global-set! lhs value)
(name->variable-or-value lhs)))
(define (global-ref name)
(let ((thing (name->variable-or-value name)))
(if (variable? thing)
(variable-flag thing)
thing)))
(define (global-set! name value)
(let ((thing (name->variable-or-value name)))
(if (primitive? thing)
(bug "trying to set the value of primitive ~S" thing)
(set-variable-flag! thing value))))
(define (name->variable-or-value name)
(let ((binding (node-ref name 'binding)))
(if (binding? binding)
(let ((value (binding-place binding))
(static (binding-static binding)))
(cond ((primitive? static)
static)
((variable? value)
value)
((and (location? value)
(constant? (contents value)))
(contents value))
(else
(bug "global binding is not a variable, primitive or constant ~S" name))))
(user-error "unbound variable ~S" (node-form name)))))

406
ps-compiler/prescheme/flatten.scm
View File

@ -1,406 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Definitions are (<variable> . <value>) pairs, where <value> can be any
; Scheme value. This code walks the values looking for sharing and for
; closures. Shared values are collected in a list and additional definitions
; are introduced for the bindings in the environments of closures and for
; close-compiled versions of any primitives in non-call position. References
; to closure-bound variables are replaced with references to the newly-created
; package variables.
(define (flatten-definitions definitions)
(set! *shared* '())
(set! *definitions* '())
(set! *immutable-value-table* (make-value-table))
(set! *closed-compiled-primitives* (make-symbol-table))
(let loop ((defs definitions) (flat '()))
(cond ((not (null? defs))
(let ((var (caar defs))
(value (cdar defs)))
(if (and (variable-set!? var)
(closure? value))
(let ((new (generate-top-variable (variable-name var))))
(loop `((,var . ,new)
(,new . ,value)
. ,defs)
flat))
(loop (cdr defs)
(cons (cons var (flatten-value value))
flat)))))
((null? *definitions*)
(let ((forms (really-make-forms flat *shared*)))
(set! *shared* #f) ; safety
(set! *closed-compiled-primitives* #f)
(set! *immutable-value-table* #f)
forms))
(else
(let ((defs *definitions*))
(set! *definitions* '())
(loop defs flat))))))
; <Definitions> is a list of (<variable> . <value>) pairs.
; <Shared> is a list of all shared objects, each of which must end up being
; bound to a variable.
(define (really-make-forms definitions shared)
(for-each (lambda (defn)
(let ((var (car defn))
(shared (value-shared (cdr defn))))
(if (and (not (variable-set!? var))
shared
(not (shared-variable shared)))
(set-shared-variable! shared var))))
definitions)
(map definition->form
(append definitions
(shared-values->definitions shared))))
(define variable-set!? (structure-ref forms variable-set!?))
(define (shared-values->definitions shared)
(do ((shared shared (cdr shared))
(defns '() (if (shared-variable (value-shared (car shared)))
defns
(let ((var (generate-top-variable #f)))
(set-shared-variable! (value-shared (car shared)) var)
(cons (cons var (car shared)) defns)))))
((null? shared)
defns)))
(define (definition->form definition)
(let* ((var (car definition))
(value (cdr definition))
(shared (value-shared value))
(value (if (or (not shared)
(eq? var (shared-variable shared)))
value
(shared-variable shared)))
(clean (clean-value! value)))
((structure-ref forms make-form)
var
(if (or (node? clean)
(variable? clean))
clean
(make-literal-node clean))
(if (closure? value)
(cdr (shared-saved (closure-temp value))) ; free vars
(stored-value-free-vars clean)))))
(define (make-literal-node value)
(make-node op/literal value))
(define (make-name-node value)
(make-node op/name value))
(define *shared* '())
(define (add-shared! value)
(set! *shared* (cons value *shared*)))
(define *definitions* '())
(define (add-package-definition! value id)
(let ((var (generate-top-variable id)))
(set! *definitions*
(cons (cons var value)
*definitions*))
var))
(define (generate-top-variable maybe-id)
(let ((var (make-global-variable (concatenate-symbol
(if maybe-id
(schemify maybe-id)
'top.)
(next-top-id))
type/undetermined)))
(set-variable-flags! var
(cons 'generated-top-variable
(variable-flags var)))
var))
(define *next-top-id* 0)
(define (next-top-id)
(let ((id *next-top-id*))
(set! *next-top-id* (+ 1 *next-top-id*))
id))
(define (generated-top-variable? var)
(memq? 'generated-top-variable (variable-flags var)))
(define (stored-value-free-vars value)
(let ((vars '()))
(let label ((value value))
(cond ((variable? value)
(cond ((not (variable-flag value))
(set-variable-flag! value #t)
(set! vars (cons value vars)))
(else
;(breakpoint "marked variable") ; why did I care?
(values))))
((vector? value)
(do ((i 0 (+ i 1)))
((= i (vector-length value)))
(label (vector-ref value i))))
((pair? value)
(label (car value))
(label (cdr value)))))
(for-each (lambda (var)
(set-variable-flag! var #f))
vars)
vars))
;----------------------------------------------------------------
; Finding shared data structures.
(define-record-type shared
()
(saved
(shared? #f)
(variable #f)))
(define make-shared shared-maker)
(define (value-shared value)
(cond ((pair? value)
(car value))
((vector? value)
(if (= 0 (vector-length value))
#f
(vector-ref value 0)))
((closure? value)
(closure-temp value))
(else
#f)))
(define (clean-value! value)
(cond ((pair? value)
(cons (clean-sub-value! (shared-saved (car value)))
(clean-sub-value! (cdr value))))
((vector? value)
(if (= 0 (vector-length value))
value
(let ((new (make-vector (vector-length value))))
(vector-set! new 0 (clean-sub-value!
(shared-saved (vector-ref value 0))))
(do ((i 1 (+ i 1)))
((= i (vector-length value)))
(vector-set! new i (clean-sub-value! (vector-ref value i))))
new)))
((closure? value)
(car (shared-saved (closure-temp value)))) ; flattened version of node
((node? value)
(if (name-node? value)
(name-node->variable value)
(bug "bad definition value: ~S" value)))
(else
value)))
(define name-node? (node-predicate 'name))
(define (clean-sub-value! value)
(cond ((pair? value)
(let ((shared (car value)))
(cond ((shared-shared? shared)
(shared-variable shared))
(else
(set-car! value (clean-sub-value! (shared-saved shared)))
(set-cdr! value (clean-sub-value! (cdr value)))
value))))
((vector? value)
(cond ((= 0 (vector-length value))
value)
((shared-shared? (vector-ref value 0))
(shared-variable (vector-ref value 0)))
(else
(vector-set! value 0 (clean-sub-value!
(shared-saved (vector-ref value 0))))
(do ((i 1 (+ i 1)))
((= i (vector-length value)))
(vector-set! value i (clean-sub-value! (vector-ref value i))))
value)))
((closure? value)
(shared-variable (closure-temp value)))
(else
value)))
(define (flatten-value value)
(cond ((immutable? value)
(flatten-immutable-value value))
((primitive? value)
(primitive->name-node value))
(else
(flatten-value! value)
value)))
(define (flatten-value! value)
(cond ((pair? value)
(check-shared! (car value) flatten-pair! value))
((vector? value)
(if (not (= 0 (vector-length value)))
(check-shared! (vector-ref value 0) flatten-vector! value)))
((closure? value)
(check-shared! (closure-temp value) flatten-closure! value))))
(define (check-shared! shared flatten! value)
(cond ((not (shared? shared))
(flatten! value))
((not (shared-shared? shared))
(set-shared-shared?! shared #t)
(add-shared! value))))
(define *immutable-value-table* #f)
(define (flatten-immutable-value value)
(cond ((pair? value)
(or (shared-immutable-value value car)
(let ((p (cons (car value) (cdr value))))
(table-set! *immutable-value-table* value p)
(flatten-pair! p)
p)))
((vector? value)
(if (= 0 (vector-length value))
value
(or (shared-immutable-value value (lambda (x) (vector-ref x 0)))
(let ((v (copy-vector value)))
(table-set! *immutable-value-table* value v)
(flatten-vector! v)
v))))
; no immutable closures
(else
value))) ; no sub-values
(define (shared-immutable-value value accessor)
(cond ((table-ref *immutable-value-table* value)
=> (lambda (copy)
(cond ((not (shared-shared? (accessor copy)))
(set-shared-shared?! (accessor copy) #t)
(add-shared! copy)
copy))))
(else
#f)))
(define (flatten-pair! pair)
(let ((temp (car pair))
(shared (make-shared)))
(set-car! pair shared)
(set-shared-saved! shared (flatten-value temp))
(set-cdr! pair (flatten-value (cdr pair)))))
(define (flatten-vector! vector)
(let ((temp (vector-ref vector 0))
(shared (make-shared)))
(vector-set! vector 0 shared)
(set-shared-saved! shared (flatten-value temp))
(do ((i 1 (+ i 1)))
((= i (vector-length vector)))
(vector-set! vector i (flatten-value (vector-ref vector i))))))
; Make top-level definitions for the bindings in the closure and then substitute
; the defined variables within the closure's code. The define variables are
; saved in the bindings in case they are shared with other closures (both for
; efficiency and because SET! requires it).
(define (flatten-closure! closure)
(let ((shared (make-shared)))
(for-each flatten-closure-binding! (closure-env closure))
(set-closure-temp! closure shared)
(set-shared-shared?! shared #t) ; closures always need definitions
(add-shared! closure)
(receive (exp free)
(substitute-in-expression (closure-node closure))
(set-shared-saved! shared (cons exp free))
(for-each clear-closure-binding! (closure-env closure)))))
(define (clear-closure-binding! pair)
(node-set! (car pair) 'substitute #f))
; PAIR is (<name-node> . <value>) if it hasn't been seen before and
; (<name-node> . <substitute-name-node>) if it has.
(define (flatten-closure-binding! pair)
(let* ((name (car pair))
(subst (if (node? (cdr pair))
(cdr pair)
(let ((subst (make-name-node-subst name (cdr pair))))
(set-cdr! pair subst)
subst))))
(node-set! name 'substitute subst)))
(define (make-name-node-subst name value)
(let ((var (add-package-definition! value (node-form name)))
(subst (make-similar-node name (node-form name))))
(node-set! subst 'binding (make-binding #f var #f))
subst))
(define op/literal (get-operator 'literal))
(define op/name (get-operator 'name))
;----------------------------------------------------------------
(define *closed-compiled-primitives* #f)
(define (make-primitive-node primitive call?)
(if (and call?
(primitive-expands-in-place? primitive))
(make-node op/primitive primitive)
(let ((name-node (primitive->name-node primitive)))
(note-variable-use! (name-node->variable name-node))
name-node)))
(define (name-node->variable name-node)
(let ((binding (node-ref name-node 'binding)))
(cond ((not (binding? binding))
(bug "unbound variable ~S" (node-form name-node)))
((primitive? (binding-static binding))
(primitive->name-node (binding-static binding)))
(else
(binding-place binding)))))
(define (primitive->name-node primitive)
(let ((id (primitive-id primitive)))
(or (table-ref *closed-compiled-primitives* id)
(let* ((var (add-package-definition!
(make-top-level-closure
(expand (primitive-source primitive)
prescheme-compiler-env))
id))
(binding (make-binding #f var #f))
(node (make-node op/name id)))
(node-set! node 'binding (make-binding #f var #f))
(table-set! *closed-compiled-primitives* id node)
(set-variable-flags! var (cons 'closed-compiled-primitive
(variable-flags var)))
node))))
(define op/primitive (get-operator 'primitive))
;----------------------------------------------------------------
(define max-key-depth 5)
(define (value-table-hash-function obj)
(let recur ((obj obj) (depth 0))
(cond ((= depth max-key-depth)
0)
((symbol? obj) (string-hash (symbol->string obj)))
((integer? obj)
(if (< obj 0) (- -1 obj) obj))
((char? obj) (+ 333 (char->integer obj)))
((eq? obj #f) 3001)
((eq? obj #t) 3003)
((null? obj) 3005)
((pair? obj)
(+ 3007
(recur (car obj) (- depth 1))
(* 3 (recur (cdr obj) (- depth 1)))))
((vector? obj)
(let loop ((i 0) (hash (+ 3009 (vector-length obj))))
(if (or (= i (vector-length obj))
(= 0 (- depth i)))
hash
(loop (+ i 1) (+ hash (* i (recur (vector-ref obj i)
(- depth i))))))))
(else (error "value cannot be used as a table key" obj)))))
(define make-value-table
(make-table-maker eq? value-table-hash-function))

666
ps-compiler/prescheme/form.scm
View File

@ -1,666 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; temporary hack
;(define enqueue! enqueue)
;(define dequeue! dequeue)
(define-record-type form
(var ; variable being defined (if any)
(value) ; current value
;source ; one line of source code
(free) ; variables free in this form
)
(used? ; is the value used in the program
(exported? #f) ; true if the definition in this form is exported
(integrate 'okay) ; one of OKAY, YES, NO, PARTIAL
(aliases '()) ; variables that are aliases for this one
(shadowed '()) ; package variables that should be shadowed here
value-type ; value's type
(dependency-index #f) ; index of this form in the data dependent order
lambdas ; list of all non-cont lambdas in this form
(clients '()) ; forms that use this one's variable
(providers '()) ; forms that define a variable used by this one
(type #f) ; one of LAMBDA, INTEGRATE, INITIALIZE or
; #F for unfinished forms
merge ; slot used by form-merging code
temp ; handy slot
))
(define-record-discloser type/form
(lambda (form)
`(form ,(variable-name (form-var form)))))
(define (make-form var value free)
(let ((form (form-maker var value free)))
(if (maybe-variable->form var)
(error "more than one definition of ~S" (variable-name var)))
(set-variable-flags! var `((form . ,form) . ,(variable-flags var)))
form))
(define (pp-one-line x)
(call-with-string-output-port
(lambda (p)
(write-one-line p 70 (lambda (p) (write x p))))))
(define (form-node form)
(let ((value (form-value form)))
(if (node? value)
value
(bug "form's value is not a node ~S ~S" form value))))
(define (set-form-node! form node lambdas)
(set-node-flag! node form)
(set-form-value! form node)
(set-form-lambdas! form lambdas))
(define (node-form node)
(let ((form (node-flag (node-base node))))
(if (form? form)
form
(bug "node ~S (~S) not in any form" node (node-base node)))))
(define (suspend-form-use! form)
(set-form-lambdas! form (make-lambda-list))
(set-node-flag! (form-node form) form))
(define (use-this-form! form)
(initialize-lambdas)
(also-use-this-form! form))
(define (also-use-this-form! form)
(add-lambdas (form-lambdas form))
(set-node-flag! (form-node form) #f))
(define (form-name form)
(variable-name (form-var form)))
(define (make-form-unused! form)
(set-form-type! form 'unused)
(cond ((node? (form-value form))
(erase (form-value form))
(set-form-value! form #f)
(set-form-lambdas! form #f))))
; notes on writing and reading forms
; What we really need here are forms.
; What to do? Can read until there are no missing lambdas = end of form
; Need the variables as well.
; (form index type var source? clients providers integrate?)
; clients and providers are lists of indicies
; can get lambdas automatically
;(define (write-cps-file file forms)
; (let ((port (make-tracking-output-port (open-output-file file))))
; (reset-pp-cps)
; (walk (lambda (f)
; (write-form f port))
; (sort-list forms
; (lambda (f1 f2)
; (< (form-index f1) (form-index f2)))))
; (close-output-port port)))
;(define (write-form form port)
; (format port "(FORM ~D ~S ~S "
; (form-index form)
; (form-type form)
; (form-integrate form))
; (if (form-var form)
; (print-variable-name (form-var form) port)
; (format port "#f"))
; (format port "~% ~S" (map form-index (form-clients form)))
; (rereadable-pp-cps (form-value form) port)
; (format port ")~%~%"))
;------------------------------------------------------------------------------
; Put the forms that do not reference any other forms' variables in a queue.
; Every form gets a list of forms that use its variable and a list of forms
; whose variables it uses.
(define (sort-forms forms)
(let ((queue (make-queue)))
(for-each (lambda (f)
(set-variable-flag! (form-var f) f))
forms)
(let ((forms (really-remove-unreferenced-forms
forms
set-providers-using-free)))
(for-each (lambda (f)
(if (null? (form-providers f))
(enqueue! queue f)))
(reverse forms))
(for-each (lambda (f)
(set-variable-flag! (form-var f) #f))
forms)
(values forms (make-form-queue queue forms)))))
(define (set-providers-using-free form)
(let loop ((vars (form-free form)) (provs '()))
(cond ((null? vars)
(set-form-providers! form provs))
((variable-flag (car vars))
=> (lambda (prov)
(set-form-clients! prov (cons form (form-clients prov)))
(loop (cdr vars) (cons prov provs))))
(else
(loop (cdr vars) provs)))))
(define (make-form-queue ready forms)
(let ((index 0))
(lambda ()
(let loop ()
(cond ((not (queue-empty? ready))
(let ((form (dequeue! ready)))
(set-form-dependency-index! form index)
(for-each (lambda (f)
(set-form-providers! f (delq! form (form-providers f)))
(if (and (null? (form-providers f))
(not (form-dependency-index f))
(form-used? f))
(enqueue! ready f)))
(form-clients form))
(set! index (+ index 1))
form))
((find-dependency-loop ready forms)
=> (lambda (rest)
(set! forms rest)
(loop)))
(else #f))))))
; Find a circular dependence between the remaining forms.
(define (find-dependency-loop queue forms)
(let ((forms (do ((forms forms (cdr forms)))
((or (null? forms)
(not (form-dependency-index (car forms))))
forms))))
(cond ((null? forms)
#f)
(else
;;(format #t "Dependency loop!~%")
(let ((form (really-find-dependency-loop forms)))
(if (not (every? (lambda (f) (eq? 'no (form-integrate f)))
(form-providers form)))
(set-form-integrate! form 'no))
(set-form-providers! form '())
(enqueue! queue form)
forms)))))
(define (really-find-dependency-loop forms)
(for-each (lambda (f) (set-form-temp! f #f))
forms)
(let label ((form (car forms)))
(cond ((form-temp form)
(break-dependency-loop (filter (lambda (f)
(and (form-temp f) (form-var f)))
forms)))
(else
(set-form-temp! form #t)
(cond ((any-map label (form-providers form))
=> (lambda (res)
(set-form-temp! form #f)
res))
(else
(set-form-temp! form #f)
#f))))))
(define (any-map proc list)
(let loop ((list list))
(cond ((null? list)
#f)
((proc (car list))
=> identity)
(else
(loop (cdr list))))))
(define *loop-forms* #f)
(define (break-dependency-loop forms)
(or (first (lambda (f)
(or (every? (lambda (f)
(eq? 'no (form-integrate f)))
(form-providers f))
(memq? f (form-providers f))
(and (scheme-node? (form-value f))
(scheme-literal-node? (form-value f)))))
forms)
(begin (set! *loop-forms* forms)
(let ((f (breakpoint "Break dependency loop: *loop-forms* = ~S" forms)))
(set! *loop-forms* #f)
f))))
(define scheme-literal-node?
((structure-ref nodes node-predicate) 'literal))
(define scheme-node?
(structure-ref nodes node?))
;----------------------------------------------------------------
(define (variable-set!? var)
(memq 'set! (variable-flags var)))
(define (note-variable-set!! var)
(if (not (variable-set!? var))
(set-variable-flags! var (cons 'set! (variable-flags var)))))
;------------------------------------------------------------------------------
; Turn expression into nodes and simplify it.
; Still to do:
; Get representations of data values
; Need to constant fold vector slots, including detection of modifications
; and single uses.
(define (expand-and-simplify-form form)
(initialize-lambdas)
(let* ((value (form-value form))
(node (if (variable? value)
(make-reference-node value)
(x->cps (form-value form) (form-name form)))))
(cond ((variable-set!? (form-var form))
(set-form-type! form 'initialize)
(set-form-node! form node '())
"settable")
((reference-node? node)
(let ((var (reference-variable node)))
(add-known-form-value! form node)
(cond ((maybe-variable->form var)
=> (lambda (f)
(set-form-aliases! f
`(,(form-var form)
,@(form-aliases form)
. ,(form-aliases f))))))
(set-form-type! form 'alias)
(erase node)
(set-form-value! form var)
"alias"))
((literal-node? node)
(expand-and-simplify-literal node form))
((lambda-node? node)
(expand-and-simplify-lambda node form))
(else
(bug "funny form value ~S" node)))))
; This could pay attention to immutability.
(define (atomic? value)
(not (or (vector? value)
(pair? value))))
(define (expand-and-simplify-literal node form)
(let ((value (literal-value node)))
(cond ((unspecific? value)
(format #t "~%Warning: variable `~S' has no value and is not SET!~%"
(form-name form))
(set-form-value! form node)
(set-form-lambdas! form '())
(set-form-integrate! form 'no)
(set-form-type! form 'unused)
"constant")
((atomic? value)
(add-known-form-value! form node)
(set-form-value! form node)
(set-form-lambdas! form '())
"constant")
(else
(set-form-node! form (stob->node value) '())
(set-form-type! form 'stob)
"consed"))))
; Make a call node containing the contents of the stob so that any
; variables will be seen as referenced and any integrable values will
; be integrated.
; Only works for vectors at this point.
; MAKE-VECTOR is a randomly chosen primop, almost anything could be used.
(define (stob->node value)
(let* ((contents '())
(add! (lambda (x) (set! contents (cons x contents)))))
(cond ((vector? value)
(do ((i 0 (+ i 1)))
((>= i (vector-length value)))
(add! (vector-ref value i))))
(else
(error "unknown kind of stob value ~S" value)))
(let ((call (make-call-node (get-prescheme-primop 'make-vector)
(+ 1 (length contents))
0))
(node (make-lambda-node 'stob 'init '())))
(attach call 0 (make-literal-node value #f)) ; save for future use
(do ((i 1 (+ i 1))
(cs (reverse contents) (cdr cs)))
((null? cs))
(let ((x (car cs)))
(attach call i (if (variable? x)
(make-reference-node x)
(make-literal-node x type/unknown)))))
(attach-body node call)
(simplify-args call 1)
node)))
(define (add-known-form-value! form value)
(let ((node (if (variable? value)
(make-reference-node value)
value))
(var (form-var form)))
(set-form-type! form 'integrate)
(cond ((or (literal-node? node)
(reference-node? node)
(and (call-node? node)
(trivial? node)))
(add-variable-known-value! var (node->vector node))
(if (variable? value)
(erase node)))
((lambda-node? node)
(add-variable-simplifier! var (make-inliner (node->vector node))))
(else
(bug "form's value ~S is not a value" value)))))
(define (make-inliner vector)
(lambda (call)
(let ((proc (call-arg call 1)))
(replace proc (reconstruct-value vector proc call)))))
(define (reconstruct-value value proc call)
(let ((has-type (maybe-follow-uvar (variable-type (reference-variable proc))))
(node (vector->node value)))
(if (type-scheme? has-type)
(instantiate-type&value has-type node proc))
node))
(define (expand-and-simplify-lambda node form)
(simplify-all node (form-name form))
(let ((lambdas (make-lambda-list))
(status (duplicate-form? form node)))
(if status
(add-known-form-value! form node))
(set-form-node! form node lambdas)
(set-form-type! form 'lambda)
(set-form-free! form #f) ; old value no longer valid
status))
(define *duplicate-lambda-size* 10)
(define (set-duplicate-lambda-size! n)
(set! *duplicate-lambda-size* n))
(define (duplicate-form? form node)
(cond ((or (variable-set!? (form-var form))
(eq? 'no (form-integrate form)))
#f)
((small-node? node *duplicate-lambda-size*)
"small")
((eq? 'yes (form-integrate form))
"by request")
; ((called-arguments? node)
; "called arguments")
(else
#f)))
(define (called-arguments? node)
(any? (lambda (v)
(any? (lambda (n)
(eq? n (called-node (node-parent n))))
(variable-refs v)))
(cdr (lambda-variables node))))
;------------------------------------------------------------------------------
(define (integrate-stob-form form)
(if (and (eq? 'stob (form-type form))
(elide-aliases! form)
(not (form-exported? form))
(every? cell-use (variable-refs (form-var form))))
(let* ((var (form-var form))
(ref (car (variable-refs var)))
(call (lambda-body (form-value form))))
; could fold any fixed references - do it later
(cond ((and (null? (cdr (variable-refs var)))
(called-node? (cell-use ref)))
(format #t "computed-goto: ~S~%" (variable-name var))
(make-computed-goto form))))))
(define (cell-use node)
(let ((parent (node-parent node)))
(if (and (call-node? parent)
(eq? 'vector-ref (primop-id (call-primop parent))))
parent
#f)))
(define (elide-aliases! form)
(not (or-map (lambda (f)
(switch-references! (form-var f) (form-var form))
(form-exported? f))
(form-aliases form))))
(define (switch-references! from to)
(for-each (lambda (r)
(set-reference-variable! r to))
(variable-refs from))
(set-variable-refs! to (append (variable-refs from) (variable-refs to))))
;------------------------------------------------------------------------------
(define (resimplify-form form)
(let ((node (form-value form)))
(cond ((and (node? node)
(not (eq? 'stob (form-type form)))
(not (node-simplified? node)))
(use-this-form! form)
(simplify-node node)
(suspend-form-use! form)))))
;------------------------------------------------------------------------------
; This is removes all forms that are not ultimately referenced from some
; exported form.
(define (add-form-provider! form provider)
(if (not (memq? provider (form-providers form)))
(set-form-providers!
form
(cons provider (form-providers form)))))
(define (variable->form var)
(or (maybe-variable->form var)
(bug "variable ~S has no form" var)))
(define (maybe-variable->form var)
(cond ((flag-assq 'form (variable-flags var))
=> cdr)
(else
#f)))
(define (remove-unreferenced-forms forms)
(really-remove-unreferenced-forms forms set-form-providers))
(define (really-remove-unreferenced-forms forms set-form-providers)
(receive (exported others)
(partition-list form-exported? forms)
(for-each (lambda (f)
(set-form-providers! f '())
(set-form-clients! f '())
(set-form-used?! f (form-exported? f)))
forms)
(for-each set-form-providers forms)
(propogate-used?! exported)
(append (remove-unused-forms others) exported)))
(define (set-form-providers form)
(for-each (lambda (n)
(add-form-provider! (node-form n) form))
(variable-refs (form-var form)))
(if (eq? (form-type form) 'alias)
(add-form-provider! form (variable->form (form-value form)))))
(define (propogate-used?! forms)
(let loop ((to-do forms))
(if (not (null? to-do))
(let loop2 ((providers (form-providers (car to-do)))
(to-do (cdr to-do)))
(if (null? providers)
(loop to-do)
(loop2 (cdr providers)
(let ((p (car providers)))
(cond ((form-used? p)
to-do)
(else
(set-form-used?! p #t)
(cons p to-do))))))))))
; Actually remove forms that are not referenced.
(define (remove-unused-forms forms)
; (format #t "Removing unused forms~%")
(filter (lambda (f)
(cond ((or (not (form-used? f))
)
;(let ((value (form-value f)))
; (and (quote-exp? value)
; (external-value? (quote-exp-value value))))
; (format #t " ~S~%" (variable-name (form-var f)))
(erase-variable (form-var f))
(cond ((node? (form-value f))
(erase (form-value f))
(set-form-value! f #f)
(set-form-lambdas! f '())))
#f)
(else #t)))
forms))
;------------------------------------------------------------
; Total yucko.
; (unknown-call (lambda e-vars e-body)
; protocol
; (vector-ref x offset)
; . args)
; =>
; (let (lambda ,vars
; (computed-goto
; ...
; (lambda ()
; (unknown-call (lambda ,copied-evars
; (jump ,(car vars) ,copied-evars))
; ,(vector-ref proc-vector i)
; . ,(cdr vars)))
; ...
; '((offsets ...) ...) ; offsets for each continuation
; ,offset))
; ,exit
; . ,args)
(define (make-computed-goto form)
(let* ((ref (car (variable-refs (form-var form))))
(in-form (node-form ref))
(entries (vector->offset-map (call-args (lambda-body (form-node form))))))
(use-this-form! in-form)
(also-use-this-form! form)
(really-make-computed-goto (node-parent ref) entries)
(erase (form-node form))
(set-form-value! form #f)
(set-form-lambdas! form #f)
(simplify-node (form-node in-form))
(suspend-form-use! in-form)))
; Returns a list ((<node> . <offsets>) ...) where <offsets> are where <node>
; was found in VECTOR. The first element of VECTOR is a marker which we
; pretend isn't there.
;
; This would be more effective if done by a simplifier after the continuations
; had been simplified.
(define (vector->offset-map vector)
(let loop ((i 0) (res '()))
(if (= (+ i 1) (vector-length vector))
(reverse (map (lambda (p)
(cons (car p) (reverse (cdr p))))
res))
(let ((n (vector-ref vector (+ i 1))))
(loop (+ i 1)
(cond ((first (lambda (p)
(node-equal? n (car p)))
res)
=> (lambda (p)
(set-cdr! p (cons i (cdr p)))
res))
(else
(cons (list n i) res))))))))
(define (really-make-computed-goto vec-ref entries)
(let* ((exits (length entries))
(offset (call-arg vec-ref 1))
(vector-call (node-parent vec-ref))
(args (sub-vector->list (call-args vector-call) 3))
(call (make-call-node (get-prescheme-primop 'computed-goto)
(+ 2 exits)
exits))
(arg-vars (map (lambda (arg) (make-variable 't (node-type arg)))
args))
(protocol (literal-value (call-arg vector-call 2)))
(cont (call-arg vector-call 0)))
(for-each detach args)
(attach call exits (make-literal-node (map cdr entries) #f))
(attach call (+ exits 1) (detach offset))
(receive (top continuations)
(if (reference-node? cont)
(make-computed-goto-tail-conts call args arg-vars entries cont protocol)
(make-computed-goto-conts call args arg-vars entries cont protocol))
(do ((i 0 (+ i 1))
(l continuations (cdr l)))
((= i exits))
(attach call i (car l)))
(replace-body vector-call top))))
(define (make-computed-goto-tail-conts call args arg-vars entries cont protocol)
(let-nodes ((top (let 1 l1 . args))
(l1 arg-vars call))
(values top (map (lambda (p)
(computed-goto-tail-exit
(detach (car p))
protocol
(reference-variable cont)
arg-vars))
entries))))
(define (computed-goto-tail-exit node protocol cont-var arg-vars)
(let ((args (map make-reference-node arg-vars)))
(let-nodes ((l1 () (unknown-tail-call 0 (* cont-var)
node
'(protocol #f) . args)))
l1)))
(define (make-computed-goto-conts call args arg-vars entries cont protocol)
(let ((cont-vars (lambda-variables cont))
(cont-type (make-arrow-type (map variable-type
(lambda-variables cont))
type/null)))
(detach cont)
(change-lambda-type cont 'jump)
(let-nodes ((top (let 1 l1 cont . args))
(l1 ((j cont-type) . arg-vars) call))
(values top
(map (lambda (p)
(computed-goto-exit (detach (car p))
protocol
arg-vars
j
cont-vars))
entries)))))
(define (computed-goto-exit node protocol arg-vars cont-var cont-vars)
(let* ((cont-vars (map copy-variable cont-vars))
(cont-args (map make-reference-node cont-vars))
(args (map make-reference-node arg-vars)))
(let-nodes ((l1 () (unknown-call 1 l2 node '(protocol #f) . args))
(l2 cont-vars (jump 0 (* cont-var) . cont-args)))
l1)))

133
ps-compiler/prescheme/front-end.scm
View File

@ -1,133 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define (prescheme-front-end package-ids spec-files copy no-copy shadow)
(receive (packages exports lookup)
(package-specs->packages+exports package-ids spec-files)
(let ((forms (flatten-definitions (scan-packages packages))))
(annotate-forms! (car package-ids) lookup exports copy no-copy shadow)
(receive (forms producer)
(sort-forms forms)
(format #t "Checking types~%")
(let ((sorted (let loop ((forms '()))
(cond ((producer)
=> (lambda (f)
(type-check-form f)
(loop (cons f forms))))
(else
(reverse forms))))))
; (format #t "Adding coercions~%")
; (add-type-coercions (form-reducer forms))
sorted)))))
(define (form-reducer forms)
(lambda (proc init)
(let loop ((forms forms) (value init))
(if (null? forms)
value
(loop (cdr forms)
(proc (form-name (car forms))
(form-value (car forms))
value))))))
(define (test id files)
((structure-ref node reset-node-id))
((structure-ref record-types reset-record-data!))
(prescheme-front-end id files '() '() '()))
(define (annotate-forms! package-id lookup exports copy no-copy shadow)
(mark-forms! exports
lookup
(lambda (f) (set-form-exported?! f #t))
"exported")
(mark-forms! copy
lookup
(lambda (f) (set-form-integrate! f 'yes))
"to be copied")
(mark-forms! no-copy
lookup
(lambda (f) (set-form-integrate! f 'no))
"not to be copied")
(for-each (lambda (data)
(let ((owner (package-lookup lookup (caar data) (cadar data))))
(if owner
(mark-forms! (cdr data)
lookup
(lambda (f)
(set-form-shadowed! owner
(cons (form-var f)
(form-shadowed owner))))
(format #f "shadowed in ~S" (car data)))
(format #t "Warning: no definition for ~S, cannot shadow ~S~%"
(car data) (cdr data)))))
shadow))
(define (mark-forms! specs lookup marker mark)
(let ((lose (lambda (p n)
(format #t "Warning: no definition for ~S, cannot mark as ~A~%"
(list p n) mark))))
(for-each (lambda (spec)
(let ((package-id (car spec))
(ids (cdr spec)))
(for-each (lambda (id)
(cond ((package-lookup lookup package-id id)
=> marker)
(else
(lose package-id id))))
ids)))
specs)))
(define (package-lookup lookup package-id id)
(let ((var (lookup package-id id)))
(and (variable? var)
(maybe-variable->form var))))
; Two possibilities:
; 1. The variable is settable but the thunk gives it no particular value.
; 2. A real value is or needs to be present, so we relate the type of
; the variable with the type of the value.
; thunk's value may be a STOB and not a lambda.
(define (type-check-form form)
;; (format #t " ~S: " (variable-name (form-var form)))
(let* ((value (form-value form))
(var (form-var form))
(name (form-name form))
(value-type (cond (((structure-ref nodes node?) value)
(infer-definition-type value (source-proc form)))
((variable? value)
(get-package-variable-type value))
(else
(bug "unknown kind of form value ~S" value)))))
(set-form-value-type! form value-type)
(cond ((not (variable-set!? var))
(let ((type (cond ((eq? type/unknown (variable-type var))
(let ((type (schemify-type value-type 0)))
(set-variable-type! var type)
type))
(else
(unify! value-type (get-package-variable-type var) form)
value-type))))
(if (not (type-scheme? type))
(make-nonpolymorphic! type)) ; lock down any related uvars
;;(format #t "~S~%" (instantiate type))
))
((not (or (eq? type/unit value-type)
(eq? type/null value-type)))
(make-nonpolymorphic! value-type) ; no polymorphism allowed (so it
;; is not checked for, so there may be depth 0 uvars in the type)
;; (format #t " ~S~%" (instantiate value-type))
(unify! value-type (get-package-variable-type var) form))
((eq? type/unknown (variable-type var))
(get-package-variable-type var)))))
(define (source-proc form)
(lambda (port)
(write-one-line port
70
(lambda (port)
(format port "~S = ~S"
(form-name form)
((structure-ref nodes schemify)
(form-value form)))))))

162
ps-compiler/prescheme/hoist.scm
View File

@ -1,162 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Move nested procedures out to top level. We move them all out, then merge
; as many as possible back together (see merge.scm), and finally check to
; see if there are any out-of-scope references.
(define (hoist-nested-procedures forms)
(set! *hoist-index* 0)
(let loop ((forms forms) (done '()))
(if (null? forms)
(reverse done)
(loop (cdr forms)
(let ((form (car forms)))
(if (eq? 'lambda (form-type form))
(append (really-hoist-nested-procedures form)
(cons form done))
(cons form done)))))))
(define (really-hoist-nested-procedures form)
(let ((top (form-value form))
(lambdas (form-lambdas form))
(lambda-parent lambda-env) ; Rename a couple of handy fields
(lambda-kids lambda-block)
(new-forms '()))
; (format #t " ~S: ~S~%" (form-name form) lambdas)
; (if (eq? 'read-list (form-name form))
; (breakpoint "read-list"))
(receive (procs others)
(find-scoping lambdas
lambda-env set-lambda-env!
lambda-block set-lambda-block!)
(set-form-lambdas! form (cons top (non-proc-lambdas (lambda-kids top))))
(map (lambda (proc)
(let ((var (replace-with-variable proc)))
(make-hoist-form proc
var
(form-name form)
(non-proc-lambdas (lambda-kids proc)))))
(filter (lambda (p)
(not (eq? p top)))
procs)))))
(define (non-proc-lambdas lambdas)
(filter (lambda (l)
(not (or (eq? 'proc (lambda-type l))
(eq? 'known-proc (lambda-type l)))))
lambdas))
(define (make-hoist-form value var hoisted-from lambdas)
(let ((form (make-form var #f #f)))
(set-form-node! form value (cons value lambdas))
(set-form-type! form 'lambda)
(set-variable-flags! var
(cons (cons 'hoisted hoisted-from)
(variable-flags var)))
form))
(define (replace-with-variable node)
(let ((var (make-hoist-variable node)))
(case (primop-id (call-primop (node-parent node)))
((let)
(substitute-var-for-proc (node-parent node) node var))
((letrec2)
(substitute-var-for-proc-in-letrec (node-parent node) node var))
(else
(move node
(lambda (node)
(make-reference-node var)))))
var))
(define (make-hoist-variable node)
(cond ((bound-to-variable node)
=> (lambda (var)
(make-global-variable (generate-hoist-name (variable-name var))
(variable-type var))))
(else
(let* ((vars (lambda-variables node))
(type (make-arrow-type (map variable-type (cdr vars))
(variable-type (car vars))))
(id (generate-hoist-name (or (lambda-name node) 'hoist))))
(make-global-variable id type)))))
(define (substitute-var-for-proc call node value-var)
(let ((proc (call-arg call 0)))
(really-substitute-var-for-proc proc call node value-var)
(if (null? (lambda-variables proc))
(replace-body call (detach-body (lambda-body proc))))))
(define (substitute-var-for-proc-in-letrec call node value-var)
(let ((proc (node-parent call)))
(really-substitute-var-for-proc proc call node value-var)
(if (null? (cdr (lambda-variables proc)))
(replace-body (node-parent proc)
(detach-body (lambda-body (call-arg call 0)))))))
(define (really-substitute-var-for-proc binder call node value-var)
(let* ((index (node-index node))
(var (list-ref (lambda-variables binder)
(- (node-index node) 1))))
(walk-refs-safely
(lambda (ref)
(replace ref (make-reference-node value-var)))
var)
(remove-variable binder var)
(detach node)
(remove-call-arg call index)))
(define *hoist-index* 0)
(define (generate-hoist-name sym)
(let ((i *hoist-index*))
(set! *hoist-index* (+ i 1))
(concatenate-symbol sym "." i)))
;----------------------------------------------------------------
; Part 2: checking for variables moved out of scope.
(define (check-hoisting forms)
(let ((forms (filter (lambda (form)
(or (eq? 'merged (form-type form))
(eq? 'lambda (form-type form))))
forms)))
(for-each (lambda (form)
(cond ((flag-assq 'hoisted (variable-flags (form-var form)))
=> (lambda (p)
(check-hoisted-form form (cdr p))))))
forms)))
(define (check-hoisted-form form hoisted-from)
(let ((vars (find-unbound-variables (form-value form) (form-head form))))
(if (not (null? vars))
(user-error "Procedure ~S in ~S is closed over: ~S~%"
(form-name form)
hoisted-from
(map variable-name vars)))))
(define (find-unbound-variables node form)
(let ((unbound '())
(mark (cons 0 0)))
(let label ((n node))
(cond ((lambda-node? n)
(let ((flag (node-flag n)))
(set-node-flag! n mark)
(label (lambda-body n))
(set-node-flag! n flag)))
((call-node? n)
(let ((vec (call-args n)))
(do ((i 0 (+ i 1)))
((= i (vector-length vec)))
(label (vector-ref vec i)))))
((reference-node? n)
(let* ((v (reference-variable n))
(b (variable-binder v)))
(cond ((and b
(not (eq? mark (node-flag b)))
(not (variable-flag v)))
(set-variable-flag! v #t)
(set! unbound (cons v unbound))))))))
(filter (lambda (v)
(set-variable-flag! v #f)
(not (eq? form (form-head (node-form (variable-binder v))))))
unbound)))

341
ps-compiler/prescheme/infer-early.scm
View File

@ -1,341 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Type checking nodes.
; Entry point
; Because NODE is not the car of a pair, this depends on lambdas not being
; coerceable and literal nodes being coerced in place (instead of having a
; call inserted).
(define (infer-definition-type node name)
(set! *currently-checking* name)
(let ((res (cond ((literal-node? node)
(infer-literal-type node name))
((lambda-node? node)
(infer-type node 0))
((name-node? node)
(get-global-type (binding-place (node-ref node 'binding))))
(else
(bug "definition value is not a value node ~S" node)))))
(set! *currently-checking* #f)
res))
(define (infer-literal-type node name)
(let ((value (node-form node)))
(cond ((vector? value)
(let ((uvar (make-uvar name -1)))
(do ((i 0 (+ i 1)))
((>= i (vector-length value)))
(unify! uvar (type-check-thing (vector-ref value i)) value))
(make-pointer-type (maybe-follow-uvar uvar))))
(else
(infer-type node 0)))))
(define (type-check-thing thing)
(if (variable? thing)
(get-package-variable-type thing)
(literal-value-type thing)))
(define literal-operator (get-operator 'literal))
(define (make-literal-node value)
(make-node literal-operator value))
; Get the type of the variable - if it is a type-variable, then create a new
; one and relate the two; if it is a polymorphic pattern, instantiate it.
(define (get-package-variable-type var)
(let ((rep (variable-type var)))
(cond ((eq? rep type/undetermined)
(let ((type (make-uvar (variable-name var) -1)))
(set-variable-type! var type)
(set-uvar-source! type var)
type))
((type-scheme? rep)
(instantiate-type-scheme rep -1))
(else
rep))))
; Exported
(define (get-variable-type var)
(let ((rep (variable-type var)))
(cond ((eq? rep type/undetermined)
(bug "lexically bound variable ~S has no type" var))
((type-scheme? rep)
(instantiate-type-scheme rep -1))
(else
rep))))
;----------------------------------------------------------------
(define (infer-type node depth)
(infer-any-type node depth #f))
(define (infer-any-type node depth return?)
(let ((type ((operator-table-ref inference-rules (node-operator-id node))
node
depth
return?)))
(set-node-type! node type)
(maybe-follow-uvar type)))
(define inference-rules
(make-operator-table
(lambda (node depth return?)
(error "no type inference for node ~S" node))))
(define (define-inference-rule name proc)
(operator-define! inference-rules name #f proc))
(define-inference-rule 'literal
(lambda (node depth return?)
(infer-literal (node-form node) node)))
(define-inference-rule 'quote
(lambda (node depth return?)
(infer-literal (cadr (node-form node)) node)))
(define (infer-literal value node)
(literal-value-type value))
(define (literal-value-type value)
(or (maybe-literal-value-type value)
(error "don't know type of literal ~S" value)))
(define (maybe-literal-value-type value)
(cond ((boolean? value)
type/boolean)
((char? value)
type/char)
((integer? value)
type/integer)
((string? value)
type/string)
(((structure-ref eval-node unspecific?) value)
type/null)
((input-port? value)
type/input-port)
((output-port? value)
type/output-port)
((external-value? value)
(external-value-type value))
((external-constant? value)
type/integer)
(else
#f)))
(define-inference-rule 'unspecific
(lambda (node depth return?)
type/null))
(define-inference-rule 'lambda
(lambda (node depth return?)
(let* ((uid (unique-id))
(exp (node-form node))
(var-types (map (lambda (name-node)
(initialize-name-node-type name-node uid depth))
(cadr exp)))
(result (infer-any-type (caddr exp) depth #t)))
; stash the return type
(set-lambda-node-return-type! node result)
(make-arrow-type var-types result))))
; Create a new type variable for VAR.
(define (initialize-name-node-type node uid depth)
(let ((uvar (make-uvar (node-form node) depth uid)))
(set-node-type! node uvar)
(set-uvar-source! uvar node)
uvar))
; Get the type of the variable - if it is a type-variable, then create a new
; one and relate the two; if it is a polymorphic pattern, instantiate it.
; How to pass the source?
(define-inference-rule 'name
(lambda (node depth return?)
(let ((type (if (node-ref node 'binding)
(get-global-type (binding-place (node-ref node 'binding)))
(node-type node))))
(if (not type)
(bug "name node ~S has no type" node))
(if (type-scheme? type)
(instantiate-type-scheme type depth)
type))))
(define-inference-rule 'primitive
(lambda (node depth return?)
(let ((type (get-global-type (cdr (node-form node)))))
(if (type-scheme? type)
(instantiate-type-scheme type depth)
type))))
; If no type is present, create a type variable.
(define (get-global-type value)
(if (location? value)
(literal-value-type (contents value))
(let ((has (maybe-follow-uvar (variable-type value))))
(cond ((not (eq? has type/undetermined))
has)
(else
(let ((type (make-uvar (variable-name value) -1)))
(set-variable-type! value type)
(set-uvar-source! type value)
type))))))
(define-inference-rule 'set!
(lambda (node depth return?)
(let* ((exp (node-form node))
(type (infer-type (caddr exp) depth))
(binding (node-ref (cadr exp) 'binding)))
(if (not binding)
(error "SET! on a local variable ~S" (schemify node)))
(unify! type (variable-type (binding-place binding)) node)
type/null)))
(define-inference-rule 'call
(lambda (node depth return?)
(rule-for-calls (node-form node) node depth return?)))
(define-inference-rule 'goto
(lambda (node depth return?)
(rule-for-calls (cdr (node-form node)) node depth return?)))
(define (rule-for-calls proc+args node depth return?)
(let ((proc (car proc+args))
(args (cdr proc+args)))
(cond ((lambda-node? proc)
(rule-for-let node depth proc args return?))
((primitive-node? proc)
(rule-for-primitives node depth (node-form proc) args return?))
(else
(rule-for-unknown-calls node depth proc+args return?)))))
(define name-node? (node-predicate 'name))
(define lambda-node? (node-predicate 'lambda))
(define literal-node? (node-predicate 'literal))
(define primitive-node? (node-predicate 'primitive))
(define (rule-for-let node depth proc args return?)
(let ((depth (+ depth 1))
(uid (unique-id))
(proc (node-form proc)))
(do ((names (cadr proc) (cdr names))
(vals args (cdr vals)))
((null? names))
(let ((type (schemify-type (infer-type (car vals) depth) depth)))
(if (type-scheme? type)
(set-node-type! (car names) type)
(unify! (initialize-name-node-type (car names) uid depth)
type
node))))
(infer-any-type (caddr proc) depth return?)))
(define (rule-for-primitives node depth primitive args return?)
((primitive-inference-rule primitive)
args node depth return?))
(define (rule-for-unknown-calls node depth proc+args return?)
(let ((proc-type (infer-type (car proc+args) depth))
(arg-types (infer-types (cdr proc+args) depth))
(return-type (if return?
(make-tuple-uvar 'result depth)
(make-uvar 'result depth))))
(unify! proc-type
(make-arrow-type arg-types return-type)
node)
; (if (= 244 (uvar-id return-type))
; (breakpoint "rule-for-unknown-calls"))
(maybe-follow-uvar return-type)))
(define (infer-types nodes depth)
(map (lambda (node)
(infer-type node depth))
nodes))
(define-inference-rule 'begin
(lambda (node depth return?)
(let loop ((exps (cdr (node-form node))) (type type/unit))
(if (null? exps)
type
(loop (cdr exps)
(infer-any-type (car exps)
depth
(or (not (null? (cdr exps)))
return?)))))))
; It would be nice if we could just try to unify the two arms and return
; type/unit if we lost, but unification has side-effects.
(define-inference-rule 'if
(lambda (node depth return?)
(let* ((args (cdr (node-form node)))
(true-type (infer-any-type (cadr args) depth return?))
(false-type (infer-any-type (caddr args) depth return?)))
(unify! (infer-type (car args) depth) type/boolean node)
(cond ((eq? true-type type/null)
false-type)
((eq? false-type type/null)
true-type)
(else
(unify! true-type false-type node)
true-type)))))
(define-inference-rule 'letrec
(lambda (node depth return?)
(let ((form (node-form node))
(depth (+ depth 1))
(uid (unique-id)))
(let ((names (map car (cadr form)))
(vals (map cadr (cadr form))))
(for-each (lambda (name)
(initialize-name-node-type name uid depth))
names)
(do ((names names (cdr names))
(vals vals (cdr vals)))
((null? names))
(if (not (lambda-node? (car vals)))
(error "LETREC value is not a LAMBDA: ~S" (schemify node)))
(unify! (infer-type (car vals) depth)
(node-type (car names))
node))
(for-each (lambda (name)
(let ((type (schemify-type (node-type name) depth)))
(if (type-scheme? type)
(set-node-type! name type))))
names)
(infer-any-type (caddr form) depth return?)))))
;--------------------------------------------------
(define (node-type node)
(maybe-follow-uvar (node-ref node 'type)))
(define (set-node-type! node type)
(node-set! node 'type type))
(define (lambda-node-return-type node)
(node-ref node 'return-type))
(define (set-lambda-node-return-type! node type)
(node-set! node 'return-type type))
;--------------------------------------------------
; Utility procedures used by the inferencers of the various primops.
; Check that the INDEX'th argument of CALL has type TYPE.
(define (check-arg-type args index type depth exp)
(if (null? args)
(begin
(format #t "Wrong number of arguments in ~S~% " (schemify exp))
(if *currently-checking*
(format #t "~% while reconstructing the type of '~S'" *currently-checking*))
(error "type problem")))
(unify! (infer-type (list-ref args index) depth)
type
exp))

94
ps-compiler/prescheme/inference.scm
View File

@ -1,94 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Type Inference
;
; The entry points to the inferencer are:
;
; (unify! type1 type2 context)
; Unify TYPE1 and TYPE2. CONTEXT is used to provide user feedback when type
; errors are detected.
;
; (make-uvar prefix depth . maybe-id)
; Makes a new type variable. PREFIX is a symbol, DEPTH is the current type
; depth (used for polymorphism), and MAYBE-ID is an optional unique
; integer.
;
; (schemify-type type depth)
; Make TYPE polymorphic in any variables bound at DEPTH.
;
; (instantiate-type-scheme scheme depth)
; Return an instantiation of SCHEME at DEPTH.
;
; (reset-inference!)
; Clear various global variables (to be replaced with fluids at some point)
(define (unify! type1 type2 context)
(cond ((really-unify! type1 type2)
=> (lambda (error-thunk)
(unify-lost error-thunk type1 type2 context)))))
(define *currently-checking* #f)
(define *current-top-exp* #f)
(define (unify-lost error-thunk type1 type2 context)
(cond ((eq? context 'simplifying)
(bug "unification error while instantiating an integrable procedure"))
((eq? context 'make-monomorphic)
#f)
(else
(user-type-error-message error-thunk type1 type2 context))))
(define (user-type-error-message error-thunk type1 type2 context)
(format #t "Type error in ~S~% " (schemify context))
(error-thunk)
(if *currently-checking*
(begin
(format #t "~% while reconstructing the type of~% ")
(*currently-checking* (current-output-port))))
(error "type problem"))
(define (really-unify! p1 p2)
(let ((p1 (maybe-follow-uvar p1)) ; get the current value of P1
(p2 (maybe-follow-uvar p2))) ; get the current value of P2
(cond ((or (eq? p1 p2)
(eq? p1 type/null)
(eq? p2 type/null))
#f)
((uvar? p1)
(bind-uvar! p1 p2))
((uvar? p2)
(bind-uvar! p2 p1))
((other-type? p1)
(if (and (other-type? p2)
(eq? (other-type-kind p1) (other-type-kind p2))
(= (length (other-type-subtypes p1))
(length (other-type-subtypes p2))))
(unify-lists! (other-type-subtypes p1)
(other-type-subtypes p2))
(mismatch-failure p1 p2)))
(else
(mismatch-failure p1 p2)))))
(define (mismatch-failure t1 t2)
(lambda ()
(format #t "type mismatch~% ")
(display-type t1 (current-output-port))
(format #t "~% ")
(display-type t2 (current-output-port))))
(define (unify-lists! l1 l2)
(let loop ((l1 l1) (l2 l2))
(if (null? l1)
#f
(or (really-unify! (car l1) (car l2))
(loop (cdr l1) (cdr l2))))))
(define (type-conflict message . stuff)
(apply breakpoint message stuff))
; For debugging
(define (uvar-name uvar)
(concatenate-symbol (uvar-prefix uvar) "." (uvar-id uvar)))

215
ps-compiler/prescheme/interfaces.scm
View File

@ -1,215 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define-interface ps-primop-interface
(export get-prescheme-primop
(define-scheme-primop :syntax)
(define-polymorphic-scheme-primop :syntax)
(define-nonsimple-scheme-primop :syntax)
(define-scheme-cond-primop :syntax)
prescheme-integer-size
lshr))
(define-interface ps-c-primop-interface
(export simple-c-primop?
primop-generate-c
(define-c-generator :syntax)))
(define-interface ps-type-interface
(export ;type/int7u
;type/int8
;type/int8u
type/integer
type/float
type/char
type/address
type/null
type/unit
type/boolean
type/undetermined
type/input-port
type/output-port
type/unknown
type/string
other-type?
other-type-kind
other-type-subtypes
make-other-type
base-type?
base-type-name
base-type-uid
make-atomic-type
make-arrow-type
arrow-type?
arrow-type-result
arrow-type-args
make-pointer-type
pointer-type?
pointer-type-to
make-tuple-type
tuple-type?
tuple-type-types
record-type?
lookup-type
type-scheme?
schemify-type
instantiate-type-scheme
copy-type
type-scheme-type
make-nonpolymorphic!
type-scheme-free-uvars ; for error messages
; type-scheme-lattice-uvars
; type-scheme-type
type-eq?
; type>
; type>=
; lattice-type?
expand-type-spec
finalize-type
display-type
make-base-type-table
))
(define-interface type-variable-interface
(export make-uvar
make-tuple-uvar
uvar?
maybe-follow-uvar
uvar-source set-uvar-source!
reset-type-vars!
uvar-binding set-uvar-binding!
uvar-prefix
uvar-id
uvar-temp set-uvar-temp!
bind-uvar!
unique-id
))
(define-interface record-type-interface
(export reset-record-data!
all-record-types
get-record-type
record-type-name
record-type-fields
get-record-type-field
record-field-record-type
record-field-name
record-field-type))
(define-interface inference-interface
(export infer-definition-type
get-package-variable-type
get-variable-type
;add-type-coercions
node-type
lambda-node-return-type))
(define-interface inference-internal-interface
(export unify!
infer-type infer-types
check-arg-type
literal-value-type
))
(define-interface form-interface
(export make-form
form?
form-value
set-form-value!
form-value-type
set-form-value-type!
node-form
set-form-node!
set-form-integrate!
set-form-exported?!
form-node
form-var
form-exported?
form-type
set-form-type!
form-free set-form-free!
suspend-form-use!
use-this-form!
also-use-this-form!
set-form-lambdas!
form-lambdas
form-name
form-merge set-form-merge!
form-providers set-form-providers!
form-clients set-form-clients!
form-shadowed set-form-shadowed!
variable-set!? note-variable-set!!
make-form-unused!
variable->form
maybe-variable->form
; high level stuff
sort-forms
expand-and-simplify-form
remove-unreferenced-forms
integrate-stob-form
resimplify-form
))
(define-interface linking-interface
(export package-specs->packages+exports
package-source
define-prescheme!
prescheme-compiler-env
))
(define-interface c-internal-interface
(export c-assignment
indent-to
c-argument-var
form-tail-called?
*doing-tail-called-procedure?*
merged-procedure-reference
goto-protocol?
c-ify
c-value
form-value
form-name
form-c-name
form-type
c-assign-to-variable
write-c-identifier
write-value-list
write-value-list-with-extras
write-value+result-var-list
form-return-count
set-form-return-count!
simple-c-primop
c-variable
*current-merged-procedure*
*extra-tail-call-args*
write-c-block
write-c-coercion
no-value-node?
display-c-type
add-c-type-declaration!
note-jump-generated!
))

236
ps-compiler/prescheme/linking.scm
View File

@ -1,236 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; This file has the Pre-Scheme compiler's code for dealing with the
; Scheme 48's module system.
; FILES is a list of files that contain structure definitions, including
; a definition for NAME. The files are loaded into a config package
; containing:
; - the procedures and macros for defining structures and interfaces
; - a Pre-Scheme structure (called PRESCHEME)
; - a ps-memory structure
; - a ps-receive structure
; - the STRUCTURE-REFS structure
; We then return:
; 1. a list of the packages required to implement the named structures
; 2. a list of the names exported by the named structures
; 3. a procedure that for looking up names defined in packages in the
; config package (this is used to map user directives to their targets)
(define (package-specs->packages+exports struct-names files)
(let ((config (make-very-simple-package 'config (list defpackage)))
(old-config ((structure-ref package-commands-internal config-package))))
(environment-define! config 'prescheme prescheme)
(environment-define! config 'ps-memory ps-memory)
(environment-define! config 'ps-receive ps-receive)
(environment-define! config 'ps-record-types ps-record-types)
(environment-define! config 'structure-refs structure-refs)
(environment-define! config ':syntax (structure-ref meta-types syntax-type))
(set-reflective-tower-maker! config (get-reflective-tower-maker old-config))
(let-fluids (structure-ref packages-internal $get-location)
get-variable
(structure-ref reading-forms $note-file-package)
(lambda (filename package) (values))
(lambda ()
(for-each (lambda (file)
(load file config))
files)))
(values (collect-packages (map (lambda (name)
(environment-ref config name))
struct-names)
(lambda (package)
#t))
(let ((names '()))
(for-each (lambda (struct-name)
(let ((my-names '()))
(for-each-declaration
(lambda (name type)
(set! my-names (cons name my-names)))
(structure-interface (environment-ref config struct-name)))
(set! names (cons (cons struct-name my-names) names))))
struct-names)
names)
(make-lookup config))))
; This creates new variables as needed for packages.
(define (get-variable package name)
;(format #t "Making variable ~S for ~S~%" name package)
((structure-ref variable make-global-variable)
name
(structure-ref ps-types type/unknown)))
; Return something that will find the binding of ID in the package belonging
; to the structure PACKAGE-ID in the CONFIG package.
(define (make-lookup config)
(lambda (package-id id)
(let ((binding (package-lookup config package-id)))
(if (and (binding? binding)
(location? (binding-place binding))
(structure? (contents (binding-place binding))))
(let* ((package (structure-package
(contents (binding-place binding))))
(binding (package-lookup package id)))
(if (binding? binding)
(binding-place binding)
#f))
#f))))
;----------------------------------------------------------------
; Handy packages and package making stuff.
(define defpackage (structure-ref built-in-structures defpackage))
(define structure-refs (structure-ref built-in-structures structure-refs))
(define scheme (structure-ref built-in-structures scheme))
(define (make-env-for-syntax-promise . structures)
(make-reflective-tower eval structures 'prescheme-linking))
(define (make-very-simple-package name opens)
(make-simple-package opens
eval
(make-env-for-syntax-promise scheme)
name))
(define (get-reflective-tower-maker p)
(environment-ref p (string->symbol ".make-reflective-tower.")))
;----------------------------------------------------------------
; The following stuff is used to define the DEFINE-RECORD-TYPE macro.
; We produce a structure that exports EXPAND-DEFINE-RECORD-TYPE. The
; base package then includes that structure in its FOR-SYNTAX package.
(define defrecord-for-syntax-package
(make-very-simple-package 'defrecord-for-syntax-package '()))
(define defrecord-for-syntax-structure
(make-structure defrecord-for-syntax-package
(lambda () (export expand-define-record-type))
'defrecord-for-syntax-structure))
(define (define-for-syntax-value id value)
(let ((loc (make-new-location defrecord-for-syntax-package id)))
(set-contents! loc value)
(package-define! defrecord-for-syntax-package
id
(structure-ref meta-types usual-variable-type)
loc
#f)))
(define-for-syntax-value 'expand-define-record-type expand-define-record-type)
;----------------------------------------------------------------
; BASE-PACKAGE contains all of the primitives, syntax, etc. for Pre-Scheme
(define (prescheme-unbound package name)
(bug "~S has no binding in package ~S" name package))
(define base-package
; (let-fluid (structure-ref packages-internal $get-location) prescheme-unbound
; (lambda () ))
(make-simple-package '()
eval
(make-env-for-syntax-promise
scheme
defrecord-for-syntax-structure)
'base-package))
; Add the operators.
(let ((syntax-type (structure-ref meta-types syntax-type)))
(for-each (lambda (id)
(package-define! base-package
id
syntax-type
#f
(get-operator id syntax-type)))
'(if begin lambda letrec quote set!
define define-syntax let-syntax
goto real-external))) ; special for Prescheme
; Add the usual macros.
(let ((syntax-type (structure-ref meta-types syntax-type)))
(for-each (lambda (name)
(package-define! base-package
name
syntax-type
#f
(make-transform
(usual-transform name)
base-package
(structure-ref meta-types syntax-type)
`(usual-transform ',name)
name)))
'(and cond do let let* or quasiquote syntax-rules))) ; delay
; Plus whatever primitives are wanted.
(define (define-prescheme! name location static)
(package-define! base-package
name
(structure-ref meta-types usual-variable-type)
location
static))
; Copy over the enumeration macros and the ERRORS enumeration.
(define (import-syntax! package-id name)
(let ((config ((structure-ref package-commands-internal config-package)))
(syntax-type (structure-ref meta-types syntax-type)))
(let ((binding (structure-lookup (environment-ref config package-id)
name
#t)))
(package-define! base-package
name
syntax-type
(binding-place binding)
(binding-static binding)))))
(import-syntax! 'enumerated 'define-enumeration)
(import-syntax! 'enumerated 'enum)
(import-syntax! 'enumerated 'name->enumerand)
(import-syntax! 'enumerated 'enumerand->name)
(import-syntax! 'prescheme 'errors)
(import-syntax! 'prescheme 'define-external-enumeration)
; define still more syntax
(load "prescheme/ps-syntax.scm" base-package)
(eval '(define-syntax define-record-type expand-define-record-type)
base-package)
;----------------------------------------------------------------
; Make the Pre-Scheme structure and related structures
(define (get-interface name)
(environment-ref ((structure-ref package-commands-internal config-package))
name))
(define prescheme
(make-structure base-package
(lambda () (get-interface 'prescheme-interface))
'prescheme))
(define ps-memory
(make-structure base-package
(lambda () (get-interface 'ps-memory-interface))
'ps-memory))
(define ps-receive
(make-structure base-package
(lambda () (get-interface 'ps-receive-interface))
'ps-receive))
(define ps-record-types
(make-structure base-package
(lambda () (export (define-record-type :syntax)))
'ps-record-types))
; and a handy environment
(define prescheme-compiler-env
(package->environment base-package))

296
ps-compiler/prescheme/merge.scm
View File

@ -1,296 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; This code determines which procedures are called from one other form, and
; thus can be compiled as part of that form and called with a `goto' instead
; of a normal procedure call. This saves much of the overhead of a normal
; procedure call.
;
; The procedures to be merged are annotated; no code is changed.
(define-subrecord form form-merge form-merge
((head) ; self or the form into which this one will be merged
)
(
(status #f) ; one of #F, DO-NOT-MERGE, MERGED
tail-clients ; forms that call this one tail-recursively, this is an
; a-list of forms and reference nodes
(tail-providers '()) ; forms that are used by this one, this is a simple list
(merged '()) ; forms merged with this one
(return-count 0) ; how many returns have been generated so far
temp ; handy utility field
))
; Two procedures for letting the user know what is going on.
(define (show-merges form)
(let ((merges (form-merged form)))
(if (not (null? merges))
(format #t " ~S: ~S~%" (form-name form) (map form-name merges)))))
(define (show-providers form)
(cond ((eq? (form-type form) 'lambda)
(format #t "~S ~A~%"
(form-name form)
(if (form-exported? form) " (exported)" ""))
(cond ((or (not (null? (form-providers form)))
(not (null? (form-tail-providers form))))
(format #t " ~S~% ~S~%"
(map form-name (form-providers form))
(map form-name (form-tail-providers form))))))))
; Note that OTHERS should be merged with FORM.
(define (do-merge form others)
(let ((form (form-head form))
(secondary (apply append (map form-merged others))))
(set-form-merged! form (append others
secondary
(form-merged form)))
(for-each (lambda (f)
(set-form-head! f form))
secondary)
(for-each (lambda (f)
(set-form-head! f form)
(set-form-status! f 'merged)
(set-form-type! f 'merged)
(set-form-merged! f '()))
others)))
; Returns the merged form, if any, to which NODE is a reference.
(define (merged-procedure-reference node)
(cond ((and (reference-node? node)
(maybe-variable->form (reference-variable node)))
=> (lambda (form)
(if (eq? 'merged (form-type form))
form
#f)))
(else #f)))
; Is FORM ever tail called?
(define (form-tail-called? form)
(and (or (eq? 'lambda (form-type form))
(eq? 'merged (form-type form)))
(memq? 'tail-called (variable-flags (form-var form)))))
; Annotate FORM if it is in fact called tail-recursively anywhere.
(define (note-tail-called-procedure form)
(if (and (eq? 'lambda (form-type form))
(or (any (lambda (r)
(used-as-label? r))
(variable-refs (form-var form)))
(eq? 'tail-called (lambda-protocol (form-value form)))))
(set-variable-flags! (form-var form)
(cons 'tail-called
(variable-flags (form-var form))))))
(define (used-as-label? node)
(and (node? (node-parent node))
(goto-call? (node-parent node))
(= 1 (node-index node))))
;------------------------------------------------------------
; Entry point.
;
; First marks the tail-called procedures and adds the MERGE slots to the
; forms. The C code generator expects FORM-MERGED to work, even if no
; actual merging was done.
;
; Three steps:
; Find the call graph.
; Merge the tail-called forms.
; Merge the non-tail-called forms.
(define *merge-forms?* #t)
(define (merge-forms forms)
(for-each (lambda (f)
(note-tail-called-procedure f)
(set-form-merge! f (form-merge-maker f))
(set-form-providers! f '()))
forms)
(if *merge-forms?*
(let ((mergable-forms (filter determine-merger-graph forms)))
(format #t "Call Graph:~%<procedure name>~%")
(format #t " <called non-tail-recursively>~%")
(format #t " <called tail-recursively>~%")
(for-each show-providers forms)
(format #t "Merging forms~%")
(receive (tail other)
(partition-list (lambda (f) (null? (form-clients f)))
mergable-forms)
(merge-tail-forms tail)
(for-each merge-non-tail-forms forms)
(for-each show-merges forms)
(values)))))
; The only forms that can be merged are those that:
; are lambdas,
; all uses are calls,
; are not exported, and
; every loop containing a non-tail-recursive call must contain a call to
; at least one non-merged procedure.
;
; This code doesn't use the last criterion. Instead it makes sure that each
; procedure is called exclusively tail-recursively or non-tail-recursively
; and doesn't allow non-tail-recursion in loops at all.
(define (determine-merger-graph form)
(cond ((and (eq? 'lambda (form-type form))
(really-determine-merger-graph form)
(not (form-exported? form))
(or (null? (form-clients form))
(null? (form-tail-clients form))))
#t)
(else
(set-form-status! form 'do-not-merge)
#f)))
; Loop down the references to FORM's variable adding FORM to the providers
; lists of the forms that reference the variable, and adding those forms
; to FORM's clients lists. OKAY? is #T if all references are calls.
; The full usage graph is needed, even if there are uses of the form's value
; that are not calls.
(define (really-determine-merger-graph form)
(let loop ((refs (variable-refs (form-var form)))
(clients '()) (tail-clients '()) (okay? #t))
(cond ((null? refs)
(set-form-clients! form clients)
(set-form-tail-clients! form tail-clients)
okay?)
(else
(let* ((r (car refs))
(f (node-form (car refs))))
(if (and (called-node? r)
(or (calls-this-primop? (node-parent r) 'tail-call)
(calls-this-primop? (node-parent r) 'unknown-tail-call)))
(loop (cdr refs)
clients
(add-to-client-list tail-clients r form f
form-tail-providers
set-form-tail-providers!)
okay?)
(loop (cdr refs)
(add-to-client-list clients r form f
form-providers
set-form-providers!)
tail-clients
(and okay? (called-node? r)))))))))
(define (add-to-client-list client-list ref form f getter setter)
(cond ((assq f client-list)
=> (lambda (p)
(set-cdr! p (cons ref (cdr p)))
client-list))
(else
(setter f (cons form (getter f)))
(cons (list f ref) client-list))))
; These forms are non-exported procedures that are always tail-called.
; Strongly connected components of the call graph that have a single
; entry point, whether in the component or not, are merged.
; This depends on STRONGLY-CONNECTED-COMPONENTS returning the components
; in a reverse topologically sorted order (which it does).
(define (merge-tail-forms forms)
(for-each merge-tail-loop
(reverse (strongly-connected-components
forms
(lambda (f)
(filter (lambda (f) (memq? f forms))
(map car (form-tail-clients f))))
form-temp
set-form-temp!))))
; ENTRIES are the forms in the loop that are called from outside.
; FORMS is used as a unique identifier here.
(define (merge-tail-loop forms)
(for-each (lambda (f) (set-form-temp! f forms)) forms)
(receive (entries other)
(partition-list (lambda (f)
(any? (lambda (p)
(not (eq? forms
(form-temp (car p)))))
(form-tail-clients f)))
forms)
(cond ((single-outside-client (if (null? entries)
other
entries)
forms)
=> (lambda (f) (do-merge f forms)))
((and (not (null? entries))
(null? (cdr entries))
(not (null? other)))
(do-merge (car entries) other)))
(for-each (lambda (f) (set-form-temp! f #f)) forms)))
; This checks to see if all non-FLAGged clients of ENTRIES are in
; fact a single form, and then returns that form.
; Forms that have already been merged into another form are treated as that
; other form (by using FORM-HEAD).
(define (single-outside-client entries flag)
(let loop ((entries entries) (form #f))
(if (null? entries)
form
(let loop2 ((clients (form-tail-clients (car entries))) (form form))
(cond ((null? clients)
(loop (cdr entries) form))
((eq? (form-temp (caar clients)) flag)
(loop2 (cdr clients) form))
((not form)
(loop2 (cdr clients) (form-head (caar clients))))
((eq? (form-head (caar clients)) form)
(loop2 (cdr clients) form))
(else
#f))))))
; Merge the forms used by FORM into it if possible.
(define (merge-non-tail-forms form)
(for-each (lambda (f)
(maybe-merge-non-tail-form f (form-head form)))
(form-providers form)))
; If FORM is not INTO, has not been merged before, and is only used by
; INTO, then merge FORM into INTO and recursively check the forms used
; by FORM.
(define (maybe-merge-non-tail-form form into)
(cond ((and (not (eq? form into))
(not (form-status form))
(every? (lambda (p)
(eq? (form-head (car p)) into))
(form-clients form)))
(do-merge into (list form))
(for-each tail-call->call
(variable-refs (form-var form)))
(for-each tail-call->call
(variable-refs (car (lambda-variables (form-node form)))))
(for-each (lambda (f)
(maybe-merge-non-tail-form f into))
(form-providers form)))))
; Replace tail calls with calls to make the code generator's job easier.
; The user didn't say that these calls had to be tail-recursive.
(define (tail-call->call ref)
(let ((call (node-parent ref)))
(if (or (calls-this-primop? call 'tail-call)
(calls-this-primop? call 'unknown-tail-call))
(let ((type (arrow-type-result (node-type (call-arg call 1)))))
(move (call-arg call 0)
(lambda (cont)
(let-nodes ((new-cont ((v type)) (return 0 cont (* v))))
new-cont)))
(set-call-exits! call 1)
(set-call-primop! call
(get-primop (if (calls-this-primop? call 'tail-call)
(enum primop call)
(enum primop unknown-call))))))))

78
ps-compiler/prescheme/node-type.scm
View File

@ -1,78 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Types and nodes together
; Instantiate TYPE and replace the types in NODE with their corresponding
; value. LOCATION is where NODE will be applied, and is used to get the actual
; types of the arguments.
(define (instantiate-type&value type node location)
(let ((has (instantiate-type-scheme type
-1
(lambda () (fix-types node))))
(wants (call->proc-type (node-parent location))))
(identity (unify! has wants 'simplifying))))
; (format #t "~%Reconstructing ")
; (pp-cps call)
; (format #t " has ~S~% wants ~S~%"
; (instantiate has)
; (instantiate wants))
; (breakpoint "reconstructing ~S" call)
; (unify! has wants 'simplifying)
; This is used to replace all references in NODE to polymorphic type variables
; with the current value of the type variable.
; Youch! Very inefficient - may make many copies of the same type.
(define (fix-types node)
(let label ((node node))
(case (node-variant node)
((lambda)
(for-each fix-variable (lambda-variables node))
(label (lambda-body node)))
((call)
(walk-vector label (call-args node)))
((literal)
(let ((value (literal-value node)))
(if (or (uvar? value)
(other-type? value))
(set-literal-value! node (copy-type value))))))))
(define (fix-variable var)
(set-variable-type! var (copy-type (variable-type var))))
(define (call->proc-type call)
(let ((end (if (or (calls-this-primop? call 'call)
(calls-this-primop? call 'tail-call))
2 ; no protocol to ignore
3))) ; protocol to ignore
(make-arrow-type (do ((i (- (vector-length (call-args call)) 1) (- i 1))
(ts '() (cons (maybe-instantiate
(node-type (call-arg call i)))
ts)))
((< i end)
ts))
(let ((cont (call-arg call 0)))
(if (reference-node? cont)
(variable-type (reference-variable cont))
(make-tuple-type (map variable-type
(lambda-variables cont))))))))
(define (maybe-instantiate type)
(if (type-scheme? type)
(instantiate-type-scheme type -1)
type))
(define (make-monomorphic! var)
(let ((type (type-scheme-type (variable-type var))))
(for-each (lambda (ref)
(if (not (called-node? ref))
(error
"polymorphic procedure ~S used as value, cannot be made monomorphic"
(variable-name var))
(unify! type
(call->proc-type (node-parent ref))
'make-monomorphic!)))
(variable-refs var))
(set-variable-type! var type)))

310
ps-compiler/prescheme/package-defs.scm
View File

@ -1,310 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Pre-Scheme packages
; Everything else
(define-structures ((prescheme-compiler (export)))
(open scheme big-scheme conditions comp-util structure-refs
prescheme-front-end prescheme-display
parameters
node
front-debug forms
ps-types
type-variables
c
structure-refs
primop-data
c-primop-data
jump ;find-jump-procs procs->jumps
record-types ;reset-record-data!
node-types
front ;simplify-all
simplify) ;simplify-node
(files top))
(define-structures ((prescheme-display (export display-forms-as-scheme)))
(open scheme big-scheme
structure-refs
names
bindings ;binding-place
nodes
variable primop external-values ps-primitives
flatten-internal ;generated-top-variable?
external-constants)
(access forms) ;form-value form-var
(files display))
(define-structures ((protocol (export normal-protocol
goto-protocol
goto-protocol?)))
(open scheme big-scheme comp-util set-parameters ps-primops ps-types node)
(files spec))
(define-structures ((prescheme-front-end (export prescheme-front-end)))
(open scheme big-scheme comp-util structure-refs
linking expand flatten forms
ps-types inference
variable
primitive-data
primop-data
inference-internal ; unify!
type-variables) ; reset-type-vars!
(access nodes ; node? schemify
node ; reset-node-id
record-types) ; reset-record-types!
(files front-end))
(define-structures ((forms form-interface))
(open scheme big-scheme comp-util node expand defrecord
node-vector queues to-cps
structure-refs
eval-node ; closure stuff
ps-primops ; get-prescheme-primop
simplify-internal ; simplify-node simplify-args
front ; simplify-all
ps-types ; type/undetermined
type-variables ; maybe-follow-uvar
node-types) ; instantiate-type&value
(access nodes) ; node-predicate
(files form))
; Translating Scheme into evaluated nodes
(define-structures ((expand (export scan-packages)))
(open scheme big-scheme comp-util structure-refs
variable
bindings nodes
ps-primitives ;eval-primitive
eval-node ;eval-node
scan-package ;package-source
locations
util ;fold
syntactic)
(access packages) ;package->environment
(files expand))
; Eval and type information on Pre-Scheme primitives
(define-structures ((ps-primitives (export primitive?
make-primitive
eval-primitive
primitive-id
primitive-source
primitive-expander
primitive-expands-in-place?
primitive-inference-rule)))
(open scheme big-scheme comp-util defrecord)
(files primitive))
(define-structures ((primitive-data (export)))
(open scheme big-scheme comp-util ps-primitives
bindings nodes
ascii structure-refs
ps-primops ;get-prescheme-primop
linking ;define-prescheme!
inference-internal ;check-arg-type
type-variables ;make-arith-op-uvar
record-types
prescheme ps-memory
ps-types external-constants external-values
locations
eval-node) ; closure? (to keep them from being made immutable)
(access variable) ; variable-name
(files (primop scm-scheme)
(primop scm-arith)
(primop scm-memory)
(primop scm-record)))
(define-structures ((eval-node (export eval-node
closure? closure-node closure-env
make-top-level-closure
closure-temp set-closure-temp!
apply-closure
unspecific? constant?)))
(open scheme define-record-types
nodes
ps-types ;expand-type-spec
external-values
external-constants ;external-constant?
signals ;error
util) ;unspecific
(files eval))
; Reducing closures and data structures to simple definitions
(define-structures ((flatten (export flatten-definitions))
(flatten-internal (export generated-top-variable?)))
(open scheme big-scheme comp-util defrecord
structure-refs
bindings nodes
variable
eval-node ;closure stuff, constant?
ps-primitives ;primitive stuff
ps-types ;type/undetermined expand-type-spec
linking ;prescheme-compiler-env
syntactic ;expand
strong
external-values
locations
features) ;immutable?
(access forms) ;avoid name conflict with NODE-FORM in nodes
(files flatten substitute))
(define-structures ((to-cps (export x->cps)))
(open scheme big-scheme comp-util
variable
names bindings nodes
primop
structure-refs
cps-util enumerated
ps-primops ;get-prescheme-primop
ps-types ;type/unknown
inference ;node-type lambda-node-return-type
ps-primitives ;primitive-expander
protocol) ;goto-protocol normal-protocol
(access node)
(files to-cps))
; Processing interface and package definitions
(define-structures ((linking linking-interface))
(open scheme big-scheme structure-refs comp-util
interfaces packages environments usual-macros
defpackage types ;for making interfaces
reflective-tower-maker
fluids
expand-define-record-type
scan-package ;collect-packages
bindings ;binding? binding-place
nodes ;get-operator
transforms ;make-transform
locations) ;contents
(access meta-types ;syntax-type usual-variable-type
variable ;make-global-variable
ps-types ;type/unknown
reading-forms ;$note-file-package
packages-internal ;$get-location
package-commands-internal ;config-package
prescheme ;we need this loaded
built-in-structures) ;defpackage structure-refs
(files linking))
;----------------------------------------------------------------
; Types and type inference
(define-structures ((ps-types ps-type-interface)
(type-variables type-variable-interface)
(record-types record-type-interface)
(expand-define-record-type
(export expand-define-record-type)))
(open scheme big-scheme comp-util defrecord)
(files type
type-scheme
type-var
record))
(define-structures ((inference inference-interface)
(inference-internal inference-internal-interface))
(open scheme big-scheme front variable comp-util transitive
ps-types type-variables
bindings nodes
structure-refs
ps-primitives
ps-primops ; get-prescheme-primop
external-values external-constants
locations) ; for imported constants
(access eval-node) ; unspecific?
(for-syntax (open scheme big-scheme))
(files inference infer-early))
(define-structures ((node-types (export instantiate-type&value
make-monomorphic!)))
(open scheme big-scheme front node comp-util
ps-types type-variables
inference-internal) ; unify!
(files node-type))
;----------------------------------------------------------------
; Primops
(define-structures ((ps-primops ps-primop-interface))
(open scheme big-scheme comp-util node simplify-internal
linking ps-types front expand)
(files (primop primop)))
(define-structures ((ps-c-primops ps-c-primop-interface))
(open scheme big-scheme comp-util node simplify-internal
define-record-types
ps-types ps-primops)
(for-syntax (open scheme big-scheme))
(files (primop c-primop)))
(define-structures ((primop-data (export)))
(open scheme big-scheme comp-util node simplify-internal simplify-let
front expand type-variables inference-internal
ps-types ps-primops record-types
parameters node-vector
node-types) ; instantiate-type&value
(files (primop base)
(primop arith)
(primop io)
(primop vector)
))
(define-structures ((c-primop-data (export)))
(open scheme big-scheme comp-util node simplify
ps-types ps-primops ps-c-primops
front
structure-refs
c-internal
ps-types type-variables inference-internal
inference ; get-variable-type
forms byte-vectors
record-types
eval-node) ; unspecific?
(access ps-primitives prescheme)
(files (primop c-base)
(primop c-arith)
(primop c-io)
(primop c-vector)
))
(define-structures ((external-values (export external-value?
make-external-value
external-value-type
external-value-string)))
(open scheme define-record-types)
(begin
(define-record-type external-value :external-value
(make-external-value string type)
external-value?
(string external-value-string)
(type external-value-type))))
;----------------------------------------------------------------
; Translating to C
(define-structures ((c (export write-c-file hoist-nested-procedures))
(c-internal c-internal-interface))
(open scheme big-scheme comp-util strongly-connected node forms
defrecord
ps-primops ps-c-primops
ps-types type-variables
flatten-internal ; generated-top-variable?
inference ; get-variable-type
inference-internal ; literal-value-type
protocol ; goto-protocol?
i/o ; force-output
record-types
external-values
external-constants
eval-node) ; unspecific?
(begin (define number-of-char-codes 256)) ; should be somewhere else
(files c
c-decl
c-call
hoist
merge))

46
ps-compiler/prescheme/primitive.scm
View File

@ -1,46 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Eval'ing and type-checking code for primitives.
(define-record-type primitive
(id ; for debugging & making tables
arg-predicates ; predicates for checking argument types
eval ; evaluation function
source ; close-compiled source (if any)
expander ; convert call to one using primops
expands-in-place? ; does the expander expand the definition in-line?
inference-rule ; type inference rule
)
())
(define make-primitive primitive-maker)
(define-record-discloser type/primitive
(lambda (primitive)
(list 'primitive (primitive-id primitive))))
(define (eval-primitive primitive args)
(cond ((not (primitive? primitive))
(user-error "error while evaluating: ~A is not a procedure" primitive))
((args-okay? args (primitive-arg-predicates primitive))
(apply (primitive-eval primitive) args))
(else
(user-error "error while evaluating: type error ~A"
(cons (primitive-id primitive) args)))))
; PREDICATES is a (possibly improper) list of predicates that should match
; ARGS.
(define (args-okay? args predicates)
(cond ((atom? predicates)
(if predicates
(every? predicates args)
#t))
((null? args)
#f)
((car predicates)
(and ((car predicates) (car args))
(args-okay? (cdr args) (cdr predicates))))
(else
(args-okay? (cdr args) (cdr predicates)))))

250
ps-compiler/prescheme/primop/arith.scm
View File

@ -1,250 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define (put-literal-first call)
(if (and (not (literal-node? (call-arg call 0)))
(literal-node? (call-arg call 1)))
(let ((arg1 (detach (call-arg call 0)))
(arg0 (detach (call-arg call 1))))
(attach call 0 arg0)
(attach call 1 arg1))))
(define (simplify-add call)
(simplify-args call 0)
(put-literal-first call)
((pattern-simplifier
((+ '0 x) x)
((+ 'a 'b) '(+ a b))
((+ 'a (+ 'b x)) (+ x '(+ a b)))
((+ 'a (- x 'b)) (+ x '(- a b))) ; no overflow in Scheme, but what
((+ 'a (- 'b x)) (- '(+ a b) x)) ; about PreScheme? Could check the
((+ (+ 'a x) (+ 'b y)) (+ '(+ a b) (+ x y)))
((+ x (+ 'a y)) (+ 'a (+ x y))))
call)) ; result of the literal. Maybe these
; should be left out.
(define-scheme-primop + #f type/integer simplify-add)
(define (simplify-subtract call)
(simplify-args call 0)
((pattern-simplifier
((- 'a 'b) '(- a b))
((- x 'a) (+ '(- 0 a) x))
((- 'a (+ 'b x)) (- '(- a b) x)) ; more overflow problems
((- 'a (- 'b x)) (+ x '(- a b)))
((- x (+ 'a y)) (+ '(- 0 a) (- x y)))
; ((- (+ 'a x) y) (+ 'a (- x y))) hmm - need to come up with a normal form
((- (+ 'a x) (+ 'b y)) (- (+ '(- a b) x) y)))
call))
(define-scheme-primop - #f type/integer simplify-subtract)
; This should check for multiply by powers of 2 (other constants can be
; done later).
(define (simplify-multiply call)
(simplify-args call 0)
(put-literal-first call)
(cond ((power-of-two-literal (call-arg call 0))
=> (lambda (i)
(set-call-primop! call (get-prescheme-primop 'ashl))
(replace (call-arg call 0) (detach (call-arg call 1)))
(attach call 1 (make-literal-node i type/unknown))))
(else
((pattern-simplifier
((* '0 x) '0)
((* '1 x) x)
((* 'a 'b) '(* a b))
((* 'a (* x 'b)) (* x '(* a b)))
((* 'a (* 'b x)) (* x '(* a b))))
call))))
(define-scheme-primop * #f type/integer simplify-multiply)
(define-scheme-primop small* #f type/integer simplify-multiply)
(define (simplify-quotient call)
(simplify-args call 0)
(cond ;((power-of-two-literal (call-arg call 1))
; => (lambda (i)
; (set-call-primop! call (get-prescheme-primop 'ashr))
; (replace (call-arg call 1) (make-literal-node i type/unknown))))
(else
((pattern-simplifier
((quotient x '0) '((lambda ()
(error "program divides by zero"))))
((quotient x '1) x)
((quotient '0 x) '0)
((quotient 'a 'b) '(quotient a b)))
call))))
(define (power-of-two-literal node)
(if (not (literal-node? node))
#f
(let ((value (literal-value node)))
(if (not (and (integer? value)
(<= 1 value)))
#f
(do ((v value (arithmetic-shift v -1))
(i 0 (+ i 1)))
((odd? v)
(if (= v 1) i #f)))))))
(define-scheme-primop quotient exception type/integer simplify-quotient)
(define-scheme-primop remainder exception type/integer)
(define (simplify-ashl call)
(simplify-args call 0)
((pattern-simplifier
((ashl '0 x) '0)
((ashl x '0) x)
((ashl 'a 'b) '(arithmetic-shift a b))
((ashl (ashl x 'a) 'b) (ashl x '(+ a b)))
((ashl (ashr x 'a) 'b)
(<= a b) ; condition
(ashl (bitwise-and x '(bitwise-not (- (expt 2 a) 1))) '(- b a)))
((ashl (ashr x 'a) 'b)
(>= a b) ; condition
(bitwise-and (ashr x '(- a b)) '(bitwise-not (- (expt 2 b) 1))))
((ashl (+ 'a x) 'b) (+ (ashl x 'b) '(arithmetic-shift a b))))
call))
(define (simplify-ashr call)
(simplify-args call 0)
((pattern-simplifier
((ashr '0 x) '0)
((ashr x '0) x)
((ashr 'a 'b) '(arithmetic-shift a (- b)))
((ashr (ashr x 'a) 'b) (ashr x '(+ a b))))
call))
(define (simplify-lshr call)
(simplify-args call 0)
((pattern-simplifier
((lshr '0 x) '0)
((lshr x '0) x)
((lshr 'a 'b) '(lshr a (- b)))
((lshr (lshr x 'a) 'b) (lshr x '(+ a b)))
((ashr (lshr x 'a) 'b) (lshr x '(+ a b)))) ; depends on shifts by zero
; having been constant folded
call))
(define-scheme-primop ashl #f type/integer simplify-ashl)
(define-scheme-primop ashr #f type/integer simplify-ashr)
(define-scheme-primop lshr #f type/integer simplify-lshr)
(define (simplify-bitwise-and call)
(simplify-args call 0)
(put-literal-first call)
((pattern-simplifier
((bitwise-and '0 x) '0)
((bitwise-and '-1 x) x)
((bitwise-and 'a 'b) '(bitwise-and a b)))
call))
(define (simplify-bitwise-ior call)
(simplify-args call 0)
(put-literal-first call)
((pattern-simplifier
((bitwise-ior '0 x) x)
((bitwise-ior '-1 x) '-1)
((bitwise-ior 'a 'b) '(bitwise-ior a b)))
call))
(define (simplify-bitwise-xor call)
(simplify-args call 0)
(put-literal-first call)
((pattern-simplifier
((bitwise-xor '0 x) x)
((bitwise-xor 'a 'b) '(bitwise-xor a b)))
call))
(define (simplify-bitwise-not call)
(simplify-args call 0)
((pattern-simplifier
((bitwise-not 'a) '(bitwise-not a)))
call))
(define-scheme-primop bitwise-and #f type/integer simplify-bitwise-and)
(define-scheme-primop bitwise-ior #f type/integer simplify-bitwise-ior)
(define-scheme-primop bitwise-xor #f type/integer simplify-bitwise-xor)
(define-scheme-primop bitwise-not #f type/integer simplify-bitwise-not)
(define (simplify-= call)
(simplify-args call 0)
(put-literal-first call)
((pattern-simplifier
((= 'a 'b) '(= a b))
((= 'a (+ 'b c)) (= '(- a b) c)) ; will these ever be used?
((= 'a (- 'b c)) (= '(- b a) c)))
call))
(define (simplify-< call)
(simplify-args call 0)
((pattern-simplifier
((< 'a 'b) '(< a b))
((< 'a (+ 'b c)) (< '(- a b) c)) ; will these ever be used?
((< (+ 'b c) 'a) (< c '(- a b)))
((< 'a (- 'b c)) (< c '(- b a)))
((< (- 'b c) 'a) (< '(- b a) c)))
call))
(define (simplify-char=? call)
(simplify-args call 0)
(put-literal-first call)
((pattern-simplifier
((char=? 'a 'b) '(char=? a b))
((char=? 'a (+ 'b c)) (char=? '(- a b) c))
((char=? 'a (- 'b c)) (char=? '(- b a) c)))
call))
(define (simplify-char<? call)
(simplify-args call 0)
((pattern-simplifier
((char<? 'a 'b) '(char<? a b))
((char<? 'a (+ 'b c)) (char<? '(- a b) c))
((char<? (+ 'b c) 'a) (char<? c '(- a b)))
((char<? 'a (- 'b c)) (char<? c '(- b a)))
((char<? (- 'b c) 'a) (char<? '(- b a) c)))
call))
(define bool-type
(lambda (call)
type/boolean))
(define-scheme-primop = #f bool-type simplify-=)
(define-scheme-primop < #f bool-type simplify-<)
(define-scheme-primop char=? #f bool-type simplify-char=?)
(define-scheme-primop char<? #f bool-type simplify-char<?)
(define (simplify-char->ascii call)
(simplify-args call 0)
(let ((arg (call-arg call 0)))
(if (literal-node? arg)
(let ((value (literal-value arg)))
(if (char? value)
(replace call (make-literal-node (char->ascii value) #f))
(breakpoint "char->ascii is applied to a non-character literal ~S"
value))))))
(define (simplify-ascii->char call)
(simplify-args call 0)
(let ((arg (call-arg call 0)))
(if (literal-node? arg)
(let ((value (literal-value arg)))
(if (integer? value)
(replace call (make-literal-node (ascii->char value) #f))
(breakpoint "ascii->char is applied to a non-integer literal ~S"
value))))))
(define-scheme-primop char->ascii #f type/integer simplify-char->ascii)
(define-scheme-primop ascii->char #f type/integer simplify-ascii->char)
;(define (simplify-sign-extend call)
; (simplify-args call 0)
; (let ((value (call-arg call 0)))
; (cond ((literal-node? value)
; (set-literal-type! value type/integer)
; (replace call (detach value))))))
;
;(define-scheme-primop sign-extend #f type/integer simplify-sign-extend)
;(define-scheme-primop zero-extend #f type/integer simplify-sign-extend)

159
ps-compiler/prescheme/primop/base.scm
View File

@ -1,159 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define (simplify-letrec1 call)
(let* ((cont (call-arg call 0))
(next (lambda-body cont))
(var (car (lambda-variables cont))))
(if (not (and (calls-this-primop? next 'letrec2)
(= 1 (length (variable-refs var)))
(eq? next (node-parent (car (variable-refs var))))
(= 1 (node-index (car (variable-refs var))))))
(error "badly formed LETREC ~S ~S" call (node-parent call)))
(simplify-args call 0)
(check-letrec-scoping call cont next)
(if (every? unused? (cdr (lambda-variables cont)))
(replace-body call (detach-body (lambda-body (call-arg next 0)))))))
(define (check-letrec-scoping letrec1 binder letrec2)
(let ((values (sub-vector->list (call-args letrec2) 2))
(body (call-arg letrec2 0)))
(for-each (lambda (n) (set-node-flag! n 'okay)) values)
(set-node-flag! body 'okay)
(for-each (lambda (var)
(for-each (lambda (ref)
(set-node-flag! (marked-ancestor ref) 'lose))
(variable-refs var)))
(cdr (lambda-variables binder)))
(let ((non-recur (filter (lambda (p)
(eq? (node-flag (car p)) 'okay))
(map cons values (cdr (lambda-variables binder))))))
(for-each (lambda (n) (set-node-flag! n #f)) values)
(set-node-flag! body #f)
(if (not (null? non-recur))
(letrec->let (map car non-recur)
(map cdr non-recur)
letrec1 binder letrec2)))))
(define (letrec->let vals vars letrec1 binder letrec2)
(for-each detach vals)
(remove-null-arguments letrec2
(- (vector-length (call-args letrec2))
(length vals)))
(set-lambda-variables!
binder
(filter (lambda (v) (not (memq v vars)))
(lambda-variables binder)))
(move-body letrec1
(lambda (letrec1)
(let-nodes ((call (let 1 l1 . vals))
(l1 vars letrec1))
call))))
; (return (lambda (a) ...) x)
; =>
; (let (lambda (a) ...) x)
(define (simplify-ps-return call)
(let ((cont (call-arg call 0))
(value (call-arg call 1)))
(cond ((not (lambda-node? cont))
(default-simplifier call))
(else
(set-call-primop! call (get-primop (enum primop let)))
(set-call-exits! call 1)
(set-node-simplified?! call #f)))))
(make-primop 'dispatch #f #f default-simplifier (lambda (call) 1) #f)
(make-primop 'let #f #f simplify-let (lambda (call) 1) #f)
(make-primop 'letrec1 #f #f (lambda (call)
(simplify-letrec1 call)) (lambda (call) 1) #f)
(make-primop 'letrec2 #f #f default-simplifier (lambda (call) 1) #f)
(make-primop 'undefined-value #t #f default-simplifier
(lambda (call) 1)
(lambda (call) type/null))
(make-primop 'undefined-effect #t #f default-simplifier
(lambda (call) 1)
(lambda (call) type/null))
(make-primop 'global-ref #t 'read default-simplifier
(lambda (call) 1)
(lambda (call)
(variable-type (reference-variable (call-arg call 0)))))
;(make-primop 'allocate #f #f 'allocate simplify-allocation (lambda (call) 1))
(make-primop 'global-set! #f 'write default-simplifier
(lambda (call) 1) #f)
(make-proc-primop 'call 'write simplify-known-call
(lambda (call) 1) 1)
(make-proc-primop 'tail-call 'write simplify-known-tail-call
(lambda (call) 1) 1)
(make-proc-primop 'return #f simplify-ps-return (lambda (call) 1) 0)
(make-proc-primop 'jump #f simplify-jump (lambda (call) 1) 0)
(make-proc-primop 'throw #f default-simplifier (lambda (call) 1) 0)
; This delays simplifying the arguments until we see if the procedure
; is a lambda-node.
(define (simplify-unknown-call call)
(simplify-arg call 1) ; simplify the procedure
(let ((proc (call-arg call 1)))
(cond ((lambda-node? proc)
(determine-lambda-protocol proc (list proc))
(mark-changed proc))
((and (reference-node? proc)
(variable-simplifier (reference-variable proc)))
=> (lambda (proc)
(proc call)))
(else
(simplify-args call 0))))) ; simplify all arguments
(make-proc-primop 'unknown-call 'write simplify-unknown-call
(lambda (call) 1) 1)
(make-proc-primop 'unknown-tail-call 'write simplify-unknown-call
(lambda (call) 1) 1)
(make-proc-primop 'unknown-return #f default-simplifier
(lambda (call) 1) 0)
(define (simplify-unspecific call)
(let ((node (make-undefined-literal)))
(set-literal-type! node type/null)
(replace call node)))
(define-scheme-primop unspecific #f type/null simplify-unspecific)
(define-scheme-primop uninitialized-value type/null)
(define-scheme-primop null-pointer? type/boolean)
(define-scheme-primop null-pointer type/boolean) ; type can't be right
(define-scheme-primop eq? type/boolean) ; should have a simplifier
;(define (exp->type exp)
; (if (quote-exp? exp)
; (real-exp->type (quote-exp-value exp))
; (error "can't turn ~S into a type" exp)))
;
;(define (real-exp->type exp)
; (let ((lose (lambda () (error "can't turn ~S into a type" exp))))
; (let label ((exp exp))
; (cond ((pair? exp)
; (case (car exp)
; ((pointer)
; (make-pointer-type (label (cadr exp))))
; ((arrow)
; (make-arrow-type (map label (cadr exp)) (caddr exp)))
; (else
; (lose))))
; ((and (symbol? exp)
; (lookup-type exp))
; => identity)
; (else
; (lose))))))
(define-scheme-cond-primop test simplify-test expand-test simplify-test?)
;(define-primitive-expander 'unspecific 0
; (lambda (source args cenv)
; (make-quote-exp the-undefined-value type/unknown)))

93
ps-compiler/prescheme/primop/c-arith.scm
View File

@ -1,93 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define-local-syntax (define-c-arith-binop-generator id c-op)
`(define-c-generator ,id #t
(lambda (call port indent)
(simple-c-primop ,c-op call port))))
(define-c-arith-binop-generator + "+")
(define-c-arith-binop-generator - "-")
(define-c-arith-binop-generator * "*")
(define-c-arith-binop-generator quotient "/")
(define-c-generator small* #t
(lambda (call port indent)
(format port "PS_SMALL_MULTIPLY(")
(c-value (call-arg call 0) port)
(format port ", ")
(c-value (call-arg call 1) port)
(format port ")")))
(define-c-arith-binop-generator remainder "%")
(define-c-arith-binop-generator bitwise-and "&")
(define-c-arith-binop-generator bitwise-ior "|")
(define-c-arith-binop-generator bitwise-xor "^")
(define-c-generator ashl #t
(lambda (call port indent)
(generate-shift call port indent "LEFT" "<<" #f)))
(define-c-generator ashr #t
(lambda (call port indent)
(generate-shift call port indent "RIGHT" ">>" #f)))
(define-c-generator lshr #t
(lambda (call port indent)
(generate-shift call port indent "RIGHT_LOGICAL" ">>" #t)))
(define (generate-shift call port indent macro c-op logical?)
(cond ((= 1 (call-exits call))
; PS_SHIFT_??? is a C macro that handles overshifting even if C doesn't
(indent-to port indent)
(format port "PS_SHIFT_~A(" macro)
(if logical? (format port "(unsigned long)"))
(c-value (call-arg call 1) port)
(format port ", ")
(c-value (call-arg call 2) port)
(format port ", ")
(c-variable (car (lambda-variables (call-arg call 0))) port)
(format port ")"))
((>= (literal-value (call-arg call 1)) prescheme-integer-size)
(format port "0L"))
(else
(if logical?
(format port "(long)(((unsigned long)")
(format port "(("))
(c-value (call-arg call 0) port)
(format port ")~A" c-op)
(c-value (call-arg call 1) port)
(format port ")"))))
(define-c-generator bitwise-not #t
(lambda (call port indent)
(simple-c-primop "~" call port)))
(define-local-syntax (define-c-comp-binop-generator id c-op)
`(define-c-generator ,id #t
(lambda (call port indent)
(simple-c-primop ,c-op call port))))
(define-c-comp-binop-generator = "==")
(define-c-comp-binop-generator < "<" )
(define-c-comp-binop-generator char=? "==")
(define-c-comp-binop-generator char<? "<" )
(define-c-generator ascii->char #t
(lambda (call port indent)
(c-value (call-arg call 0) port)))
(define-c-generator char->ascii #t
(lambda (call port indent)
(c-value (call-arg call 0) port)))
;(define-c-generator sign-extend #t
; (lambda (call port indent)
; (display "((long) " port)
; (c-value (call-arg call 0) port)
; (display ")" port)))
;
;(define-c-generator zero-extend #t
; (lambda (call port indent)
; (display "((unsigned long) " port)
; (c-value (call-arg call 0) port)
; (display ")" port)))

343
ps-compiler/prescheme/primop/c-base.scm
View File

@ -1,343 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define-c-generator let #f
(lambda (call port indent)
(let ((args (call-args call))
(vars (lambda-variables (call-arg call 0))))
(do ((i 1 (+ i 1))
(vars vars (cdr vars)))
((null? vars))
(let ((val (vector-ref args i)))
(if (not (lambda-node? val))
(c-assignment (car vars) val port indent)))))))
(define-c-generator letrec1 #f
(lambda (call port indent)
(values)))
(define-c-generator letrec2 #f
(lambda (call port indent)
(values)))
(define-c-generator jump #f
(lambda (call port indent)
(let ((proc (called-lambda call)))
(assign-argument-vars (lambda-variables proc) call 1 port indent)
(indent-to port indent)
(display "goto " port)
(writec port #\L)
(display (lambda-id proc) port)
(write-char #\; port)
(note-jump-generated! proc)
(values))))
(define (assign-argument-vars vars call start port indent)
(really-assign-argument-vars vars call start "arg" port indent))
(define (assign-merged-argument-vars vars call start port indent)
(really-assign-argument-vars vars call start "merged_arg" port indent))
(define (assign-global-argument-vars vars call start port indent)
(really-assign-argument-vars vars call start "goto_arg" port indent))
(define (really-assign-argument-vars vars call start name port indent)
(let ((args (call-args call)))
(do ((i start (+ i 1))
(vars vars (cdr vars)))
((>= i (vector-length args)))
(if (not (or (undefined-value-node? (vector-ref args i))
(eq? type/unit (get-variable-type (car vars)))))
(c-assignment (c-argument-var name
(get-variable-type (car vars))
(- i start)
port)
(vector-ref args i)
port indent)))))
; Calls
; Unknown calls have a first argument of 'goto if they are supposed to be
; tail-recursive. For known calls the protocol field of the lambda node
; is set to 'tail-called if any of the calls are supposed to be tail-recursive.
;
; Calls to non-tail-called procedures are just regular C calls. For tail-
; called procedures there are two kinds of calls:
; Tail-call from a tail-called procedure: proceed through the driver loop
; All others: start a driver loop
;
; Known and unknown calls are handled identically, except that known calls
; may be to merged procedures.
;
; Merged procedures with GOTO calls:
; This works if we merge the return points as well. Possibly there should be
; one return switch per C procedure. There do have to be separate return point
; variables (and one global one for the switch).
(define-c-generator call #f
(lambda (call port indent)
(cond ((merged-procedure-reference (call-arg call 1))
=> (lambda (form)
(generate-merged-call call 2 form port indent)))
(else
(generate-c-call call 2 port indent)))))
(define-c-generator tail-call #f
(lambda (call port indent)
(cond ((merged-procedure-reference (call-arg call 1))
=> (lambda (form)
(generate-merged-goto-call call 2 form port indent)))
(else
(generate-c-tail-call call 2 port indent)))))
(define-c-generator unknown-call #f
(lambda (call port indent)
(if (goto-protocol? (literal-value (call-arg call 2)))
(user-warning "ignoring GOTO declaration for non-tail-recursive call to"
(variable-name (reference-variable
(call-arg call 1)))))
(generate-c-call call 3 port indent)))
(define-c-generator unknown-tail-call #f
(lambda (call port indent)
(generate-c-tail-call call 3 port indent)))
(define (generate-merged-goto-call call start form port indent)
(let ((proc (form-value form)))
(assign-merged-argument-vars (cdr (lambda-variables proc))
call start
port indent)
(indent-to port indent)
(display "goto " port)
(display (form-c-name form) port)
(write-char #\; port)
(values)))
(define (generate-goto-call call start port indent)
(let ((proc (call-arg call 1)))
(if (not (global-reference? proc))
(bug "incorrect procedure in goto call ~S" call))
(assign-global-argument-vars (cdr (lambda-variables
(global-lambda
(reference-variable proc))))
call start
port indent)
; T is the marker for the tail-call version of the procedure
(indent-to port indent)
(display "return((long)T" port)
(c-value proc port)
(display ");" port)))
(define (global-lambda var)
(let ((form (maybe-variable->form var)))
(if (and form
(or (eq? 'lambda (form-type form))
(eq? 'merged (form-type form))))
(form-value form)
(bug "value of ~S, called using goto, is not a known procedure"
var))))
; C requires that we dereference all but calls to global functions.
; Calls to literals are macros that must take care of themselves.
(define (generate-c-call call start port indent)
(let ((vars (lambda-variables (call-arg call 0)))
(args (call-args call))
(proc (call-arg call 1)))
(if (and (global-reference? proc)
(memq? 'tail-called (variable-flags (reference-variable proc))))
(call-with-driver-loop call start port indent (car vars))
(let ((deref? (or (and (reference-node? proc)
(variable-binder (reference-variable proc)))
(call-node? proc))))
(c-assign-to-variable (car vars) port indent)
(if deref?
(display "(*" port))
(c-value proc port)
(if deref?
(writec port #\)))
(write-value+result-var-list args start (cdr vars) port)))
(writec port #\;)
(values)))
(define (generate-c-tail-call call start port indent)
(let ((proc (call-arg call 1))
(args (call-args call)))
(cond ((not (and (global-reference? proc)
(memq? 'tail-called
(variable-flags (reference-variable proc)))))
(indent-to port indent)
(display "return " port)
(c-value proc port)
(write-value-list-with-extras args start *extra-tail-call-args* port))
(*doing-tail-called-procedure?*
(generate-goto-call call start port indent))
(else
(call-with-driver-loop call start port indent #f)))
(writec port #\;)
(values)))
(define (global-reference? node)
(and (reference-node? node)
(global-variable? (reference-variable node))))
(define (call-with-driver-loop call start port indent result-var)
(let* ((proc-var (reference-variable (call-arg call 1)))
(vars (lambda-variables (global-lambda proc-var))))
(assign-global-argument-vars (cdr vars) call start port indent)
(if result-var
(c-assign-to-variable result-var port indent)
(begin
(indent-to port indent)
(display "return " port)))
(display "TTrun_machine((long)" port)
(display "T" port)
(write-c-identifier (variable-name proc-var) port)
(display ")" port)))
(define (generate-merged-call call start form port indent)
(let ((return-index (form-return-count form))
(name (form-c-name form))
(res (lambda-variables (call-arg call 0))))
(set-form-return-count! form (+ 1 return-index))
(assign-merged-argument-vars (cdr (lambda-variables (form-value form)))
call start port indent)
(indent-to port indent)
(format port "~A_return_tag = ~D;" name return-index)
(indent-to port indent)
(format port "goto ~A;" name)
(indent-to port (- indent 1))
(format port "~A_return_~S:" name return-index)
(do ((i 0 (+ i 1))
(res res (cdr res)))
((null? res))
(let ((var (car res)))
(cond ((and (used? var)
(let ((type (get-variable-type var)))
(and (not (eq? type type/unit))
(not (eq? type type/null)))))
(c-assign-to-variable var port indent)
(format port "~A~D_return_value;" name i)))))))
; Returns
(define-c-generator return #f
(lambda (call port indent)
(if *current-merged-procedure*
(generate-return-from-merged-call call 1 port indent)
(really-generate-c-return call 1 port indent))))
(define-c-generator unknown-return #f
(lambda (call port indent)
(cond (*doing-tail-called-procedure?*
(generate-return-from-tail-call call port indent))
(*current-merged-procedure*
(generate-return-from-merged-call call 1 port indent))
(else
(really-generate-c-return call 1 port indent)))))
(define (generate-return-from-tail-call call port indent)
(if (not (no-value-node? (call-arg call 1)))
(c-assignment "TTreturn_value" (call-arg call 1) port indent))
(indent-to port indent)
(display "return(0L);" port))
(define (generate-return-from-merged-call call start port indent)
(let ((name *current-merged-procedure*))
(do ((i start (+ i 1)))
((= i (call-arg-count call)))
(let ((arg (call-arg call i)))
(if (not (no-value-node? arg))
(c-assignment (format #f "~A~D_return_value" name (- i start))
arg port indent))))
(indent-to port indent)
(format port "goto ~A_return;" name)))
(define (really-generate-c-return call start port indent)
(do ((i (+ start 1) (+ i 1)))
((= i (call-arg-count call)))
(let ((arg (call-arg call i)))
(if (not (no-value-node? arg))
(begin
(indent-to port indent)
(format port "*TT~D = " (- (- i start) 1))
(c-value arg port)
(write-char #\; port)))))
(indent-to port indent)
(display "return" port)
(if (not (no-value-node? (call-arg call start)))
(begin
(write-char #\space port)
(c-value (call-arg call start) port)))
(display ";" port)
(values))
; Allocate
;(define-c-generator allocate #f
; (lambda (call port indent)
; (let ((cont (call-arg call 0))
; (size (call-arg call 1)))
; (c-assign-to-variable (car (lambda-variables cont)) port indent)
; (display "(long) malloc(" port)
; (c-value size port)
; (display "* sizeof(char));" port))))
(define-c-generator global-ref #t
(lambda (call port indent)
(c-value (call-arg call 0) port)))
(define-c-generator global-set! #f
(lambda (call port indent)
(let ((value (call-arg call 2)))
(if (not (and (literal-node? value)
(unspecific? (literal-value value))))
(c-assignment (reference-variable (call-arg call 1))
value
port indent)))))
; if (ARG1 OP ARG2) {
; cont1 }
; else {
; cont2 }
(define-c-generator test #f
(lambda (call port indent)
(destructure ((#(cont1 cont2 value) (call-args call)))
(generate-c-conditional-prelude port indent)
(c-value value port)
(generate-c-conditional-jumps cont1 cont2 port indent))))
(define (generate-c-conditional-prelude port indent)
(indent-to port indent)
(display "if " port)
(writec port #\())
(define (generate-c-conditional-jumps cont1 cont2 port indent)
(display ") {" port)
(write-c-block (lambda-body cont1) port (+ indent 2))
(newline port)
(indent-to port indent)
(display "else {" port)
(write-c-block (lambda-body cont2) port (+ indent 2)))
(define-c-generator unspecific #t
(lambda (call port indent)
(bug "generating code for undefined value ~S" call)))
(define-c-generator uninitialized-value #t
(lambda (call port indent)
(bug "generating code for uninitialized value ~S" call)))
(define-c-generator null-pointer? #t
(lambda (call port indent)
(display "NULL == " port)
(c-value (call-arg call 0) port)))
(define-c-generator null-pointer #t
(lambda (call port indent)
(display "NULL" port)))
(define-c-generator eq? #t
(lambda (call port indent)
(simple-c-primop "==" call port)))

169
ps-compiler/prescheme/primop/c-io.scm
View File

@ -1,169 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define (write-c-io-call call port name . args)
(format port name)
(writec port #\()
(for-each (lambda (arg)
(cond ((string? arg)
(format port arg))
((variable? arg)
(c-variable arg port))
(else
(c-value (call-arg call arg) port))))
args)
(writec port #\)))
; stdin, stdout, and stderr cannot be variables because they may be macros in C.
(define-c-generator stdin #t
(lambda (call port indent)
(format port "stdin")))
(define-c-generator stdout #t
(lambda (call port indent)
(format port "stdout")))
(define-c-generator stderr #t
(lambda (call port indent)
(format port "stderr")))
; char eof? status
(define-c-generator read-char #f
(lambda (call port indent)
(indent-to port indent)
(let ((vars (lambda-variables (call-arg call 0))))
(write-c-io-call call port "PS_READ_CHAR" 1 ", "
(car vars) ", " (cadr vars) ", " (caddr vars)))))
(define-c-generator peek-char #f
(lambda (call port indent)
(indent-to port indent)
(let ((vars (lambda-variables (call-arg call 0))))
(write-c-io-call call port "PS_PEEK_CHAR" 1 ", "
(car vars) ", " (cadr vars) ", " (caddr vars)))))
(define-c-generator read-integer #f
(lambda (call port indent)
(indent-to port indent)
(let ((vars (lambda-variables (call-arg call 0))))
(write-c-io-call call port "PS_READ_INTEGER" 1 ", "
(car vars) ", " (cadr vars) ", " (caddr vars)))))
(define-c-generator write-char #f
(lambda (call port indent)
(indent-to port indent)
(let ((vars (lambda-variables (call-arg call 0))))
(if (used? (car vars))
(write-c-io-call call port "PS_WRITE_CHAR" 1 ", " 2 ", " (car vars))
(begin
(display "{ long ignoreXX;" port)
(indent-to port indent)
(write-c-io-call call port "PS_WRITE_CHAR" 1 ", " 2 ", ignoreXX")
(display " }" port))))))
(define-c-generator write-string #t
(lambda (call port indent)
(write-c-io-call call port "ps_write_string" 0 ", " 1)))
(define-c-generator write-integer #t
(lambda (call port indent)
(write-c-io-call call port "ps_write_integer" 0 ", " 1)))
(define-c-generator force-output #t
(lambda (call port indent)
(write-c-io-call call port "ps_flush" 0)))
(define-c-generator read-block #f
(lambda (call port indent)
(let ((vars (lambda-variables (call-arg call 0))))
(c-assign-to-variable (car vars) port indent)
(write-c-io-call call port "ps_read_block" 1 ", ((char *) " 2 "), " 3
", &" (cadr vars) ", &" (caddr vars))
(write-char #\; port))))
(define-c-generator write-block #t
(lambda (call port indent)
(write-c-io-call call port "ps_write_block" 0 ", ((char *) " 1 ")"
", " 2)))
; (read-block (lambda (okay? eof? got) ...) port buffer count)
;
;(define-c-generator read-block #f
; (lambda (call port indent)
; (let* ((cont (call-arg call 0))
; (vars (lambda-variables cont)))
; ;; got = ps_read(port, buffer, count, &okay?, &eof?);
; (c-assign-to-variable (caddr vars) port indent)
; (write-c-io-call call port
; "ps_read" 1 ", (void *)" 2 ", " 3 ", &" (car vars)
; ", &" (cadr vars))
; (write-char #\; port))))
;
;; (write-block (lambda (okay? sent) ...) port buffer count)
;
;(define-c-generator write-block #f
; (lambda (call port indent)
; (let* ((cont (call-arg call 0))
; (vars (lambda-variables cont)))
; ;; sent = ps_write(port, buffer, count, &okay?);
; (c-assign-to-variable (cadr vars) port indent)
; (write-c-io-call call port
; "ps_write" 1 ", (void *)" 2 ", " 3 ", &" (car vars))
; (write-char #\; port))))
(define-c-generator open-input-file #f
(lambda (call port indent)
(let ((vars (lambda-variables (call-arg call 0))))
(c-assign-to-variable (car vars) port indent)
(write-c-io-call call port "ps_open_input_file" 1 ", &" (cadr vars))
(write-char #\; port))))
(define-c-generator open-output-file #f
(lambda (call port indent)
(let ((vars (lambda-variables (call-arg call 0))))
(c-assign-to-variable (car vars) port indent)
(write-c-io-call call port "ps_open_output_file" 1 ", &" (cadr vars))
(write-char #\; port))))
(define-c-generator close-input-port #t
(lambda (call port indent)
(write-c-io-call call port "ps_close" 0)))
(define-c-generator close-output-port #t
(lambda (call port indent)
(write-c-io-call call port "ps_close" 0)))
(define-c-generator abort #t
(lambda (call port indent)
(format port "(exit -1)")))
(define-c-generator error #f
(lambda (call port indent)
(indent-to port indent)
(format port "ps_error(")
(c-value (call-arg call 1) port)
(format port ", ~D" (- (call-arg-count call) 2))
(do ((i 2 (+ i 1)))
((= i (call-arg-count call)))
(format port ", ")
(c-value (call-arg call i) port))
(format port ");")))
(define-c-generator error-string #t
(lambda (call port indent)
(write-c-io-call call port "ps_error_string" 0)))
; (c-e-v <proc> <nargs> <pointer-to-args>)
(define-c-generator call-external-value #t
(lambda (call port indent)
(format port "((long(*)())")
(c-value (call-arg call 0) port)
(format port ")(")
(c-value (call-arg call 1) port)
(format port ", ")
(c-value (call-arg call 2) port)
(writec port #\))))

29
ps-compiler/prescheme/primop/c-primop.scm
View File

@ -1,29 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Code generation for primops.
(define-record-type c-primop :c-primop
(make-c-primop simple? generate)
c-primop?
(simple? c-primop-simple?)
(generate c-primop-generate))
(define (simple-c-primop? primop)
(c-primop-simple? (primop-code-data primop)))
(define (primop-generate-c primop call port indent)
((c-primop-generate (primop-code-data primop))
call port indent))
(define-syntax define-c-generator
(lambda (exp r$ c$)
(destructure (((ignore id simple? generate) exp))
`(set-primop-code-data!
(,(r$ 'get-prescheme-primop) ',id)
(,(r$ 'make-c-primop)
,simple?
,generate
)))))

42
ps-compiler/prescheme/primop/c-record.scm
View File

@ -1,42 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define-c-generator make-record #t
(lambda (args)
(bug "no eval method for MAKE-RECORD"))
(lambda (call depth)
(reconstruct-make-record call depth))
(lambda (call port indent)
(let ((type (node-type call)))
(write-c-coercion type port)
(format port "malloc(sizeof(")
(display-c-type (pointer-type-to type) #f port)
(format port ") * ")
(c-value (call-arg call 0) port)
(format port ")"))))
(define (reconstruct-make-record call depth)
(let* ((args (call-exp-args call))
(arg-types (call-arg-types (cdr args) depth))
(record-type (quote-exp-value (car args)))
(type (record-type-type record-type))
(maker-type (record-type-maker-type record-type)))
(unify! maker-type (make-arrow-type arg-types type))
type))
(define-c-scheme-primop make-record
'allocate
(lambda (call)
(record-type-type (literal-value (node-ref call 0))))
default-simplifier)
(define-scheme-primop record-ref
'read
(lambda (call)
(record-slot-type (literal-value (node-ref call 0))))
default-simplifier)
(define-scheme-primop record-set!
'write
(lambda (call) type/unit)
default-simplifier)

242
ps-compiler/prescheme/primop/c-vector.scm
View File

@ -1,242 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; (make-vector size init)
(define-c-generator make-vector #t
(lambda (call port indent)
(let ((type (node-type call)))
(write-c-coercion type port)
(format port "malloc(sizeof(")
(display-c-type (pointer-type-to type) #f port)
(format port ") * ")
(c-value (call-arg call 0) port)
(format port ")"))))
(define-c-generator vector-ref #t
(lambda (call port indent)
(generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))
(define (generate-c-vector-ref vector index port)
(display "*(" port)
(c-value vector port)
(display " + " port)
(c-value index port)
(writec port #\)))
(define-c-generator vector-set! #t
(lambda (call port indent)
(generate-c-vector-set (call-arg call 1)
(call-arg call 2)
(call-arg call 3)
port indent)))
(define (generate-c-vector-set vector index value port indent)
(indent-to port indent)
(generate-c-vector-ref vector index port)
(display " = " port)
(c-value value port)
(writec port #\;))
(define-c-generator make-string #t
(lambda (call port indent)
; calloc is used as a hack to get a zero at the end
(format port "(char *)calloc( 1, 1 + ")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator string-length #t
(lambda (call port indent)
(format port "strlen((char *) ")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator string-ref #t
(lambda (call port indent)
(generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))
(define-c-generator string-set! #f
(lambda (call port indent)
(generate-c-vector-set (call-arg call 1)
(call-arg call 2)
(call-arg call 3)
port indent)))
(define-c-generator make-record #f
(lambda (call port indent)
(let ((type (get-record-type (literal-value (call-arg call 0)))))
(write-c-coercion type port)
(format port "malloc(sizeof(struct ")
(write-c-identifier (record-type-name type) port)
(format port "))"))))
(define-c-generator record-ref #t
(lambda (call port indent)
(generate-c-record-ref (call-arg call 0)
(call-arg call 1)
(call-arg call 2)
port)))
(define (generate-c-record-ref record type field port)
(let ((field (get-record-type-field (literal-value type)
(literal-value field))))
(c-value record port)
(display "->" port)
(write-c-identifier (record-field-name field) port)))
(define-c-generator record-set! #t
(lambda (call port indent)
(generate-c-record-set (call-arg call 1)
(call-arg call 2)
(call-arg call 3)
(call-arg call 4)
port indent)))
(define (generate-c-record-set record value type field port indent)
(indent-to port indent)
(generate-c-record-ref record type field port)
(display " = " port)
(c-value value port)
(writec port #\;))
(define-c-generator allocate-memory #t
(lambda (call port indent)
(write-c-coercion type/address port)
(format port "malloc(")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator deallocate #t
(lambda (call port indent)
(format port "free(")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator deallocate-memory #t
(lambda (call port indent)
(format port "free(")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator address+ #t
(lambda (call port indent)
(simple-c-primop "+" call port)))
(define-c-generator address-difference #t
(lambda (call port indent)
(simple-c-primop "-" call port)))
(define-c-generator address= #t
(lambda (call port indent)
(simple-c-primop "==" call port)))
(define-c-generator address< #t
(lambda (call port indent)
(simple-c-primop "<" call port)))
(define-c-generator address->integer #t
(lambda (call port indent)
(format port "((long) ")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator integer->address #t
(lambda (call port indent)
(format port "((char *) ")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator copy-memory! #t
(lambda (call port indent)
(format port "memcpy((void *)")
(c-value (call-arg call 1) port)
(format port ", (void *)")
(c-value (call-arg call 0) port)
(format port ",")
(c-value (call-arg call 2) port)
(format port ")")))
(define-c-generator memory-equal? #t
(lambda (call port indent)
(format port "(!memcmp((void *)")
(c-value (call-arg call 1) port)
(format port ", (void *)")
(c-value (call-arg call 0) port)
(format port ",")
(c-value (call-arg call 2) port)
(format port "))")))
(define-c-generator byte-ref #t
(lambda (call port indent)
(generate-c-memory-ref "unsigned char" (call-arg call 0) port)))
(define-c-generator word-ref #t
(lambda (call port indent)
(generate-c-memory-ref "long" (call-arg call 0) port)))
(define (generate-c-memory-ref type pointer port)
(format port "*((~A *) " type)
(c-value pointer port)
(writec port #\)))
(define-c-generator byte-set! #t
(lambda (call port indent)
(generate-c-memory-set! "unsigned char"
(call-arg call 1)
(call-arg call 2)
port
indent)))
(define-c-generator word-set! #t
(lambda (call port indent)
(generate-c-memory-set! "long"
(call-arg call 1)
(call-arg call 2)
port
indent)))
(define (generate-c-memory-set! type pointer value port indent)
(indent-to port indent)
(generate-c-memory-ref type pointer port)
(display " = " port)
(c-value value port)
(writec port #\;))
(define-c-generator char-pointer->string #t
(lambda (call port indent)
(format port "((char *)")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator char-pointer->nul-terminated-string #t
(lambda (call port indent)
(format port "((char *)")
(c-value (call-arg call 0) port)
(format port ")")))
(define-c-generator computed-goto #f
(lambda (call port indent)
(generate-c-switch call port indent)))
(define (generate-c-switch call port indent)
(let ((size (call-exits call)))
(indent-to port indent)
(display "switch (" port)
(c-value (call-arg call (+ size 1)) port)
(display ") {" port)
(let ((indent (+ indent 2)))
(do ((i 0 (+ i 1))
(labels (literal-value (call-arg call size)) (cdr labels)))
((>= i size))
(for-each (lambda (l)
(indent-to port indent)
(format port "case ~D : " l))
(car labels))
(write-c-switch-case (call-arg call i) port indent)))
(indent-to port indent)
(display "}" port)))
(define (write-c-switch-case node port indent)
(writec port #\{)
(write-c-block (lambda-body node) port (+ indent 2))
(indent-to port (+ indent 2))
(display "break;" port))

38
ps-compiler/prescheme/primop/io.scm
View File

@ -1,38 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
;(define-scheme-primop cast-to-long)
(define-scheme-primop stdin type/input-port)
(define-scheme-primop stdout type/output-port)
(define-scheme-primop stderr type/output-port)
(define-nonsimple-scheme-primop read-char io)
(define-nonsimple-scheme-primop peek-char io)
(define-nonsimple-scheme-primop read-integer io)
(define type/status type/integer)
(define-nonsimple-scheme-primop write-char io)
(define-scheme-primop write-string io type/status)
(define-scheme-primop write-integer io type/status)
(define-scheme-primop force-output io type/status)
(define-nonsimple-scheme-primop open-input-file)
(define-nonsimple-scheme-primop open-output-file)
(define-scheme-primop close-input-port io type/status)
(define-scheme-primop close-output-port io type/status)
(define-scheme-primop abort io type/unit)
(define-nonsimple-scheme-primop error io)
(define-scheme-primop error-string type/string)
(define-scheme-primop call-external-value io type/integer)
(define-nonsimple-scheme-primop read-block io)
(define-scheme-primop write-block io type/status)

163
ps-compiler/prescheme/primop/primop.scm
View File

@ -1,163 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define prescheme-primop-table (make-symbol-table))
(walk-vector (lambda (primop)
(if (primop? primop)
(table-set! prescheme-primop-table
(primop-id primop)
primop)))
all-primops)
(define (get-prescheme-primop id)
(cond ((table-ref prescheme-primop-table id)
=> identity)
((name->enumerand id primop)
=> get-primop)
(else
(bug "Scheme primop ~A not found" id))))
(define (add-scheme-primop! id primop)
(table-set! prescheme-primop-table id primop))
(define-syntax define-scheme-primop
(syntax-rules ()
((define-scheme-primop id type)
(define-scheme-primop id #f type))
((define-scheme-primop id side-effects type)
(define-scheme-primop id side-effects type default-simplifier))
((define-scheme-primop id side-effects type simplifier)
(define-polymorphic-scheme-primop
id side-effects (lambda (call) type) simplifier))))
(define-syntax define-polymorphic-scheme-primop
(syntax-rules ()
((define-polymorphic-scheme-primop id type)
(define-polymorphic-scheme-primop id #f type))
((define-polymorphic-scheme-primop id side-effects type)
(define-polymorphic-scheme-primop id side-effects type default-simplifier))
((define-scheme-primop id side-effects type simplifier)
(add-scheme-primop! 'id
(make-primop 'id #t 'side-effects simplifier
(lambda (call) 1)
type)))))
(define-syntax define-nonsimple-scheme-primop
(syntax-rules ()
((define-nonsimple-scheme-primop id)
(define-nonsimple-scheme-primop id #f))
((define-nonsimple-scheme-primop id side-effects)
(define-nonsimple-scheme-primop id side-effects default-simplifier))
((define-nonsimple-scheme-primop id side-effects simplifier)
(add-scheme-primop! 'id
(make-primop 'id #f 'side-effects simplifier
(lambda (call) 1)
'nontrivial-primop)))))
(define-syntax define-scheme-cond-primop
(syntax-rules ()
((define-scheme-cond-primop id simplifier expand simplify?)
(add-scheme-primop! 'id
(make-conditional-primop 'id
#f
simplifier
(lambda (call) 1)
expand
simplify?)))))
;(define-prescheme! 'error ; all four args must be present if used as value
; (lambda (exp env)
; (let ((string (expand (cadr exp) env #f))
; (args (map (lambda (arg)
; (expand arg env #f))
; (cddr exp))))
; (make-block-exp
; (list
; (make-call-exp (get-prescheme-primop 'error)
; 0
; type/unknown
; `(,string
; ,(make-quote-exp (length args) type/int32)
; . ,(case (length args)
; ((0)
; (list (make-quote-exp 0 type/int32)
; (make-quote-exp 0 type/int32)
; (make-quote-exp 0 type/int32)))
; ((1)
; (list (car args)
; (make-quote-exp 0 type/int32)
; (make-quote-exp 0 type/int32)))
; ((2)
; (list (car args)
; (cadr args)
; (make-quote-exp 0 type/int32)))
; ((3)
; args)
; (else
; (error "too many arguments to ERROR in ~S" exp))))
; exp)
; (make-quote-exp the-undefined-value type/unknown))))))
; For the moment VALUES is more or less a macro.
;(define-prescheme! 'values ; dies if used as a value
; (lambda (exp env)
; (make-call-exp (get-prescheme-primop 'pack)
; 0
; type/unknown
; (map (lambda (arg)
; (expand arg env #f))
; (cdr exp))
; exp)))
; Each arg spec is either #F = non-continuation argument or a list of
; variable (name . type)s for the continuation.
;(define (define-continuation-expander id primop-id arg-specs)
; (define-primitive-expander id (length arg-specs)
; (lambda (source args cenv)
; (receive (conts other)
; (expand-arguments args arg-specs cenv)
; (make-call-exp (get-prescheme-primop primop-id)
; (length conts)
; type/unknown
; (append conts other)
; source)))))
;(define (expand-arguments args specs cenv)
; (let loop ((args args) (specs specs) (conts '()) (other '()))
; (if (null? args)
; (values (reverse conts) (reverse other))
; (let ((arg (expand (car args) cenv #f)))
; (if (not (car specs))
; (loop (cdr args) (cdr specs) conts (cons arg other))
; (loop (cdr args) (cdr specs)
; (cons (expand-continuation-arg arg (car specs))
; conts)
; other))))))
;
;(define (expand-continuation-arg arg var-specs)
; (let* ((vars (map (lambda (p)
; (make-variable (car p) (cdr p)))
; var-specs)))
; (make-continuation-exp
; vars
; (make-call-exp (get-primop (enum primop unknown-call))
; 0
; type/unknown
; `(,arg
; ,(make-quote-exp (length vars) #f)
; . ,vars)
; #f)))) ; no source
; Randomness needed by both arith.scm and c-arith.scm.
; What we will get in C.
(define prescheme-integer-size 32)
(define int-mask (- (arithmetic-shift 1 prescheme-integer-size) 1))
(define (lshr i n)
(arithmetic-shift (bitwise-and i int-mask) (- 0 n)))

187
ps-compiler/prescheme/primop/scm-arith.scm
View File

@ -1,187 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Arithmetic inference rules
(define (arith-op-rule args node depth return?)
(for-each (lambda (arg)
(unify! (infer-type arg depth) type/integer node))
args)
type/integer)
(define (arith-comparison-rule args node depth return?)
(arith-op-rule args node depth return?)
type/boolean)
(define (integer-binop-rule args node depth return?)
(check-arg-type args 0 type/integer depth node)
(check-arg-type args 1 type/integer depth node)
type/integer)
(define (integer-monop-rule args node depth return?)
(check-arg-type args 0 type/integer depth node)
type/integer)
(define (integer-comparison-rule args node depth return?)
(check-arg-type args 0 type/integer depth node)
type/boolean)
;----------------------------------------------------------------
; Arithmetic
(define-complex-primitive (+ . integer?) +
arith-op-rule
(lambda (x y) (+ x y))
(lambda (args type)
(if (null? args)
(make-literal-node 0 type/integer)
(n-ary->binary args
(make-literal-node (get-prescheme-primop '+))
type))))
(define-complex-primitive (* . integer?) *
arith-op-rule
(lambda (x y) (* x y))
(lambda (args type)
(if (null? args)
(make-literal-node 1)
(n-ary->binary args
(make-literal-node (get-prescheme-primop '*))
type))))
(define-complex-primitive (- integer? . integer?)
(lambda args
(if (or (null? (cdr args))
(null? (cddr args)))
(apply - args)
(user-error "error while evaluating: type error ~A" (cons '- args))))
(lambda (args node depth return?)
(case (length args)
((1)
(check-arg-type args 0 type/integer depth node)
type/integer)
((2)
(check-arg-type args 0 type/integer depth node)
(check-arg-type args 1 type/integer depth node)
type/integer)
(else
(user-error "wrong number of arguments to - in ~S" (schemify node)))))
(lambda (x y) (- x y))
(lambda (args type)
(let ((primop (get-prescheme-primop '-)))
(if (null? (cdr args))
(make-primop-call-node primop
(list (make-literal-node 0) (car args))
type)
(make-primop-call-node primop args type)))))
(define (n-ary->binary args proc type)
(let loop ((args args))
(if (null? (cdr args))
(car args)
(loop (cons (make-call-node proc
(list (car args) (cadr args))
type)
(cddr args))))))
(define-syntax define-binary-primitive
(syntax-rules ()
((define-binary-primitive id type-reconstruct)
(define-complex-primitive (id integer? integer?) id
type-reconstruct
(lambda (x y) (id x y))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'id) args type))))))
(define-binary-primitive = arith-comparison-rule)
(define-binary-primitive < arith-comparison-rule)
(define-semi-primitive (> integer? integer?) >
arith-comparison-rule
(lambda (x y) (< y x)))
(define-semi-primitive (<= integer? integer?) <=
arith-comparison-rule
(lambda (x y) (not (< y x))))
(define-semi-primitive (>= integer? integer?) >=
arith-comparison-rule
(lambda (x y) (not (< x y))))
(define-binary-primitive quotient integer-binop-rule)
(define-binary-primitive remainder integer-binop-rule)
(define-binary-primitive modulo integer-binop-rule)
(define-primitive bitwise-and
((integer? type/integer) (integer? type/integer))
type/integer)
(define-primitive bitwise-ior
((integer? type/integer) (integer? type/integer))
type/integer)
(define-primitive bitwise-xor
((integer? type/integer) (integer? type/integer))
type/integer)
(define-primitive bitwise-not
((integer? type/integer))
type/integer)
(define-primitive shift-left
((integer? type/integer) (integer? type/integer))
type/integer
ashl)
(define-primitive logical-shift-right
((integer? type/integer) (integer? type/integer))
type/integer
lshr)
(define-primitive arithmetic-shift-right
((integer? type/integer) (integer? type/integer))
type/integer
ashr)
(define-semi-primitive (abs integer?) abs
arith-op-rule
(lambda (n) (if (< n 0) (- 0 n) n)))
(define-semi-primitive (zero? integer?) zero?
arith-comparison-rule
(lambda (n) (= n 0)))
(define-semi-primitive (positive? integer?) positive?
arith-comparison-rule
(lambda (n) (< 0 n)))
(define-semi-primitive (negative? integer?) negative?
arith-comparison-rule
(lambda (n) (< n 0)))
(define-semi-primitive (even? integer?) even?
integer-comparison-rule
(lambda (n) (= 0 (remainder n 2))))
(define-semi-primitive (odd? integer?) odd?
integer-comparison-rule
(lambda (n) (not (even? n))))
(define-semi-primitive (max integer? . integer?) max
arith-op-rule
(lambda (x y)
(if (< x y) y x)))
(define-semi-primitive (min integer? . integer?) min
arith-op-rule
(lambda (x y)
(if (< x y) x y)))
(define-semi-primitive (expt integer? positive-integer?) expt
arith-op-rule
(lambda (x y)
(do ((r x (* r x))
(y y (- y 1)))
((<= y 0)
r))))

122
ps-compiler/prescheme/primop/scm-memory.scm
View File

@ -1,122 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define-primitive allocate-memory ((positive-integer? type/integer)) type/address)
(define-primitive deallocate-memory ((address? type/address)) type/unit)
(define-load-time-primitive (address? #f) address?)
(define-primitive address+
((address? type/address)
(integer? type/integer))
type/address)
(define-semi-primitive (address- address? integer?) address-
(lambda (args node depth return?)
(check-arg-type args 0 type/address depth node)
(check-arg-type args 1 type/integer depth node)
type/address)
(lambda (x y) (address+ x (- 0 y))))
(define-primitive address-difference
((address? type/address)
(address? type/address))
type/integer)
(define-primitive address=
((address? type/address)
(address? type/address))
type/boolean)
(define-primitive address<
((address? type/address)
(address? type/address))
type/boolean)
(define-prescheme! 'null-address
(let ((location (make-undefined-location 'null-address)))
(set-contents! location (make-external-value "NULL" type/address))
location)
#f)
(define-semi-primitive (null-address? address?) null-address?
(lambda (args node depth return)
(check-arg-type args 0 type/address depth node)
type/boolean)
(lambda (x) (address= x null-address)))
(define (address-comparison-rule args node depth return?)
(check-arg-type args 0 type/address depth node)
(check-arg-type args 1 type/address depth node)
type/boolean)
(define-semi-primitive (address> address? address?) address>
address-comparison-rule
(lambda (x y) (address< y x)))
(define-semi-primitive (address<= address? address?) address<=
address-comparison-rule
(lambda (x y) (not (address< y x))))
(define-semi-primitive (address>= address? address?) address>=
address-comparison-rule
(lambda (x y) (not (address< x y))))
(define-primitive address->integer
((address? type/address))
type/integer)
(define-primitive integer->address
((integer? type/integer))
type/address)
(define-primitive copy-memory!
((address? type/address)
(address? type/address)
(positive-integer? type/integer))
type/unit)
(define-primitive memory-equal?
((address? type/address)
(address? type/address)
(positive-integer? type/integer))
type/boolean)
(define-primitive unsigned-byte-ref
((address? type/address))
type/integer
byte-ref)
(define-primitive unsigned-byte-set!
((address? type/address) (unsigned-byte? type/integer))
type/unit
byte-set!)
(define-primitive word-ref ((address? type/address)) type/integer)
(define-primitive word-set!
((address? type/address) (positive-integer? type/integer))
type/unit)
(define-primitive char-pointer->string
((address? type/address)
(positive-integer? type/integer))
type/string)
(define-primitive char-pointer->nul-terminated-string
((address? type/address))
type/string)
(let ((read-block-return-type
(make-tuple-type (list type/integer type/boolean type/status))))
(define-primitive read-block
((input-port? type/input-port)
(address? type/address)
(positive-integer? type/integer))
read-block-return-type))
(define-primitive write-block
((output-port? type/output-port)
(address? type/address)
(positive-integer? type/integer))
type/status)

46
ps-compiler/prescheme/primop/scm-record.scm
View File

@ -1,46 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define-complex-primitive (make-record symbol?)
(lambda (type)
(bug "no evaluator for MAKE-RECORD"))
(lambda (args node depth return?)
(let ((type-id (cadr (node-form (car args)))))
(make-pointer-type (get-record-type type-id))))
#f ; no closed form
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'make-record) args type)))
(define-complex-primitive (record-ref any? ; no RECORD? available
symbol? symbol?)
(lambda (thing type field)
(bug "no evaluator for RECORD-REF"))
(lambda (args node depth return?)
(let ((type-id (cadr (node-form (cadr args))))
(field-id (cadr (node-form (caddr args)))))
(let ((record-type (make-pointer-type (get-record-type type-id)))
(field-type (record-field-type
(get-record-type-field type-id field-id))))
(check-arg-type args 0 record-type depth node)
field-type)))
#f ; no closed form
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'record-ref) args type)))
(define-complex-primitive (record-set! any? ; no RECORD? available
any? symbol? symbol?)
(lambda (thing value type field)
(bug "no evaluator for RECORD-SET!"))
(lambda (args node depth return?)
(let ((type-id (cadr (node-form (caddr args))))
(field-id (cadr (node-form (cadddr args)))))
(let ((record-type (make-pointer-type (get-record-type type-id)))
(field-type (record-field-type
(get-record-type-field type-id field-id))))
(check-arg-type args 0 record-type depth node)
(check-arg-type args 1 field-type depth node)
type/unit)))
#f ; no closed form
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'record-set!) args type)))

403
ps-compiler/prescheme/primop/scm-scheme.scm
View File

@ -1,403 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Primitives that directly correspond to primops.
;
; (define-primitive (id (arg-pred arg-type) ...) result-type . maybe-primop-id)
;
; Primitives that are n-ary or have other weirdness.
;
; (define-complex-primitive (id . argument-predicates)
; eval-fn inference-rule source . maybe-expander)
;
; Primitives that have only source but not a primop.
;
; (define-semi-primitive (id . argument-predicates)
; eval-fn inference-rule source maybe-expander)
;
; Primitives available only at load time.
;
; (define-load-time-primitive (id . argument-predicates) eval-fn)
; (really-define-primitive (id . argument-predicates)
; eval-fn inference-rule source expander expands-in-place?)
(define-syntax really-define-primitive
(lambda (exp r c)
(let* ((spec (cadr exp))
(id (car spec))
(arg-predicates (cdr spec))
(eval (caddr exp))
(rest (cdddr exp))
(inference-rule (car rest))
(source (cadr rest))
(expander (caddr rest))
(expands-in-place? (cadddr rest)))
`(let ((,(r 'predicates) ,(let recur ((preds arg-predicates))
(cond ((pair? preds)
`(cons ,(car preds)
,(recur (cdr preds))))
((null? preds)
'(quote ()))
(else
preds)))))
(define-prescheme! ',id
#f ; location
(make-primitive ',id
,(r 'predicates)
,eval
',source
,expander
,expands-in-place?
,inference-rule))))))
(define-syntax define-complex-primitive
(lambda (exp r c)
`(really-define-primitive ,@(cdr exp) #t)))
(define-syntax define-primitive
(lambda (exp r c)
(let* ((id (cadr exp))
(args (caddr exp))
(result (cadddr exp))
(primop (if (null? (cddddr exp)) (cadr exp) (car (cddddr exp))))
(names (map (lambda (a b) b)
args
'(x1 x2 x3 x4 x5 x6 x7 x8 x9))))
`(define-complex-primitive (,id . ,(map car args)) ,id
(lambda (args node depth return?)
(if (not (= (length args)
,(length args)))
(user-error "wrong number of arguments in ~S" (schemify node)))
,@(do ((i 0 (+ i 1))
(args args (cdr args))
(res '() (cons `(check-arg-type args ,i ,(cadar args) depth node)
res)))
((null? args)
(reverse res)))
,result)
(lambda ,names (,id . ,names))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop ',primop) args type))))))
(define-syntax define-semi-primitive
(lambda (exp r c)
`(really-define-primitive ,@(cdr exp) #f #f)))
(define-syntax define-load-time-primitive
(lambda (exp r c)
`(define-semi-primitive ,(cadr exp)
,(caddr exp)
(make-load-time-only-rule ',(caadr exp))
#f)))
(define (make-load-time-only-rule id)
(lambda (args node depth return?)
(user-error "~S is only available at load time ~S" id (schemify node))))
;----------------------------------------------------------------
; Boolean stuff
(define-semi-primitive (not #f) not
(lambda (args node depth return?)
(check-arg-type args 0 type/boolean depth node)
type/boolean)
(lambda (x) (if x #f #t)))
(define-load-time-primitive (boolean? #f) boolean?)
(define-complex-primitive (eq? #f #f) eq?
(lambda (args node depth return?)
(unify! (infer-type (car args) depth)
(infer-type (cadr args) depth)
node)
type/boolean)
(lambda (x y) (eq? x y))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'eq?) args type)))
(define-load-time-primitive (eqv? #f) eqv?)
(define-load-time-primitive (equal? #f) equal?)
;----------------------------------------------------------------
; Characters
(define (ascii-value? n)
(and (integer? n)
(>= n 0)
(< n ascii-limit)))
(define-primitive ascii->char ((ascii-value? type/integer)) type/char)
(define-primitive char->ascii ((char? type/char)) type/integer)
(define (char-comparison-rule args node depth return?)
(check-arg-type args 0 type/char depth node)
(check-arg-type args 1 type/char depth node)
type/boolean)
(define-syntax define-char-comparison
(lambda (exp r c)
(let ((id (cadr exp))
(op (caddr exp)))
`(define-complex-primitive (,id char? char?) ,id
char-comparison-rule
(lambda (x y) (,op x y))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop ',op) args type))))))
(define-char-comparison char=? =)
(define-char-comparison char<? <)
(define-char-comparison char>? >)
(define-char-comparison char<=? <=)
(define-char-comparison char>=? >=)
; Plus lots more...
;----------------------------------------------------------------
; Data manipulation
(define (any? x) #t)
(define (positive-integer? x)
(and (integer? x)
(<= 0 x)))
(define (unsigned-byte? x)
(and (positive-integer? x)
(<= x 256)))
(define-complex-primitive (make-vector positive-integer? . any?) make-vector
(lambda (args node depth return?)
(let ((uvar (make-uvar 'v depth)))
(make-nonpolymorphic! uvar)
(check-arg-type args 0 type/integer depth node)
(check-arg-type args 1 uvar depth node)
(make-pointer-type uvar)))
(lambda (size init)
(make-vector size init))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'make-vector) args type)))
(define-load-time-primitive (vector-length vector?) vector-length)
(define-complex-primitive (vector-ref vector? positive-integer?) vector-ref
(lambda (args node depth return?)
(let ((elt-type (make-uvar 'v depth)))
(check-arg-type args 0 (make-pointer-type elt-type) depth node)
(check-arg-type args 1 type/integer depth node)
elt-type))
(lambda (vector index)
(vector-ref vector index))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'vector-ref) args type)))
(define-complex-primitive (vector-set! vector? positive-integer? any?)
vector-set!
(lambda (args node depth return?)
(let ((elt-type (make-uvar 'v depth)))
(check-arg-type args 0 (make-pointer-type elt-type) depth node)
(check-arg-type args 1 type/integer depth node)
(check-arg-type args 2 elt-type depth node)
type/unit))
(lambda (vector index value)
(vector-set! vector index value))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'vector-set!) args type)))
(define-primitive make-string ((integer? type/integer)) type/string)
(define-primitive string-length ((string? type/string)) type/integer)
(define-primitive string-ref
((string? type/string) (integer? type/integer))
type/char)
(define-primitive string-set!
((string? type/string) (integer? type/integer) (char? type/char))
type/unit)
(define-complex-primitive (deallocate any?) (lambda (x) (values))
(lambda (args node depth return?)
(let ((type (make-pointer-type (make-uvar 'p depth))))
(check-arg-type args 0 type depth node)
type/unit))
(lambda (thing)
(deallocate thing))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'deallocate) args type)))
(define-complex-primitive (null-pointer? any?) (lambda (x) #f)
(lambda (args node depth return?)
(let ((type (make-pointer-type (make-uvar 'p depth))))
(check-arg-type args 0 type depth node)
type/boolean))
(lambda (thing)
(null-pointer? thing))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'null-pointer?) args type)))
(define-complex-primitive (null-pointer) (lambda () #f)
(lambda (args node depth return?)
(make-pointer-type (make-uvar 'null depth)))
(lambda ()
(null-pointer))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'null-pointer) args type)))
;----------------------------------------------------------------
; I/O
(define-primitive current-input-port () type/input-port stdin)
(define-primitive current-output-port () type/output-port stdout)
(define-primitive current-error-port () type/output-port stderr)
(define type/status type/integer)
(let ((return (make-tuple-type (list type/input-port type/status))))
(define-primitive open-input-file ((string? type/string)) return))
(let ((return (make-tuple-type (list type/output-port type/status))))
(define-primitive open-output-file ((string? type/string)) return))
(define-primitive close-input-port ((input-port? type/input-port)) type/status)
(define-primitive close-output-port ((output-port? type/output-port)) type/status)
(define char-return-type
(make-tuple-type (list type/char type/boolean type/status)))
(define-primitive read-char ((input-port? type/input-port)) char-return-type)
(define-primitive peek-char ((input-port? type/input-port)) char-return-type)
(define integer-return-type
(make-tuple-type (list type/integer type/boolean type/status)))
(define-primitive read-integer ((input-port? type/input-port)) integer-return-type)
(define-primitive write-char
((char? type/char) (output-port? type/output-port))
type/status)
(define-primitive write-string
((string? type/string) (output-port? type/output-port))
type/status)
(define-primitive write-integer
((integer? type/integer) (output-port? type/output-port))
type/status)
(define-complex-primitive (newline output-port?) newline
(lambda (args node depth return?)
(check-arg-type args 0 type/output-port depth node)
type/status)
(lambda (out)
(write-char #\newline out))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'write-char)
(cons (make-literal-node #\newline) args)
type)))
(define-primitive force-output ((output-port? type/output-port)) type/status)
(define-primitive error-string
((positive-integer? type/status))
type/string)
;----------------------------------------------------------------
(define-complex-primitive (values . any?) values
(lambda (args node depth return?)
(make-tuple-type (infer-types args depth)))
#f
(lambda (args type)
(let ((node (make-node values-operator (cons 'values args))))
(node-set! node 'type type)
node)))
(define values-operator (get-operator 'values))
; CALL-WITH-VALUES that uses closures instead of procedures.
(define (ps-call-with-values producer consumer)
(call-with-values
(lambda ()
(apply-closure producer '()))
(lambda args
(apply-closure consumer args))))
(define-complex-primitive (call-with-values closure? closure?)
ps-call-with-values
(lambda (args node depth return?)
(if (not (lambda-node? (cadr args)))
(user-error
"second argument to CALL-WITH-VALUES must be a lambda node~% ~S"
(schemify node)))
(let* ((consumer-type (infer-type (cadr args) depth))
(arg-types (arrow-type-args consumer-type))
(result-type (arrow-type-result consumer-type)))
(unify! (infer-type (car args) depth)
(make-arrow-type '() (make-tuple-type arg-types))
node)
(if (not return?) ; so we cause a check for illegal tuples
(unify! result-type (make-uvar 'temp depth) node))
result-type))
#f
(lambda (args type)
(let* ((tuple-type (arrow-type-result
(maybe-follow-uvar (node-ref (car args) 'type))))
(node (make-node call-with-values-operator
(list 'call-with-values
(make-call-node (car args) '() tuple-type)
(cadr args)))))
(node-set! node 'type type)
node)))
(define lambda-node? (node-predicate 'lambda))
(define call-with-values-operator (get-operator 'call-with-values))
(define-primitive unspecific () type/unit)
(define-complex-primitive (error string? . integer?) error
(lambda (args node depth return?)
(check-arg-type args 0 type/string depth node)
(do ((args (cdr args) (cdr args)))
((null? args))
(check-arg-type args 0 type/integer depth node))
type/null)
(lambda (error string)
(error string))
(lambda (args type)
(make-primop-call-node (get-prescheme-primop 'error) args type)))
; For enumerated types that are shared with C
(define-load-time-primitive (make-external-constant symbol? symbol? string?)
make-external-constant)
;----------------------------------------------------------------
; Utilities for making nodes
(define call-operator (get-operator 'call))
(define literal-operator (get-operator 'literal))
(define name-operator (get-operator 'name))
(define primitive-operator (get-operator 'primitive))
(define (make-call-node proc args type)
(let ((node (make-node call-operator (cons proc args))))
(node-set! node 'type type)
node))
(define (make-literal-node value)
(make-node literal-operator value))
(define (make-primop-call-node primop args type)
(make-call-node (make-literal-node primop) args type))
(define (make-reference-node id binding)
(let ((node (make-node name-operator id)))
(node-set! node 'binding binding)
node))
(define (var->name-node var)
(make-reference-node ((structure-ref variable variable-name) var)
(make-binding #f var #f)))

82
ps-compiler/prescheme/primop/vector.scm
View File

@ -1,82 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define-polymorphic-scheme-primop make-vector allocate
(lambda (call)
(make-pointer-type (node-type (call-arg call 1)))))
(define-polymorphic-scheme-primop vector-ref read
(lambda (call)
(pointer-type-to (node-type (call-arg call 0)))))
(define-nonsimple-scheme-primop vector-set! write)
(define-scheme-primop make-string allocate type/string)
(define-scheme-primop string-length type/integer)
(define-scheme-primop string-ref read type/char)
(define-nonsimple-scheme-primop string-set! write)
(define-polymorphic-scheme-primop make-record allocate
(lambda (call)
(literal-value (call-arg call 1))))
(define-polymorphic-scheme-primop record-ref read
(lambda (call)
(record-field-type (literal-value (call-arg call 1)))))
(define-nonsimple-scheme-primop record-set! write)
(define-scheme-primop deallocate deallocate type/unit)
(define-scheme-primop allocate-memory allocate type/address)
(define-scheme-primop deallocate-memory deallocate type/unit)
(define (simplify-address+ call)
(simplify-args call 0)
((pattern-simplifier
((address+ a '0) a)
((address+ (address+ a x) y) (address+ a (+ x y))))
call))
(define-scheme-primop address+ #f type/address simplify-address+)
(define-scheme-primop address-difference type/address)
(define-scheme-primop address= type/boolean)
(define-scheme-primop address< type/boolean)
(define-scheme-primop address->integer type/integer)
(define-scheme-primop integer->address type/address)
(define-scheme-primop copy-memory! write type/unit)
(define-scheme-primop memory-equal? type/boolean)
(define-scheme-primop byte-ref read type/integer)
(define-scheme-primop word-ref read type/integer)
(define-nonsimple-scheme-primop byte-set! write)
(define-nonsimple-scheme-primop word-set! write)
; We delete the length argument because we don't need it. This is allowable
; because trivial calls can't have WRITE side effects.
(define-scheme-primop char-pointer->string #f type/string
(lambda (call)
(if (= 2 (call-arg-count call))
(remove-call-arg call 1))))
(define-scheme-primop char-pointer->nul-terminated-string type/string)
; (COMPUTED-GOTO <exit0> <exit1> ... <exitN> <dispatch-value>)
; Remove an unecessary coercion on the dispatch-value, if possible.
(define (simplify-computed-goto call)
(simplify-args call 0)
(let ((value (call-arg call (call-exits call))))
(cond ((and (call-node? value)
(eq? 'coerce (primop-id (call-primop value)))
(< (call-exits call) 256)
(eq? type/integer (literal-value (call-arg value 1))))
(replace value (detach (call-arg value 0)))))))
(define-nonsimple-scheme-primop computed-goto #f simplify-computed-goto)

116
ps-compiler/prescheme/ps-syntax.scm
View File

@ -1,116 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Redefine CASE so that it doesn't call MEMV
(define-syntax case
(lambda (e r c)
(let ((x (r 'x))
(xlet (r 'let))
(xcond (r 'cond))
(xif (r 'if))
(xeq? (r 'eq?))
(xquote (r 'quote)))
(let ((test (lambda (y)
`(,xeq? ,x (,xquote ,y)))))
`(,xlet ((,x ,(cadr e)))
(,xcond . ,(map (lambda (clause)
(if (c (car clause) 'else)
clause
`(,(let label ((xs (car clause)))
(cond ((null? xs) #f)
((null? (cdr xs))
(test (car xs)))
(else
`(,xif ,(test (car xs))
#t
,(label (cdr xs))))))
. ,(cdr clause))))
(cddr e))))))))
; RECEIVE (from big-scheme)
(define-syntax receive
(syntax-rules ()
((receive ?vars ?producer . ?body)
(call-with-values (lambda () ?producer)
(lambda ?vars . ?body)))))
(define-syntax external
(lambda (e r c)
(let ((l (length e)))
(if (and (or (= l 3) (= l 4))
(string? (cadr e)))
`(,(r 'real-external) ,(cadr e) ',(caddr e))
e))))
; DEFINE-EXTERNAL-ENUMERATION (from prescheme)
(define-syntax define-external-enumeration
(lambda (form rename compare)
(let* ((name (cadr form))
(symbol->upcase-string
(lambda (s)
(list->string (map (lambda (c)
(if (char=? c #\-)
#\_
(char-upcase c)))
(string->list (symbol->string s))))))
(constant
(lambda (sym string)
`(,(rename 'make-external-constant) ',name ',sym ,string)))
(conc (lambda things
(string->symbol (apply string-append
(map (lambda (thing)
(if (symbol? thing)
(symbol->string thing)
thing))
things)))))
(var-name
(lambda (sym)
(conc name "/" sym)))
(components
(list->vector
(map (lambda (stuff)
(if (pair? stuff)
(cons (car stuff)
(var-name (car stuff)))
(cons stuff
(var-name stuff))))
(caddr form))))
(%define (rename 'define))
(%define-syntax (rename 'define-syntax))
(%begin (rename 'begin))
(%quote (rename 'quote))
(%make-external-constant (rename 'make-external-constant))
(e-name (conc name '- 'enumeration))
(count (vector-length components)))
`(,%begin
(,%define-syntax ,name
(let ((components ',components))
(lambda (e r c)
(let ((key (cadr e)))
(cond ((c key 'enum)
(let ((which (caddr e)))
(let loop ((i 0)) ;vector-posq
(if (< i ,count)
(if (c which (car (vector-ref components i)))
(r (cdr (vector-ref components i)))
(loop (+ i 1)))
;; (syntax-error "unknown enumerand name"
;; `(,(cadr e) ,(car e) ,(caddr e)))
e))))
(else e))))))
(,%define ,(conc name '- 'count) ,count)
. ,(map (lambda (stuff)
(if (pair? stuff)
`(,%define ,(var-name (car stuff))
(,%make-external-constant ',name
',(car stuff)
,(cadr stuff)))
`(,%define ,(var-name stuff)
(,%make-external-constant ',name
',stuff
,(symbol->upcase-string stuff)))))
(caddr form)))))
(begin define define-syntax quote external make-external-constant))

122
ps-compiler/prescheme/record.scm
View File

@ -1,122 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Records that translate into C structs.
; Representation of records types.
(define-record-type record-type
(name)
(fields ; filled in later because of circularity
constructor-args) ; fields passed to the constructor
)
(define-record-discloser type/record-type
(lambda (rtype)
(list 'record-type (record-type-name rtype))))
; Fields of record types.
(define-record-type record-field
(record-type
name
type
)
())
; Global table of record types. Since we compile to a single C file the
; record types used within a single computation must have distinct names.
; (This should really be a fluid.)
(define *record-type-table* (make-symbol-table))
(define (reset-record-data!)
(set! *record-type-table* (make-symbol-table)))
(define (get-record-type id)
(cond ((table-ref *record-type-table* id)
=> identity)
(else
(error "no record type ~S" id))))
(define (lookup-record-type id)
(table-ref *record-type-table* id))
(define (all-record-types)
(table->entry-list *record-type-table*))
; Construction a record type. This gets the name, the list of fields whose
; initial values are passed to the constructor, and the field specifications.
; Each field specification consists of a name and a type.
(define (make-record-type id constructor-args specs)
(let ((rt (record-type-maker id)))
(if (table-ref *record-type-table* id)
(user-error "multiple definitions of record type ~S" id))
(table-set! *record-type-table* id rt)
(set-record-type-fields! rt (map (lambda (spec)
(record-field-maker
rt
(car spec)
(expand-type-spec (cadr spec))))
specs))
(set-record-type-constructor-args! rt
(map (lambda (name)
(get-record-type-field id name))
constructor-args))
rt))
; Return the field record for FIELD-ID in record-type TYPE-ID.
(define (get-record-type-field type-id field-id)
(let ((rtype (get-record-type type-id)))
(cond ((any (lambda (field)
(eq? field-id (record-field-name field)))
(record-type-fields rtype))
=> identity)
(else
(user-error "~S is not a field of ~S" field-id rtype)))))
; The macro expander for DEFINE-RECORD-TYPE.
;
; (define-record-type <id> <type-id>
; (<constructor> . <field-names>)
; (<field-name> <type> <accessor-name> [<modifier-name>]) ...)
;
; The <type-id> is used only by Pre-Scheme-in-Scheme.
(define (expand-define-record-type exp r c)
(let ((id (cadr exp))
(maker (cadddr exp))
(fields (cddddr exp)))
(let ((rt (make-record-type id (cdr maker) fields)))
`(,(r 'begin)
(,(r 'define) ,maker
(,(r 'let) ((,(r id) (,(r 'make-record) ',id)))
(,(r 'if) (,(r 'not) (,(r 'null-pointer?) ,(r id)))
(,(r 'begin)
. ,(map (lambda (name)
`(,(r 'record-set!) ,(r id) ,name ',id ',name))
(cdr maker))))
,(r id)))
,@(map (lambda (field)
`(,(r 'define) (,(caddr field) ,(r id))
(,(r 'record-ref) ,(r id) ',id ',(car field))))
fields)
,@(map (lambda (field)
`(,(r 'define) (,(cadddr field) ,(r id) ,(r 'x))
(,(r 'record-set!)
,(r id) ,(r 'x)',id ',(car field))))
(filter (lambda (spec)
(not (null? (cdddr spec))))
fields))))))
; primitives
; (make-record 'type . args)
; (record-ref thing 'type 'field)
; (record-set! thing value 'type 'field)
;
; C record creator
; global list of these things

101
ps-compiler/prescheme/spec.scm
View File

@ -1,101 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Protocol specifications are lists of representations.
(set-compiler-parameter! 'lambda-node-type
(lambda (node)
(let ((vars (lambda-variables node)))
(case (lambda-type node)
((cont jump)
(make-arrow-type (map variable-type vars)
type/unknown)) ; what to do?
((proc known-proc)
(make-arrow-type (map variable-type (cdr vars))
(variable-type (car vars))))
(else
(error "unknown type of lambda node ~S" node))))))
(set-compiler-parameter! 'true-value #t)
(set-compiler-parameter! 'false-value #f)
; Tail-calls with goto-protocols cause the lambda node to be annotated
; as tail-called.
; Calls with a tuple argument need their argument spread out into separate
; variables.
(define (determine-lambda-protocol lambda-node call-refs)
(set-lambda-protocol! lambda-node #f)
(for-each (lambda (r)
(let ((call (node-parent r)))
(cond ((goto-protocol? (literal-value (call-arg call 2)))
(if (not (calls-this-primop? call 'unknown-tail-call))
(bug "GOTO marker in non-tail-all ~S" call))
(set-lambda-protocol! lambda-node 'tail-called)))
(unknown-call->known-call call)))
call-refs)
(set-calls-known?! lambda-node))
(set-compiler-parameter! 'determine-lambda-protocol determine-lambda-protocol)
(define (unknown-call->known-call call)
(remove-call-arg call 2) ; remove the protocol
(set-call-primop! call
(case (primop-id (call-primop call))
((unknown-call)
(get-primop (enum primop call)))
((unknown-tail-call)
(get-primop (enum primop tail-call)))
(else
(bug "odd primop in call ~S" call)))))
; CONT is the continuation passed to PROCS.
(define (determine-continuation-protocol cont procs)
(for-each (lambda (proc)
(let ((cont-var (car (lambda-variables proc))))
(walk-refs-safely
(lambda (ref)
(let ((call (node-parent ref)))
(unknown-return->known-return call cont-var cont)))
cont-var)))
procs))
(set-compiler-parameter! 'determine-continuation-protocol
determine-continuation-protocol)
; If the return is actually a tail-recursive call we change it to
; a non-tail-recursive one (since we have identified the continuation)
; and insert the appropriate continuation.
(define (unknown-return->known-return call cont-var cont)
(case (primop-id (call-primop call))
((unknown-return)
(set-call-primop! call (get-primop (enum primop return))))
((unknown-tail-call tail-call)
(let* ((vars (map copy-variable (lambda-variables cont)))
(args (map make-reference-node vars)))
(let-nodes ((cont vars (return 0 (* cont-var) . args)))
(replace (call-arg call 0) cont)
(set-call-primop! call
(if (calls-this-primop? call 'tail-call)
(get-primop (enum primop call))
(get-primop (enum primop unknown-call))))
(set-call-exits! call 1)
(if (and (calls-this-primop? call 'unknown-call)
(goto-protocol? (literal-value (call-arg call 2))))
(set-literal-value! (call-arg call 2) #f)))))
(else
(bug "odd return primop ~S" (call-primop call)))))
(define normal-protocol #f)
(define goto-protocol 'goto)
(define (goto-protocol? x)
(eq? x goto-protocol))
(set-compiler-parameter! 'lookup-primop get-prescheme-primop)
(set-compiler-parameter! 'type/unknown type/unknown)
(set-compiler-parameter! 'type-eq? type-eq?)

324
ps-compiler/prescheme/substitute.scm
View File

@ -1,324 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Substituting new variables for old in expressions.
(define *free-exp-vars* #f)
(define (substitute-in-expression exp)
(set! *free-exp-vars* '())
(set! *letrec-datas* '())
(let* ((exp (substitute-in-exp exp))
(free *free-exp-vars*))
(set! *free-exp-vars* '())
(for-each (lambda (var)
(set-variable-flag! var #f))
free)
(values exp free)))
(define global-marker (list 'global))
(define (note-binding-use! binding)
(let ((var (binding-place binding)))
(if (variable? var)
(note-variable-use! var))))
(define (note-variable-use! var)
(cond ((not (eq? (variable-flag var) global-marker))
(set! *free-exp-vars* (cons var *free-exp-vars*))
(set-variable-flag! var global-marker))))
; Main dispatch
(define (substitute-in-exp node)
((operator-table-ref substitutions (node-operator-id node))
node))
; Particular operators
(define substitutions
(make-operator-table
(lambda (node)
(error "no substitution for node ~S" node))))
(define (default-substitution node)
(make-similar-node node
(cons (car (node-form node))
(map substitute-in-exp (cdr (node-form node))))))
(define (define-substitution name proc)
(operator-define! substitutions name #f proc))
(define-substitution 'literal identity)
(define-substitution 'quote identity)
(define-substitution 'unspecific identity)
(define-substitution 'real-external
(lambda (node)
(let* ((exp (node-form node))
(type (expand-type-spec (cadr (node-form (caddr exp))))))
(make-literal-node (make-external-value (node-form (cadr exp))
type)))))
(define op/literal (get-operator 'literal))
(define (make-literal-node x)
(make-node op/literal x))
; We copy the names because the same node may occur in multiple places
; in the tree.
(define-substitution 'lambda
(lambda (node)
(let* ((new-names (copy-names (cadr (node-form node))))
(body (substitute-in-exp (caddr (node-form node)))))
(make-similar-node node
(list (car (node-form node))
new-names
body)))))
(define (copy-names names)
(map (lambda (name)
(let ((new (make-similar-node name (node-form name))))
(node-set! name 'substitute new)
new))
names))
(define-substitution 'name
(lambda (node)
(substitute-name-node node #f)))
(define (substitute-name-node node call?)
(let ((node (name-node-substitute node)))
(let ((binding (node-ref node 'binding)))
(cond ((not binding)
(note-name-use! node)
node)
((primitive? (binding-static binding))
(make-primitive-node (binding-static binding) call?))
((location? (binding-place binding))
(let ((value (contents (binding-place binding))))
(if (constant? value)
(make-literal-node value)
(identity
(bug "name ~S has non-constant location ~S" node value)))))
(else
(note-binding-use! binding)
node)))))
(define (name-node-substitute node)
(let loop ((node node) (first? #t))
(cond ((node-ref node 'substitute)
=> (lambda (node)
(loop node #f)))
((and first? (not (node-ref node 'binding)))
(user-error "unbound variable ~S" (node-form node)))
(else
node))))
(define-substitution 'set!
(lambda (node)
(let* ((exp (node-form node))
(name (substitute-name-node (cadr exp) #f))
(binding (node-ref name 'binding)))
(if (not (binding? binding))
(user-error "SET! on local variable ~S" (node-form (cadr exp))))
((structure-ref forms note-variable-set!!)
(binding-place binding))
(note-binding-use! binding)
(make-similar-node node
(list (car exp)
name
(substitute-in-exp (caddr exp)))))))
(define-substitution 'call
(lambda (node)
(let ((proc (car (node-form node)))
(args (cdr (node-form node))))
(make-similar-node node
(cons (if (name-node? proc)
(substitute-name-node proc #t)
(substitute-in-exp proc))
(map substitute-in-exp args))))))
; Flush GOTO when it is used with a primitive.
(define-substitution 'goto
(lambda (node)
(let ((proc (cadr (node-form node)))
(args (cddr (node-form node))))
(if (and (name-node? proc)
(bound-to-primitive? proc))
(make-node (get-operator 'call)
(cons (substitute-name-node proc #t)
(map substitute-in-exp args)))
(make-similar-node node
(cons 'goto
(cons (if (name-node? proc)
(substitute-name-node proc #t)
(substitute-in-exp proc))
(map substitute-in-exp args))))))))
(define name-node? (node-predicate 'name))
(define (bound-to-primitive? node)
(let ((node (name-node-substitute node)))
(let ((binding (node-ref node 'binding)))
(and binding
(primitive? (binding-static binding))))))
(define-substitution 'begin default-substitution)
(define-substitution 'if default-substitution)
; drop the loophole part
(define-substitution 'loophole
(lambda (node)
(substitute-in-exp (caddr (node-form node)))))
;----------------------------------------------------------------
; Breaking LETREC's down to improve type inference and make compilation
; easier.
(define-substitution 'letrec
(lambda (node)
(let* ((exp (node-form node))
(vars (map car (cadr exp)))
(vals (map cadr (cadr exp))))
(receive (names datas)
(copy-letrec-names vars vals exp)
(for-each (lambda (data value)
(expand-letrec-value data value datas exp))
datas
vals)
(let ((sets (strongly-connected-components datas
letrec-data-uses
letrec-data-seen?
set-letrec-data-seen?!)))
;; so we don't keep track of which vars are referenced in the body
(for-each (lambda (d)
(set-letrec-data-seen?! d #t))
datas)
(do ((sets sets (cdr sets))
(exp (substitute-in-exp (caddr exp))
(build-letrec (car sets) exp)))
((null? sets)
(for-each (lambda (n)
(node-set! n 'letrec-data #f))
names)
exp)))))))
(define-record-type letrec-data
(name ; the name node for which this data exists
marker ; a unique marker for this LETREC
cell? ; variable is SET! or its value is not a (lambda ...). This is
; always #F until I can think of a reason to allow otherwise.
)
(value ; the expanded value of this variable
uses ; a list of variables that VALUE uses
seen? ; #T if this has been seen before during the current expansion
))
(define (copy-letrec-names names vals marker)
(let ((names (map (lambda (name value)
(let ((new (make-similar-node name (node-form name)))
(cell? #f)) ; we no longer allow SET! on LETREC vars.
(node-set! new 'letrec-data
(letrec-data-maker new marker cell?))
(node-set! name 'substitute new)
new))
names
vals)))
(values names (map (lambda (name) (node-ref name 'letrec-data)) names))))
(define lambda-node? (node-predicate 'lambda))
; List of LETREC bound variables currently in scope.
(define *letrec-datas* '())
(define (note-name-use! name)
(let ((data (node-ref name 'letrec-data)))
(cond ((and data (not (letrec-data-seen? data)))
(set-letrec-data-seen?! data #t)
(set! *letrec-datas* (cons data *letrec-datas*))))))
; Expand VALUE and determine which of DATAS it uses.
(define (expand-letrec-value data value datas mark)
(let ((old-letrec-vars *letrec-datas*))
(set! *letrec-datas* '())
(for-each (lambda (d) (set-letrec-data-seen?! d #f)) datas)
(set-letrec-data-value! data (substitute-in-exp value))
(receive (ours others)
(partition-list (lambda (data)
(eq? (letrec-data-marker data) mark))
*letrec-datas*)
(set! *letrec-datas* (append others old-letrec-vars))
(set-letrec-data-uses! data ours))))
; If there is only one variable and its value doesn't reference it, then
; use a LET instead of a LETREC. Variables whose value is either set! or
; not a lambda have explicit cells introduced.
(define (build-letrec datas body)
(if (and (null? (cdr datas))
(not (memq? (car datas)
(letrec-data-uses (car datas)))))
(make-let-node (map letrec-data-name datas)
(map letrec-data-value datas)
body)
(receive (cells normal)
(partition-list letrec-data-cell? datas)
(make-let-node (map letrec-data-name cells)
(map (lambda (ignore) (unspecific-node))
cells)
(make-letrec-node (map letrec-data-name normal)
(map letrec-data-value normal)
(make-begin-node
(append (map letrec-data->set! cells)
(list body))))))))
(define op/unspecific (get-operator 'unspecific))
(define op/set! (get-operator 'set!))
(define (unspecific-node)
(make-node op/unspecific '()))
(define (letrec-data->set! data)
(make-node op/set!
(list 'set!
(letrec-data-name data)
(letrec-data-value data))))
(define (make-let-node names values body)
(if (null? names)
body
(make-node op/call
(cons (make-node op/lambda
(list 'lambda names body))
values))))
(define (make-letrec-node names values body)
(if (null? names)
body
(make-node op/letrec
(list 'letrec
(map list names values)
body))))
(define (make-begin-node nodes)
(if (null? (cdr nodes))
(car nodes)
(make-node op/begin (cons 'begin nodes))))
(define op/call (get-operator 'call))
(define op/lambda (get-operator 'lambda))
(define op/letrec (get-operator 'letrec))
(define op/begin (get-operator 'begin))
;----------------------------------------------------------------
; A version of MAKE-SIMILAR-NODE that actually makes a new node.
; I wish this could keep the old node's list of properties.
(define (make-similar-node node form)
(make-node (node-operator node) form))

25
ps-compiler/prescheme/test/boolean.scm
View File

@ -1,25 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define (test in out)
(write-string '"Type in two numbers: " out)
(let* ((i (read-integer in))
(j (read-integer in)))
(write-string '"A = " out)
(write-integer i out)
(newline out)
(write-string '"B = " out)
(write-integer j out)
(newline out)
(write-string (if (and (< i j)
(or (= (remainder i '2) '0)
(= (remainder j '2) '0)))
'"A < B and A or B is even"
'"A >= B or A and B are both odd")
out)
(newline out)
'0))
(test (current-input-port) (current-output-port))

72
ps-compiler/prescheme/test/buffer.scm
View File

@ -1,72 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; (port->stream port type) -> stream or error value
; (
;
;
;
(define-record-type stream
make-stream
(port port)
(type int8u)
(buffer int32) ; pointer the start of the buffer
(size int32)
(loc int32) ; pointer to the next char to be read or the next slot to
; be written
(limit int32)) ; end of the available characters
(define buffer-size 1024)
(define (port->stream port type)
(let ((buffer (allocate-memory buffer-size))
(stream (make-stream)))
(if (or (null-memory? buffer)
(null-pointer? stream))
(error "out of memory"))
(set-stream-port! stream port)
(set-stream-type! stream type)
(set-stream-buffer! stream buffer)
(set-stream-size! stream buffer-size)
(set-stream-loc! stream buffer)
(set-stream-limit! stream buffer)
buffer))
(define (stream-read-char stream)
(let ((loc (stream-loc stream)))
(cond ((< loc (stream-limit stream))
(let ((ch (unsigned-byte-ref loc)))
(set-stream-loc! stream (+ 1 (stream-loc stream)))
ch))
(else
(let* ((buffer (stream-buffer stream))
(count (read-block (stream-port stream)
buffer
(stream-size stream))))
(cond ((= count 0) ; EOF
0)
(else
(set-stream-loc! stream (+ buffer 1))
(set-stream-limit! stream (+ buffer count))
(unsigned-byte-ref buffer))))))))
; this will need to be PCLUSR'd.
(define (stream-write-char stream char)
(let ((loc (stream-loc stream)))
(cond ((< loc (stream-limit stream))
(unsigned-byte-set! loc char)
(set-stream-loc! stream (+ 1 (stream-loc stream))))
(else
(let* ((buffer (stream-buffer stream))
(count (write-block (stream-port stream)
buffer
(stream-limit stream))))
(cond ((= count 0) ; EOF
0)
(else
(set-stream-loc! stream (+ buffer 1))
(set-stream-limit! stream (+ buffer count))
(unsigned-byte-ref buffer))))))))

11
ps-compiler/prescheme/test/bvector.scm
View File

@ -1,11 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define (test)
(let ((v (make-byte-vector 10))
(out (current-output-port)))
(write-number (byte-vector-ref v 4) out)
(byte-vector-set! v 5 100)
(write-number (byte-vector-ref v 5) out)
(write-number (byte-vector-word-ref v 4) out)))

18
ps-compiler/prescheme/test/cell.scm
View File

@ -1,18 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define *count* 0)
(define (increment)
(set! *count* (+ *count* 1)))
(define (value)
*count*)
(define (test out)
(increment)
(increment)
(write-number (value) out)
(newline out))
(test (current-output-port))

29
ps-compiler/prescheme/test/coerce.scm
View File

@ -1,29 +0,0 @@
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
(define-local-syntax (define-primitive id nargs)
(let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
`(define (,id . ,args)
(call-primitively ,id . ,args))))
(define-primitive make-byte-vector 1)
(define-primitive null-pointer? 1)
(define (byte-vector-ref vec index)
(call-primitively byte-contents-int8 (pointer-add vec index)))
(define (byte-vector-set! vec index value)
(call-primitively byte-set-contents-int8! (pointer-add vec index) value))
(define (pointer->integer x)
(call-primitively coerce x '(pointer int8) 'int32))
(define (integer->pointer x)
(call-primitively coerce x 'int32 '(pointer int8)))
(define (test)
(let ((bv (make-byte-vector 10)))
(if (null-pointer? bv)
100
(pointer->integer bv))))

Some files were not shown because too many files have changed in this diff Show More