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

Unpack disk3.tgz

This commit is contained in:
Lassi Kortela 2023-05-20 12:57:06 +03:00
parent 3a12151067
commit 777c904054
66 changed files with 30520 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
conio.h Normal file
View File

@ -0,0 +1,16 @@
/**
*
* This header file defines an equivalence between several of the
* standard level 2 I/O functions and their console I/O counterparts.
* Use this header file for programs which perform all of these functions
* to the console only, and need an unbuffered, direct interface to the
* user's console. See Section 3.2.3 of the manual for more information.
*
**/
#define getchar getch
#define putchar putch
#define gets cgets
#define puts cputs
#define printf cprintf
#define scanf cscanf


66
ctype.h Normal file
View File

@ -0,0 +1,66 @@
/**
*
* This header file defines various ASCII character manipulation macros,
* as follows:
*
* isalpha(c) non-zero if c is alpha
* isupper(c) non-zero if c is upper case
* islower(c) non-zero if c is lower case
* isdigit(c) non-zero if c is a digit (0 to 9)
* isxdigit(c) non-zero if c is a hexadecimal digit (0 to 9, A to F,
* a to f)
* isspace(c) non-zero if c is white space
* ispunct(c) non-zero if c is punctuation
* isalnum(c) non-zero if c is alpha or digit
* isprint(c) non-zero if c is printable (including blank)
* isgraph(c) non-zero if c is graphic (excluding blank)
* iscntrl(c) non-zero if c is control character
* isascii(c) non-zero if c is ASCII
* iscsym(c) non-zero if valid character for C symbols
* iscsymf(c) non-zero if valid first character for C symbols
*
**/
#define _U 1 /* upper case flag */
#define _L 2 /* lower case flag */
#define _N 4 /* number flag */
#define _S 8 /* space flag */
#define _P 16 /* punctuation flag */
#define _C 32 /* control character flag */
#define _B 64 /* blank flag */
#define _X 128 /* hexadecimal flag */
extern char _ctype[]; /* character type table */
#define isalpha(c) (_ctype[(c)+1]&(_U|_L))
#define isupper(c) (_ctype[(c)+1]&_U)
#define islower(c) (_ctype[(c)+1]&_L)
#define isdigit(c) (_ctype[(c)+1]&_N)
#define isxdigit(c) (_ctype[(c)+1]&_X)
#define isspace(c) (_ctype[(c)+1]&_S)
#define ispunct(c) (_ctype[(c)+1]&_P)
#define isalnum(c) (_ctype[(c)+1]&(_U|_L|_N))
#define isprint(c) (_ctype[(c)+1]&(_P|_U|_L|_N|_B))
#define isgraph(c) (_ctype[(c)+1]&(_P|_U|_L|_N))
#define iscntrl(c) (_ctype[(c)+1]&_C)
#define isascii(c) ((unsigned)(c)<=127)
#define iscsym(c) (isalnum(c)||(((c)&127)==0x5f))
#define iscsymf(c) (isalpha(c)||(((c)&127)==0x5f))
#define toupper(c) (islower(c)?((c)-('a'-'A')):(c))
#define tolower(c) (isupper(c)?((c)+('a'-'A')):(c))
#define toascii(c) ((c)&127)
/**
*
* Define NULL if it's not already defined
*
*/
#ifndef NULL
#if SPTR
#define NULL 0 /* null pointer value */
#else
#define NULL 0L
#endif
#endif

476
dos.h Normal file
View File

@ -0,0 +1,476 @@
/**
*
* This header file supplies information needed to interface with the
* particular operating system and C compiler being used.
*
**/
/**
*
* Define NULL if it's not already defined
*
*/
#ifndef NULL
#if SPTR
#define NULL 0 /* null pointer value */
#else
#define NULL 0L
#endif
#endif
/**
*
* The following symbols specify which operating system is being used.
*
* CPM Any CP/M OS
* CPM80 CP/M for Intel 8080 or Zilog Z80
* CPM86 CP/M for Intel 8086
* CPM68 CP/M for Motorola 68000
* MSDOS Microsoft's MSDOS
*
* Note: CPM will be set to 1 for any of the above.
*
* UNIX "Standard" UNIX
* MIBS General Automation's MIBS OS
*
*/
#if CPM80
#define CPM 1
#endif
#if CPM86
#define CPM 1
#endif
#if CPM68
#define CPM 1
#endif
#if MSDOS
#define CPM 1
#endif
/**
*
* The following definitions specify the particular C compiler being used.
*
* LATTICE Lattice C compiler
*
*/
#define LATTICE 1
/**
*
* The following type definitions take care of the particularly nasty
* machine dependency caused by the unspecified handling of sign extension
* in the C language. When converting "char" to "int" some compilers
* will extend the sign, while others will not. Both are correct, and
* the unsuspecting programmer is the loser. For situations where it
* matters, the new type "byte" is equivalent to "unsigned char".
*
*/
#if LATTICE
typedef unsigned char byte;
#endif
/**
*
* Miscellaneous definitions
*
*/
#define SECSIZ 128 /* disk sector size */
#if CPM
#define DMA (char *)0x80 /* disk buffer address */
#endif
/**
*
* The following structure is a File Control Block. Operating systems
* with CPM-like characteristics use the FCB to store information about
* a file while it is open.
*
*/
#if CPM
struct FCB
{
char fcbdrv; /* drive code */
char fcbnam[8]; /* file name */
char fcbext[3]; /* file name extension */
#if MSDOS
short fcbcb; /* current block number */
short fcblrs; /* logical record size */
long fcblfs; /* logical file size */
short fcbdat; /* create/change date */
char fcbsys[10]; /* reserved */
char fcbcr; /* current record number */
long fcbrec; /* random record number */
#else
char fcbexn; /* extent number */
char fcbs1; /* reserved */
char fcbs2; /* reserved */
char fcbrc; /* record count */
char fcbsys[16]; /* reserved */
char fcbcr; /* current record number */
short fcbrec; /* random record number */
char fcbovf; /* random record overflow */
#endif
};
#define FCBSIZ sizeof(struct FCB)
#endif
/**
*
* The following symbols define the sizes of file names and node names.
*
*/
#if CPM
#define FNSIZE 13 /* maximum file node size */
#define FMSIZE 64 /* maximum file name size */
#define FESIZE 4 /* maximum file extension size */
#else
#define FNSIZE 16 /* maximum file node size */
#define FMSIZE 64 /* maximum file name size */
#define FESIZE 4 /* maximum file extension size */
#endif
/**
*
* The following structures define the 8086 registers that are passed to
* various low-level operating system service functions.
*
*/
#if I8086
struct XREG
{
short ax,bx,cx,dx,si,di;
};
struct HREG
{
byte al,ah,bl,bh,cl,ch,dl,dh;
};
union REGS
{
struct XREG x;
struct HREG h;
};
struct SREGS
{
short es,cs,ss,ds;
};
struct XREGS
{
short ax,bx,cx,dx,si,di,ds,es;
};
union REGSS
{
struct XREGS x;
struct HREG h;
};
#endif
/**
*
* The following codes are returned by the low-level operating system service
* calls. They are usually placed into _OSERR by the OS interface functions.
*
*/
#if MSDOS
#define E_FUNC 1 /* invalid function code */
#define E_FNF 2 /* file not found */
#define E_PNF 3 /* path not found */
#define E_NMH 4 /* no more file handles */
#define E_ACC 5 /* access denied */
#define E_IFH 6 /* invalid file handle */
#define E_MCB 7 /* memory control block problem */
#define E_MEM 8 /* insufficient memory */
#define E_MBA 9 /* invalid memory block address */
#define E_ENV 10 /* invalid environment */
#define E_FMT 11 /* invalid format */
#define E_IAC 12 /* invalid access code */
#define E_DATA 13 /* invalid data */
#define E_DRV 15 /* invalid drive code */
#define E_RMV 16 /* remove denied */
#define E_DEV 17 /* invalid device */
#define E_NMF 18 /* no more files */
#endif
/**
*
* This structure contains disk size information returned by the getdfs
* function.
*/
struct DISKINFO
{
unsigned short free; /* number of free clusters */
unsigned short cpd; /* clusters per drive */
unsigned short spc; /* sectors per cluster */
unsigned short bps; /* bytes per sector */
};
/**
*
* The following structure is used by the dfind and dnext functions to
* hold file information.
*
*/
struct FILEINFO
{
char resv[21]; /* reserved */
char attr; /* actual file attribute */
long time; /* file time and date */
long size; /* file size in bytes */
char name[13]; /* file name */
};
/**
*
* The following structure appears at the beginning (low address) of
* each free memory block.
*
*/
struct MELT
{
struct MELT *fwd; /* points to next free block */
#if SPTR
unsigned size; /* number of MELTs in this block */
#else
long size; /* number of MELTs in this block */
#endif
};
#define MELTSIZE sizeof(struct MELT)
/**
*
* The following structure is a device header. It is copied to _OSCED
* when a critical error occurs.
*
*/
struct DEV
{
long nextdev; /* long pointer to next device */
short attr; /* device attributes */
short sfunc; /* short pointer to strategy function */
short ifunc; /* short pointer to interrupt function */
char name[8]; /* device name */
};
/**
*
* The following structure contains country-dependent information returned
* by the getcdi function.
*
*/
struct CDI2 /* DOS Version 2 format */
{
short fdate; /* date/time format */
/* 0 => USA (h:m:s m/d/y) */
/* 1 => Europe (h:m:s d/m/y) */
/* 2 => Japan (h:m:s d:m:y) */
char curr[2]; /* currency symbol and null */
char sthou[2]; /* thousands separator and null */
char sdec[2]; /* decimal separator and null */
char resv[24]; /* reserved */
};
struct CDI3 /* DOS Version 3 format */
{
short fdate; /* date format */
/* 0 => USA (m d y) */
/* 1 => Europe (d m y) */
/* 2 => Japan (d m y) */
char curr[5]; /* currency symbol, null-terminated */
char sthou[2]; /* thousands separator and null */
char sdec[2]; /* decimal separator and null */
char sdate[2]; /* date separator and null */
char stime[2]; /* time separator and null */
char fcurr; /* currency format */
/* Bit 0 => 0 if symbol precedes value */
/* => 1 if symbol follows value */
/* Bit 1 => number of spaces between value */
/* and symbol */
char dcurr; /* number of decimals in currency */
char ftime; /* time format */
/* Bit 0 => 0 if 12-hour clock */
/* => 1 if 24-hour clock */
long pcase; /* far pointer to case map function */
char sdata[2]; /* data list separator and null */
short resv[5]; /* reserved */
};
union CDI
{
struct CDI2 v2;
struct CDI3 v3;
};
/**
*
* Level 0 I/O services
*
**/
#ifndef NARGS
extern void chgdta(char *);
extern int chgfa(char *, int);
extern int chgft(int, long);
extern int dclose(int);
extern int dcreat(char *, int);
extern int dcreatx(char *, int);
extern int dfind(struct FILEINFO *, char *, int);
extern int dnext(struct FILEINFO *);
extern int dopen(char *, int);
extern unsigned dread(int, char *, unsigned);
extern long dseek(int, long, int);
extern int dunique(char *, int);
extern unsigned dwrite(int, char *, unsigned);
extern int getcd(int,char *);
extern int getch(void);
extern int getche(void);
extern int getdfs(int, struct DISKINFO *);
extern char *getdta(void);
extern int getfa(char *);
extern int getfc(int, int *);
extern long getft(int);
extern int getvfy(void);
extern int kbhit(void);
extern int putch(int);
extern int rlock(int, long, long);
extern void rstdta(void);
extern void rstvfy(void);
extern int runlk(int, long, long);
extern void setvfy(void);
extern int ungetch(int);
#else
extern void chgdta();
extern int chgfa();
extern int chgft();
extern int dclose();
extern int dcreat();
extern int dcreatx();
extern int dfind();
extern int dnext();
extern int dopen();
extern unsigned dread();
extern long dseek();
extern int dunique();
extern unsigned dwrite();
extern int getcd();
extern int getch();
extern int getche();
extern int getdfs();
extern char *getdta();
extern int getfa();
extern int getfc();
extern long getft();
extern int getvfy();
extern int kbhit();
extern int putch();
extern int rlock();
extern void rstdta();
extern void rstvfy();
extern int runlk();
extern void setvfy();
extern int ungetch();
#endif
/**
*
* Miscellaneous external definitions
*
*/
#ifndef NARGS
extern int chgclk(unsigned char *);
extern int chgdsk(int);
extern char *envpack(char **, char **);
extern int envunpk(char *);
#if SPTR
extern unsigned FP_OFF(long);
extern unsigned FP_SEG(long);
#else
extern unsigned FP_OFF(char *);
extern unsigned FP_SEG(char *);
#endif
extern long ftpack(char *);
extern void ftunpk(long, char *);
extern int getbrk(void);
extern int getcdi(int, struct CDI3 *);
extern void getclk(unsigned char *);
extern int getdsk(void);
extern int getpf(char *, char *);
extern int getpfe(char *, char *);
extern unsigned inp(unsigned);
extern int int86(int, union REGS *, union REGS *);
extern int int86s(int, union REGSS *, union REGSS *);
extern int int86x(int, union REGS *, union REGS *, struct SREGS *);
extern int intdos(union REGS *, union REGS *);
extern int intdoss(union REGSS *, union REGSS *);
extern int intdosx(union REGS *, union REGS *, struct SREGS *);
extern int isnet(void);
extern int isnetdc(int);
extern int isnetfh(int);
extern int isneton(void);
extern void makedv(char *, unsigned *, unsigned *);
extern void makepv(int(*)(), unsigned *, unsigned *);
extern void movedata(unsigned, unsigned, unsigned, unsigned, unsigned);
extern int onbreak(int(*)());
extern void onerror(int);
extern void outp(unsigned, unsigned);
extern void peek(unsigned, unsigned, char *, unsigned);
extern void poke(unsigned, unsigned, char *, unsigned);
extern int poserr(char *);
extern void rstbrk(void);
extern void rstdsk(void);
extern int setcdi(int);
extern void setbrk(void);
#else
extern int chgclk();
extern int chgdsk();
extern char *envpack();
extern int envunpk();
extern unsigned FP_OFF();
extern unsigned FP_SEG();
extern long ftpack();
extern void ftunpk();
extern int getbrk();
extern int getcdi();
extern void getclk();
extern int getdsk();
extern int getpf();
extern int getpfe();
extern unsigned inp();
extern int int86();
extern int int86s();
extern int int86x();
extern int intdos();
extern int intdoss();
extern int intdosx();
extern int isnet();
extern int isnetdc();
extern int isnetfh();
extern int isneton();
extern void makedv();
extern void makepv();
extern void movedata();
extern int onbreak();
extern void onerror();
extern void outp();
extern void peek();
extern void poke();
extern int poserr();
extern void rstbrk();
extern void rstdsk();
extern int setcdi();
extern void setbrk();
#endif

193
dos.mac Normal file
View File

@ -0,0 +1,193 @@
.XLIST
PAGE 58,132
;**
;
; This macro library defines the operating environment for the 8086 S
; memory model, which allows 64Kbytes of data and 64Kbytes of program.
;
;**
MSDOS EQU 2
;**
;
; The following symbols define the 8086 memory mode being used. Set LPROG
; to 1 for a large program segment (greater than 64K-bytes), and set LDATA
; to 1 for a large data segment. Set COM to 1 to generate .COM files
; instead of .EXE files. Note that if COM is not zero, then LPROG and
; LDATA must be 0.
;
;**
COM EQU 0
LPROG EQU 0
LDATA EQU 0
;**
;
; The following symbols are established via LPROG and LDATA as follows:
;
; S8086 set for small model (small prog, small data)
; D8086 set for model with large data, small prog
; P8086 set for model with large prog, small data
; L8086 set for large model
;
;**
IF (LPROG EQ 0) AND (LDATA EQ 0)
S8086 EQU 1
D8086 EQU 0
P8086 EQU 0
L8086 EQU 0
ENDIF
IF (LPROG EQ 0) AND (LDATA NE 0)
S8086 EQU 0
D8086 EQU 1
P8086 EQU 0
L8086 EQU 0
ENDIF
IF (LPROG NE 0) AND (LDATA EQ 0)
S8086 EQU 0
D8086 EQU 0
P8086 EQU 1
L8086 EQU 0
ENDIF
IF (LPROG NE 0) AND (LDATA NE 0)
S8086 EQU 0
D8086 EQU 0
P8086 EQU 0
L8086 EQU 1
ENDIF
;**
;
; The DSEG and PSEG macros are defined to generate the appropriate GROUP
; and SEGMENT statements for the memory model being used. The ENDDS and
; ENDPS macros are then used to end the segments.
;
;**
DSEG MACRO
DGROUP GROUP DATA
DATA SEGMENT WORD PUBLIC 'DATA'
ASSUME DS:DGROUP
ENDM
ENDDS MACRO
DATA ENDS
ENDM
IF S8086
PSEG MACRO
PGROUP GROUP PROG
PROG SEGMENT BYTE PUBLIC 'PROG'
ASSUME CS:PGROUP
ENDM
ENDPS MACRO
PROG ENDS
ENDM
ENDIF
IF D8086
PSEG MACRO
CGROUP GROUP CODE
CODE SEGMENT BYTE PUBLIC 'CODE'
ASSUME CS:CGROUP
ENDM
ENDPS MACRO
CODE ENDS
ENDM
ENDIF
IF P8086
PSEG MACRO
_CODE SEGMENT BYTE PUBLIC 'CODE'
ASSUME CS:_CODE
ENDM
ENDPS MACRO
_CODE ENDS
ENDM
ENDIF
IF L8086
PSEG MACRO
_PROG SEGMENT BYTE PUBLIC 'PROG'
ASSUME CS:_PROG
ENDM
ENDPS MACRO
_PROG ENDS
ENDM
ENDIF
;**
;
; The BEGIN and ENTRY macros establish appropriate function entry points
; depending on whether NEAR or FAR program addressing is being used. The
; only difference between the two is that BEGIN generates a PROC operation
; to start a segment.
;
BEGIN MACRO NAME ; begin a function
PUBLIC NAME
IF LPROG
NAME PROC FAR
ELSE
NAME PROC NEAR
ENDIF
ENDM
ENTRY MACRO NAME
PUBLIC NAME
IF LPROG
NAME LABEL FAR
ELSE
NAME LABEL NEAR
ENDIF
ENDM
;**
;
; The following symbols are defined to help set up a STRUC defining the
; stack frame:
;
; CPSIZE -> code pointer size (2 or 4)
; DPSIZE -> data pointer size (2 or 4)
;
; These wouldn't be necessary if it were possible to use macros or even
; conditionals within a STRUC.
;
IF LPROG
CPSIZE EQU 4
ELSE
CPSIZE EQU 2
ENDIF
IF LDATA
DPSIZE EQU 4
ELSE
DPSIZE EQU 2
ENDIF
;
; The SETX macro sets the symbol X to 4 if LPROG is 0 or to 6 otherwise.
; X can then be used to skip past the BP and return address save area
; in the stack frame when accessing the function arguments.
;
SETX MACRO
IF LPROG
X EQU 6
ELSE
X EQU 4
ENDIF
ENDM
;
; The PEXTRN macro defines an external pointer in the data segment.
;
PEXTRN MACRO NAME
IF LDATA
EXTRN NAME:DWORD
ELSE
EXTRN NAME:WORD
ENDIF
ENDM
.LIST

2
freesp.equ Normal file
View File

@ -0,0 +1,2 @@
dog equ 1


167
math.h Normal file
View File

@ -0,0 +1,167 @@
/**
*
* Structure to hold information about math exceptions
*
*/
struct exception
{
int type; /* error type */
char *name; /* math function name */
double arg1, arg2; /* function arguments */
double retval; /* proposed return value */
};
/*
*
* Exception type codes, found in exception.type
*
*/
#define DOMAIN 1 /* domain error */
#define SING 2 /* singularity */
#define OVERFLOW 3 /* overflow */
#define UNDERFLOW 4 /* underflow */
#define TLOSS 5 /* total loss of significance */
#define PLOSS 6 /* partial loss of significance */
/**
*
* Error codes generated by basic arithmetic operations (+ - * /)
*
*/
#define FPEUND 1 /* underflow */
#define FPEOVF 2 /* overflow */
#define FPEZDV 3 /* zero divisor */
#define FPENAN 4 /* not a number (invalid operation) */
#define FPECOM 5 /* not comparable */
/**
*
* Constants
*
*/
#define PI 3.14159265358979323846
#define PID2 1.57079632679489661923 /* PI divided by 2 */
#define PID4 0.78539816339744830962 /* PI divided by 4 */
#define I_PI 0.31830988618379067154 /* Inverse of PI */
#define I_PID2 0.63661977236758134308 /* Inverse of PID2 */
#define HUGE 1.797693e308 /* huge value */
#define TINY 2.2e-308 /* tiny value */
#define LOGHUGE 709.778 /* natural log of huge value */
#define LOGTINY -708.396 /* natural log of tiny value */
/**
*
* External declarations
*
*/
extern int _FPERR; /* floating point arithmetic error */
extern int errno; /* UNIX error code */
#ifndef NARGS
extern double acos(double);
extern double asin(double);
extern double atan(double);
extern double atan2(double, double);
extern double atof(char *);
extern double ceil(double);
extern double cos(double);
extern double cosh(double);
extern void CXFERR(int);
extern double drand48(void);
extern char *ecvt(double, int, int *, int *);
extern double erand48(short *);
extern double except(int, char *, double, double, double);
extern double exp(double);
extern double fabs(double);
extern char *fcvt(double, int, int *, int *);
extern double floor(double);
extern double fmod(double, double);
extern double frexp(double, int *);
extern char *gcvt(double, int, char *);
extern long jrand48(short *);
extern double ldexp(double, int);
extern void lcong48(short *);
extern double log(double);
extern double log10(double);
extern long lrand48(void);
extern int matherr(struct exception *);
extern double modf(double, double *);
extern long mrand48(void);
extern long nrand48(short *);
extern double pow(double, double);
extern int rand(void);
extern short *seed48(short *);
extern double sin(double);
extern double sinh(double);
extern double sqrt(double);
extern void srand(unsigned);
extern void srand48(long);
extern double tan(double);
extern double tanh(double);
#else
extern double acos();
extern double asin();
extern double atan();
extern double atan2();
extern double atof();
extern double ceil();
extern double cos();
extern double cosh();
extern void CXFERR();
extern double drand48();
extern char *ecvt();
extern double erand48();
extern double except();
extern double exp();
extern double fabs();
extern char *fcvt();
extern double floor();
extern double fmod();
extern double frexp();
extern char *gcvt();
extern long jrand48();
extern void lcong48();
extern double ldexp();
extern double log();
extern double log10();
extern long lrand48();
extern int matherr();
extern double modf();
extern long mrand48();
extern long nrand48();
extern double pow();
extern int rand();
extern short *seed48();
extern double sin();
extern double sinh();
extern double sqrt();
extern void srand();
extern void srand48();
extern double tan();
extern double tanh();
#endif
/**
*
* Macros
*
*/
#define abs(x) ((x)<0?-(x):(x))
#define max(a,b) ((a)>(b)?(a):(b))
#define min(a,b) ((a)<=(b)?(a):(b))
/**
*
* Define NULL if it's not already defined
*
*/
#ifndef NULL
#if SPTR
#define NULL 0 /* null pointer value */
#else
#define NULL 0L
#endif
#endif

17
memtype.equ Normal file
View File

@ -0,0 +1,17 @@
IFDEF REGMEM
MIN_PAGESIZE EQU 0C00H ; Minimum page size for conventional memory
ENDIF
IFDEF EXPMEM
MIN_PAGESIZE EQU 04000h ; Minimum page size for expanded memory
ENDIF
IFDEF EXTMEM
MIN_PAGESIZE EQU 04000h ; Minimum page size for extended memory
ENDIF
IFDEF PROMEM
MIN_PAGESIZE EQU 0C00h ; Minimum page size for protected memory
MAX_PAGESIZE EQU 07FF0h ; Maximum page size for protected memory
ENDIF


17
memtype.h Normal file
View File

@ -0,0 +1,17 @@
#ifdef REGMEM
#define MIN_PAGESIZE 0x0C00
#endif
#ifdef EXPMEM
#define MIN_PAGESIZE 0x4000
#endif
#ifdef EXTMEM
#define MIN_PAGESIZE 0x4000
#endif
#ifdef PROMEM
#define MIN_PAGESIZE 0x0C00
#define MAX_PAGESIZE 0x7FF0
#endif


12
pcmake.equ Normal file
View File

@ -0,0 +1,12 @@
;
; A list of EQU's for the various types of PCs
;
UNKNOWN equ 0
TIPC equ 1
IBMPC equ 0ffh
IBMXT equ 0feh
IBMJR equ 0fdh
IBMAT equ 0fch ;IBM PC-AT
IBM80 equ 0f8h ;IBM PS/2 Model 80
IBMTYPE equ 0f0h ;IBM machine types >= this value


10
pcmake.h Normal file
View File

@ -0,0 +1,10 @@
/* A list of DEFINES's for the various types of PCs */
#define UNKNOWN 0
#define TIPC 1
#define IBMPC 0x0ff
#define IBMXT 0x0fe
#define IBMJR 0x0fd
#define IBMAT 0x0fc
#define IBM80 0xf8h ;IBM PS/2 Model 80
#define IBMTYPE 0xf0h ;IBM machine types >= this value


1403
prosprin.asm Normal file
View File

File diff suppressed because it is too large Load Diff

888
prosread.asm Normal file
View File

@ -0,0 +1,888 @@
; =====> PROSREAD.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* S-Expression reading *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 March 1986 *
;* Last Modification: 10 Feb 1987 *
;* *
;* tc 2/10/87 fix to convert first *
;* char after # to upper case *
;* tc 2/10/87 added support to do *
;* readline *
;***************************************
page 60,132
include scheme.equ
include sinterp.arg
SPACE equ 20h
CTRL_Z equ 1Ah
LINEFEED equ 0Ah
RETURN equ 0Dh
COM equ 3Bh
BK_SLASH equ 5Ch
BUFSIZE equ 256
TEST_NUM equ 8
EOFERR equ 1
SHARPERR equ 7
PORTERR equ -2
HEAPERR equ -3
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
public test_ch, t_array
extrn locases:word
extrn hicases:word
extrn CXFERR_s:word
extrn port_r:word
srd_str db "READ-ATOM",0
sln_str db "READ-LINE",0
inv_char db "Invalid character constant",0
limit dw ? ; current size of atom buffer
main_reg dw ? ; main register
flg_eof dw ? ; whether to flag end-of-file
atomb dw ? ; atom buffer
test_ch db 0Ah,20h,7Fh,0Ch,09h,08h,0Dh,1Bh ; special characters
char db 20h ; most recently received char
t_str1 db "NEWLINE",0
t_str2 db "SPACE",0
t_str3 db "RUBOUT",0
t_str4 db "PAGE",0
t_str5 db "TAB",0
t_str6 db "BACKSPACE",0
t_str7 db "RETURN",0
t_str8 db "ESCAPE",0
t_array dw t_str1
dw t_str2
dw t_str3
dw t_str4
dw t_str5
dw t_str6
dw t_str7
dw t_str8
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;;;***************************************************************************
;;; Support for read-line
;;;***************************************************************************
rln_proc proc
extrn next_SP:near
extrn src_err:near
public srd_line
srd_line: lods byte ptr ES:[SI]
save <SI>
add AX,offset reg0 ; compute register address
mov main_reg,AX
xor BX,BX
push BX
push AX
C_call get_port,,Load_ES ; get the port object
mov SP,BP ; get the return status
test AX,AX ; error returned?
jnz srd_lerr
pushm <tmp_disp,tmp_page,main_reg>
call sread_ln ; get a line
mov SP,BP
jmp next_SP ; return to interpreter
;
srd_lerr: lea BX,sln_str
jmp src_err ; link to error handler
rln_proc endp
;;;***************************************************************************
;;; Set up for the operation of reading a single line from the given port.
;;;***************************************************************************
extrn setabort:near
extrn abort:near
extrn ssetadr:near
srdlnarg struc
temp_r dw ? ; temporary storage
srdln_BP dw ? ; caller's BP
dw ? ; caller's return address
rp_reg dw ? ; port register
rpg dw ? ; adjusted page number
rdisp dw ? ; displacement
srdlnarg ends
;
public sread_at
sread_ln proc near
push BP
sub SP, offset srdln_BP ; allocate local storage
mov BP,SP
call setabort ; save stack pointer
pushm <[BP].rdisp,[BP].rpg>
call ssetadr ; set port address
mov SP,BP
test AX,AX ; check return status
jz srdl_010
mov AX,PORTERR ; port error
push AX
call abort
;
mov flg_eof,1 ; flag eof
srdl_010:
call rcvchar ; get char, eof won't return here
cmp AL,LINEFEED ; is char linefeed?
je srdl_010 ; if so, ignore
mov [BP].temp_r,AX ; save character read
mov AX,BUFSIZE ; Get buffer size
mov limit,AX
push AX
C_call getmem ; allocate buffer
mov SP,BP
cmp AX,0 ; memory available?
jne srdl_020
;error allocate C heap space
mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp srdln_ret
srdl_020: mov SI,AX
mov atomb,AX ; address of buffer
mov flg_eof,0 ; don't flag error on EOF
xor BX,BX ; index into buffer
mov AX,[BP].temp_r ; restore saved character
; read characters
srdln_cha:
cmp AL,RETURN ; Return character?
je srdln_ret ; yes, return
cmp AL,CTRL_Z ; EOF character?
je srdln_ret ; yes, return
cmp AL,LINEFEED ; Linefeed character?
je srdln_ret ; yes, don't put in atomb
pushm <AX,BX>
call addchar ; Add character to buffer
mov SP,BP
inc BX
srdln_nxt:
call rcvchar ; Get next character
jmp srdln_cha ; Go get next character
srdln_ret:
mov CX,STRTYPE ; Allocate string data type
mov [BP].temp_r,BX
pushm <BX,CX,main_reg>
c_call alloc_bl,,Load_ES
mov SP,BP
mov CX,3 ; Copy buffer to Scheme string
mov SI,atomb
pushm <[BP].temp_r,SI,CX,main_reg>
call toblock
mov AX,limit ; Release buffer
pushm <AX,atomb>
C_call rlsmem
mov SP,BP
mov flg_eof,1 ; Reset flags
mov limit,0
add SP,offset srdln_BP ; Deallocate local storage
pop BP
ret ; Return
sread_ln endp
;;;***************************************************************************
;;; Support for read-atom
;;;***************************************************************************
rds_proc proc
extrn next_SP:near
extrn src_err:near
public srd_atom
srd_atom: lods byte ptr ES:[SI]
save <SI>
add AX,offset reg0 ; compute register address
mov main_reg,AX
xor BX,BX
push BX
push AX
C_call get_port,,Load_ES ; get the port object
mov SP,BP ; get the return status
test AX,AX ; error returned?
jnz srd_err
pushm <tmp_disp,tmp_page,main_reg>
call sread_at ; sread_atom()
mov SP,BP
jmp next_SP ; return to interpreter
;
srd_err: lea BX,srd_str
jmp src_err ; link to error handler
rds_proc endp
;;;***************************************************************************
;;; Set up for the operation of reading a single atom from the given port.
;;; Special characters such as ')' are parsed as lists(!) to tell them from
;;; ordianry atoms.
;;;***************************************************************************
extrn setabort:near
extrn abort:near
extrn ssetadr:near
sreadarg struc
dw ? ; caller's BP
dw ? ; caller's return address
p_reg dw ? ; port register
pg dw ? ; adjusted page number
disp dw ? ; displacement
sreadarg ends
;
public sread_at
sread_at proc near
push BP
mov BP,SP
call setabort ; save stack pointer
mov BX,[BP].p_reg ;be certain main_reg gets set if
;sread_at gets called directly from C
mov main_reg,BX
pushm <[BP].disp,[BP].pg>
call ssetadr ; set port address
mov SP,BP
test AX,AX ; check return status
jz srd_010
mov AX,PORTERR ; port error
push AX
call abort
;
srd_010: mov flg_eof,1 ; initialization
mov limit,0
; skip spaces
srd_spa: call rcvchar
call ck_space ; check for space
test CX,CX
jz srd_spa ; yes, skip
; skip comments
srd_com: cmp AL,COM ; check for comment
jne srd_at
srd_c10: call rcvchar
cmp AL,RETURN
jne srd_c10 ; yes, ignore the whole line
jmp srd_spa
;
srd_at: test AL,AL ; null character?
jz srd_spa
call read_ato
pop BP
ret
sread_at endp
;;;***************************************************************************
;;; Fetch one character from the input stream
;;;***************************************************************************
extrn take_ch:near
rcvchar proc near
pop DX ; fetch return address
;
push DX ; save registers
push SI
push DI
push CX
push BX
call take_ch ; takechar()
pop BX ; restore registers
pop CX
pop DI
pop SI
pop DX
; Check the character
cmp AX,256
jge rcv_10
cmp AL,CTRL_Z ; EOF character?
je rcv_10 ; yes, jump
mov char,AL
jmp DX ; return to caller
; EOF character is fetched
rcv_10: cmp flg_eof,0 ; EOF flag set?
jne rcv_20 ; yes, error
mov AX,CTRL_Z
mov char,AL
jmp DX ; return to caller
;
rcv_20: mov AX,EOFERR
push AX
call abortrea ; abortread(EOFERR)
rcvchar endp
;;;***************************************************************************
;;; Read in an atom (symbol, string, number)
;;; Store the pointer to the atom in REG.
;;; Special characters such as ')' or ',' are read as atoms themselves.
;;; Normal atoms will end in a whitespace or a terminating macro character;
;;; strings end with the closing '"'.
;;; Numbers in the requested base are interpreted as such.
;;; On exit, the next character in the buffer is the one following the last
;;; character of the atom.
;;;***************************************************************************
extrn toblock:near
extrn cons:near
extrn buildint:near
extrn alloc_st:near
extrn scannum:near
extrn pushchar:near
readarg struc
num_base dw ? ; base of number
tmpreg dw ?
inputch dw ? ; whether the #\ macro is in effect
escaped dw ? ; whether an escape char is used
inflo dq ? ; for floating point value
bignum dw ?
biglimit dw ?
read_BP dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
readarg ends
;
read_ato proc near
push ES
push BP
sub SP,offset read_BP ; allocate local storage
mov BP,SP
xor CX,CX
mov [BP].tmpreg,AX
;;; cmp AL,SPACE ; check for space?
;;; jne read_at
;;; mov [DI].C_page,CX ; yes, form NIL and return
;;; mov [DI].C_disp,CX
;;; jmp read_end
read_at: mov flg_eof,CX ; initialization
mov [BP].inputch,CX
mov [BP].escaped,CX
mov CXFERR_s,CX
mov AX,BUFSIZE
mov limit,AX
mov [BP].num_base,10
push AX
C_call getmem ; allocate memory
mov SP,BP
cmp AX,0 ; memory available?
jne read_01
memerr: mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp read_ret
read_01: mov SI,AX
mov atomb,AX ; save the address of atom buffer
mov DI,main_reg
xor BX,BX
mov AX,[BP].tmpreg
; check for the special character first
cmp AL,5Bh ; [
je read_10
cmp AL,5Dh ; ]
je read_10
cmp AL,7Bh ; {
je read_10
cmp AL,7Dh ; }
je read_10
cmp AL,28h ; (
je read_10
cmp AL,29h ; )
je read_10
cmp AL,27h ; '
je read_10
cmp AL,60h ; `
jne read_st
; special character case
read_10: mov [SI],AL ; *atomb = ch
inc BX
jmp read_sp
;
read_st: cmp AL,22h ; "
jne read_co
; string case
push AX
call delimby ; get the string
mov SP,BP
mov [BP].tmpreg,BX ; save BX register
mov CX,STRTYPE
pushm <BX,CX,main_reg>
C_call alloc_bl,,Load_ES ; allocate string object
mov SP,BP
mov CX,3
mov SI,atomb
pushm <[BP].tmpreg,SI,CX,main_reg>
call toblock ; copy string to string object
jmp read_bye
;
read_co: cmp AL,2Ch ; ,
jne read_mac
; comma case
mov [SI],AL
inc BX
call rcvchar ; get the next character
cmp AL,40h ; check for @
je read_20
cmp AL,2Eh ; check for .
je read_20
jmp read_nor
read_20: mov [SI+BX],AL
inc BX
jmp read_sp
;
read_mac: cmp AL,23h ; #
je read_25
jmp read_sym
; macro case
read_25: mov flg_eof,1
read_30: test BX,BX ; first character?
jz read_34
read_32: jmp read_200 ; no, jump
;
read_34: cmp AL,23h ; #
jne read_32 ; no, jump
call rcvchar ; get the next character
call ck_space ; check for space
test CX,CX
jnz read_40
read_35: mov AX,SHARPERR ; yes, error
push AX
call abortrea
;
read_40: mov byte ptr [SI+1],AL ; save the character
push BX
mov BX,offset locases ; address of lower-case characters
xlat
pop BX ; restore registers
cmp AL,62h ; b?
jne read_d
mov [BP].num_base,2
jmp read_100
;
read_d: cmp AL,64h ; d?
jne read_x
mov [BP].num_base,10
jmp read_100
;
read_x: cmp AL,78h ; x?
je read_50
cmp AL,68h ; h?
jne read_o
read_50: mov [BP].num_base,16
jmp read_100
;
read_o: cmp AL,6Fh ; o?
jne read_ba
mov [BP].num_base,8
jmp read_100
;
read_ba: cmp AL,BK_SLASH ; \?
jne read_i
call rcvchar
pushm <AX,BX>
call addchar
mov SP,BP
inc BX
mov [BP].inputch,1
mov [BP].escaped,1
jmp read_100
;
read_i: cmp AL,69h ; i?
je read_100
cmp AL,65h ; e?
je read_100
cmp AL,73h ; s?
je read_100
cmp AL,6Ch ; l?
je read_100
cmp AL,3Ch ; <?
je read_60 ; yes, error
cmp AL,29h ; )?
jne read_70
read_60: jmp read_35 ; yes, error
;
read_70: mov byte ptr [SI],23h ; default
mov BX,offset hicases ; address of higher-case characters
xlat
mov byte ptr [SI+1],AL ; Change letter past # to upper case
mov BX,2
cmp AL,28h ; check for (
jne read_100
jmp read_sp ; yes, special case
;
read_100: call rcvchar ; get the next character
jmp read_30
;
read_200: mov flg_eof,0
; handle for symbol
read_sym: ; default
call ck_space ; check for space
test CX,CX
jz read_en ; yes, jump
cmp AL,CTRL_Z ; eof character?
je read_en
cmp AL,28h ; (
je read_en
cmp AL,29h ; )
je read_en
cmp AL,27h ; '
je read_en
cmp AL,60h ; `
je read_en
cmp AL,COM ; comment?
je read_en
cmp AL,2Ch ; ,
je read_en
cmp AL,22h ; "
je read_en
cmp AL,5Bh ; [
je read_en
cmp AL,5Dh ; ]
je read_en
cmp AL,7Bh ; {
je read_en
cmp AL,7Dh ; }
je read_en
push BX
mov BX,offset hicases ; address of higher-case characters
xlat
pop BX
cmp AL,7Ch ; |?
jne read_210
mov [BP].escaped,1
push AX
call delimby ; read the whole symbol
mov SP,BP
jmp read_250
;
read_210: cmp AL,BK_SLASH ; \?
jne read_220
mov [BP].escaped,1
mov flg_eof,1
call rcvchar
mov flg_eof,0
read_220: pushm <AX,BX>
call addchar
mov SP,BP
inc BX
read_250: call rcvchar ; get the next character
jmp read_sym
;
read_en: xor AL,AL ; put null at end of token
pushm <AX,BX>
call addchar
mov SP,BP
; Check for single, unescaped dot
cmp BX,1
jne read_num
cmp byte ptr [SI],2Eh ; check for .
jne read_num
cmp [BP].escaped,1
je read_num
jmp read_nor
; At this point a token has been accumulated, check for number
read_num: mov [BP].tmpreg,BX ; save BX register
push [BP].num_base
push SI
call scannum ; scan number
mov SP,BP
mov SI,atomb ; restore SI register
mov BX,[BP].tmpreg ; restore BX register
test AX,AX ; number or not?
jnz read_n05
jmp read_500
read_n05: cmp [BP].escaped,1
jne read_n07
jmp read_500
read_n07: cmp AX,0
jle read_300 ; negative for floating point number
; integer of some size
add AX,9 ; (AX + 9) / 2
shr AX,1 ; AX = bytes needed for integer
mov [BP].biglimit,AX ; save for later
push AX
C_call getmem ; allocate memory for bignum
mov SP,BP
cmp AX,0 ; memory available?
jne read_n10
jmp memerr ; no, error
read_n10: mov BX,AX
mov [BP].bignum,AX
mov byte ptr [BX+3],0
mov byte ptr [BX+4],0
pushm <[BP].num_base, atomb, BX>
call buildint ; form integer
mov SP,BP
mov DI,main_reg
mov BX,[BP].bignum
pushm <BX,DI>
C_call alloc_in,,Load_ES ; alloc_int
mov SP,BP
pushm <[BP].biglimit,[BP].bignum>
C_call rlsmem ; release memory for bignum
mov SP,BP
jmp read_rls
; Floating point number
read_300: lea DX,[BP].inflo
pushm <[BP].num_base, DX, SI>
C_call scanflo,,Load_ES ; scan the flonum
mov SP,BP
mov DI,main_reg
lea BX,[BP].inflo
pushm <[BX+6],[BX+4],[BX+2],[BX]> ; push flonum value
push DI
C_call alloc_fl,,Load_ES ; alloc_flonum
mov SP,BP
jmp read_rls
; Allocate character or interned symbol
read_500: cmp [BP].inputch,0 ; #\ macro?
mov DI,main_reg
jne read_510
jmp read_600 ; no, symbol
read_510: mov [DI].C_page,SPECCHAR*2
cmp BX,1 ; only one character?
jne read_mul ; no, jump
xor AH,AH
mov AL,byte ptr [SI]
mov [DI].C_disp,AX ; return the character
jmp read_rls
; Check for a multichar character constant
read_mul: mov AL,byte ptr [SI]
mov BX,offset hicases ; address of higher-case characters
xlat
mov byte ptr [SI],AL
xor BX,BX
read_515: cmp BL,TEST_NUM ; finish the comparison?
je read_580 ; yes, jump
lea DI,t_array ; save BX register
mov CX,BX
shl BX,1 ; get the word offset
mov DI,word ptr [DI+BX] ; address of special string
xor BX,BX
read_520: mov AL,byte ptr [DI+BX] ; get the character in string
cmp AL,0 ; end of string
je read_530 ; match
cmp byte ptr [SI+BX],AL
jne read_540
inc BX
jmp read_520
read_530: mov BX,CX
lea SI,test_ch ; address of special characters
mov AL,byte ptr [SI+BX]
mov DI,main_reg
mov [DI].C_disp,AX ; return the special character
jmp read_rls
;
read_540: mov BX,CX
inc BX
jmp read_515
; For the unrecognized multi-char character constant, return #\?
read_580: mov DI,main_reg
mov [DI].C_disp,3Fh ; return '?' character
;;; push SI
;;; lea BX,tmp_reg
;;; push BX
;;; C_call alloc_st,,Load_ES ; alloc_string for error message
;;; mov SP,BP
;;; lea BX,tmp_reg
;;; push BX
;;; lea BX,inv_char
;;; push BX
;;; xor BX,BX
;;; push BX
;;; C_call set_erro,,Load_ES ; set_error
;;; mov SP,BP
mov CXFERR_s,-1 ; error status
jmp read_rls
; Not a character, but a symbol
read_600: push BX ; length of symbol
push SI ; address of symbol
push DI ; register
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
jmp read_rls
;
read_sp: pushm <BX, SI, DI>
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
lea BX,nil_reg
mov DI,main_reg
pushm <BX, DI, DI>
call cons ; encase in a list
mov SP,BP
jmp read_bye
;
read_nor: pushm <BX, SI, DI>
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
lea BX,nil_reg
mov DI,main_reg
pushm <BX, DI, DI>
call cons ; encase in a list
mov SP,BP
read_rls: cmp char,CTRL_Z ; EOF character?
je read_bye
call pushchar ; put post-atom char back to buffer
;
read_bye: mov AX,limit
pushm <AX, atomb>
C_call rlsmem ; release memory
mov SP,BP
mov flg_eof,1 ; reset flags
mov limit,0
;
read_end: mov AX,CXFERR_s ; return status
read_ret: add SP,offset read_BP ; release local storage
pop BP
pop ES
ret
read_ato endp
;;;************************************************************************
;;; DELIMBY(c)
;;; DELIMBY takes characters from the input stream and places them
;;; in the buffer ATOMB, starting at offset stored in BX register, and
;;; ending when the delimiting character C is reached.
;;; Note: SI = address of atomb
;;; BX = number of characters in atomb
;;;************************************************************************
deliarg struc
dw ? ; caller's BP
dw ? ; caller's return address
cha dw ? ; character
deliarg ends
delimby proc near
push BP ; get the return address
mov BP,SP
mov flg_eof,1 ; signal the EOF error
call rcvchar
deli_10: mov CX,[BP].cha
cmp AL,CL ; reach the end?
je deli_50 ; yes, return
cmp AL,RETURN ; carriage return?
je deli_40 ; yes, ignore
cmp AL,BK_SLASH ; check for \
jne deli_30
call rcvchar ; yes, ignore
deli_30: pushm <AX,BX>
call addchar
mov SP,BP
inc BX
deli_40: call rcvchar ; get the next character
jmp deli_10
deli_50: mov flg_eof,0
pop BP
ret
delimby endp
;;;************************************************************************
;;; ADDCHAR (i, c)
;;; ADDCHAR takes the character c and places it in the dynamic
;;; atom buffer atomb, at offset i. If the buffer can not contain
;;; any more characters, additional space is allocated, and limit
;;; is adjusted accordingly.
;;;************************************************************************
addarg struc
add_tmp dw ?
add_BP dw ? ; caller's BP
dw ? ; caller's return address
index dw ?
chara dw ?
addarg ends
addchar proc near
push BP
sub SP,offset add_BP ; allocate local storage
mov BP,SP
mov BX,[BP].index
cmp BX,limit ; room for character?
jge add_10 ; no, jump
add_01: mov AX,[BP].chara
mov byte ptr [SI+BX],AL
add_ret: add SP,offset add_BP
pop BP
ret
add_10: mov AX,limit
add AX,BUFSIZE
push AX
C_call getmem ; allocate memory
mov SP,BP
cmp AX,0 ; memory available?
jne add_20
mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp add_ret
add_20: mov DI,AX ; address of new buffer
mov SI,atomb
mov CX,limit
rep movsb ; copy characters
mov [BP].add_tmp,AX ; save buffer pointer
pushm <limit, atomb>
C_call rlsmem ; discard the old buffer
mov SP,BP
mov SI,[BP].add_tmp
mov atomb,SI
mov CX,limit
add CX,BUFSIZE ; increase the limit
mov limit,CX
mov BX,[BP].index
jmp add_01
addchar endp
;;;************************************************************************
;;; ABORTREAD(code)
;;; Cancels the entire read operation via ABORT, after
;;; resetting some vital registers.
;;; Note: DI = address of main register
;;;************************************************************************
abortarg struc
dw ? ; caller's BP
dw ? ; caller's return address
errcode dw ? ; error code
abortarg ends
abortrea proc near
push BP
mov BP,SP
mov DI,main_reg ; main register
cmp [BP].errcode,EOFERR ; EOF error?
jne ab_010
mov [DI].C_page,EOF_PAGE*2 ; return eof indicator
mov [DI].C_disp,EOF_DISP
jmp ab_020
;
ab_010: xor AX,AX
mov [DI].C_page,AX ; NUL main register
mov [DI].C_disp,AX
;
ab_020: push [BP].errcode
call abort
pop BP
ret
abortrea endp
;;;**********************************************************************
;;; Local support to check the character in AX is space or not
;;; Note: CX = 0 iff the character is whitespace
;;;**********************************************************************
ck_space proc near
pop DX ; get the return address
xor CX,CX
cmp AL,SPACE ; space?
je is
cmp AL,9
jb isnot
cmp AL,0Dh
jbe is
isnot: inc CX
is: jmp DX ; return to caller
ck_space endp
prog ends
end


548
prowin.asm Normal file
View File

@ -0,0 +1,548 @@
; =====> PROWIN.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* Window I/O support *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 March 1986 *
;* Last Modification: 24 March 1986 *
;* 7 Jan 1987 - dbs *
;* added random I/O *
;***************************************
page 60,132
include scheme.equ
include sinterp.arg
include screen.equ
BUFFSIZE equ 256 ; input/output buffer
WINDSIZE equ 32-BLK_OVHD
PORTATTR equ 62
LABEL equ 32+BUFFSIZE ; window label field
P_FLAGS equ 6
W_FLAGS equ 26
WINDOW equ 4
B_ATTR equ 22
T_ATTR equ 24
CUR_LINE equ 10
CUR_COL equ 12
UL_LINE equ 14
UL_COL equ 16
N_LINES equ 18
N_COLS equ 20
NUM_FLDS equ 12
CHUNK equ 14
STR_PTR equ 3
OPEN equ 8
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
extrn port_pg:word,port_ds:word
public MAX_ROWS,MAX_COLS
bad_port db "[VM INTERNAL ERROR] Bad port for window output",CR,LF,0
mk_win_st db "%MAKE_WINDOW",0
sv_win_st db "WINDOW-SAVE-CONTENTS",0
rt_win_st db "WINDOW-RESTORE-CONTENTS",0
gt_win_st db "%REIFY-PORT",0
cl_win_st db "WINDOW_CLEAR",0
defaults dw 0,0,0,0 ; default values of window object
max_rows db DEFAULT_NUM_ROWS,0
max_cols db DEFAULT_NUM_COLS,0
dw -1,15,1,0,0
wnlines dw 0 ; number of lines
wncols dw 0 ; number of columns
wulline dw 0 ; upper-left line number
wulcol dw 0 ; upper-left column number
branchtab dw setw_20 ; [0] : cursor line
dw setw_20 ; [1] : cursor column
dw setw_30 ; [2] : upper left corner line
dw setw_40 ; [3] : upper left corner column
dw setw_50 ; [4] : number of lines
dw setw_60 ; [5] : number of columns
dw setw_100 ; [6] : border attribute
dw setw_100 ; [7] : text attribute
dw setw_100 ; [8] : flags
dw setw_100 ; [9] : buffer position
dw setw_100 ; [10] : buffer end
dw setw_100 ; [11] : port flag
dw setw_70 ; [12] : # of chunks
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
extrn rest_scr:near
extrn save_scr:near
win_proc proc near
;;;************************************************************************
;;; Allocate a window object
;;;************************************************************************
extrn zero_blk:near
extrn next_SP:near
extrn src_err:near
extrn adj4bord:near
public make_win
make_win: lods byte ptr ES:[SI] ; load the operand register
save <SI>
add AX,offset reg0 ; compute register address
mov BX,AX
mov SI,[BX].C_disp ; get displacement
mov BX,[BX].C_page ; get page number
mov tmp_disp,SI ; save window label pointer
mov tmp_page,BX
cmp byte ptr ptype+[BX],STRTYPE*2 ; check string type
jne make_err
jmp short make_020
make_err: test BX,BX
jz make_020 ; null window label
lea BX,mk_win_st ; load address of text
jmp src_err ; display error message
make_020: mov BX,BUFFSIZE+WINDSIZE ; get object length
mov CX,PORTTYPE ; port type
pushm <BX,CX,AX>
C_call alloc_bl,,Load_ES ; allocate block for window object
pop BX
mov DI,[BX].C_disp ; get displacement
save <DI>
mov BX,[BX].C_page ; get page numbe of window object
LoadPage ES,BX ; get page address
shr BX,1
pushm <DI, BX>
call zero_blk ; zero window object
restore <DI>
mov word ptr ES:[DI+6],PORTATTR ; store port attribute
mov AX,DI
add DI,10 ; position to move default values
lea SI,defaults ; address of default values
mov CX,NUM_FLDS-1 ; length of defaults
rep movsw ; move defaults into object
mov DI,AX
mov AX,tmp_page
mov BX,tmp_disp
mov byte ptr ES:[DI+STR_PTR],AL ; store window label pointer
mov word ptr ES:[DI+STR_PTR+1],BX
jmp next_SP
;;;************************************************************************
;;; Get Window Attributes
;;; Get Window Attributes was translated from C. The following C comments
;;; show the mappings of the arguments to get-window-attributes to their
;;; actual locations within the port object.
;;;
;;;
;;;#define NUM_FIELDS 12
;;;static int defaults[NUM_FIELDS] = {0, /* cursor line number */
;;; 0, /* cursor column number */
;;; 0, /* upper left corner line number */
;;; 0, /* upper left corner column number */
;;; 25, /* number of lines */
;;; 80, /* number of columns */
;;; -1, /* no border */
;;; 15, /* text high intensity, enable */
;;; 1, /* wrap enabled */
;;; 0, /* current buffer position */
;;; 0, /* current buffer end */
;;;TRANSCRIPT+BINARY+WINDOW+OPEN+READ_WRITE}; /* port attributes */
;;;static int map_attr[NUM_FIELDS] = {10,12,14,16,18,20,22,24,26,28,30,6};
;;;
;;;************************************************************************
public get_wind
get_wind: lods word ptr ES:[SI] ; load register operand
save <SI> ; save the location pointer
xor BX,BX
mov BL,AH
add BX,offset reg0 ; compute address of register
xor AH,AH
add AX,offset reg0
save <AX> ; save registers
save <BX>
mov CX,1
pushm <CX, AX>
C_call get_port,,Load_ES ; get the port object
mov SP,BP
mov SI,tmp_page
cmp byte ptr ptype+[SI],PORTTYPE*2
jne get_err
restore <BX>
cmp [BX].C_page,SPECFIX*2
jne get_err
mov BX,word ptr [BX].C_disp ; get the value
shl BX,1
sar BX,1
cmp BX,0
jl get_err
cmp BX,NUM_FLDS
jg get_err ; used to be jge - dbs
LoadPage ES,SI ; get page address
mov SI,tmp_disp
restore <AX>
mov DI,AX
mov word ptr [DI].C_page,SPECFIX*2
cmp BX,12
jne get_05
mov AX,word ptr ES:[SI+CHUNK]; get chunk number
jmp get_20
get_05: cmp BX,11
jne get_10
mov AX,word ptr ES:[SI+6]
jmp get_20
get_10: shl BX,1 ; get the word offset
mov AX,word ptr ES:[SI+10+BX]
get_20:
test word ptr ES:[SI+P_FLAGS],WINDOW ; Port a window?
jz get_25 ; No, jump
and AX,07FFFh ; Yes, return integer
mov word ptr [DI].C_disp,AX
jmp next_SP ; Return to interpreter
get_25:
xor BX,BX
push BX ; push long integer value
push AX
push DI ; register to store value
C_call long2int,,Load_ES ; convert to scheme integer
mov SP,BP
jmp next_SP
get_err: lea BX,gt_win_st
jmp src_err ; link to error handler
;;;************************************************************************
;;; Modify Transcript File Status
;;;************************************************************************
public trns_chg
trns_chg: lods byte ptr ES:[SI] ; load register operand
save <SI>
add AX,offset reg0 ; compute address of register
mov BX,AX
mov SI,[BX].C_disp
mov BX,[BX].C_page
cmp byte ptr ptype+[BX],PORTTYPE*2 ; check type
jne trns_10
LoadPage ES,BX ; get page address
mov AX,word ptr ES:[SI+P_FLAGS]
mov CX,AX
and AX,OPEN ; open?
jz trns_10
and CX,3 ; read and write?
jz trns_10
mov TRNS_pag,BX
mov TRNS_dis,SI
jmp next_SP
trns_10: xor AX,AX
mov TRNS_pag,AX
mov TRNS_dis,AX
jmp next_SP
;;;************************************************************************
;;; Save Window Contents
;;;************************************************************************
public save_win
save_win: lods byte ptr ES:[SI] ; load register operand
save <SI>
add AX,offset reg0 ; compute address of register
xor BX,BX
pushm <BX, AX>
save <AX>
C_call get_port,,Load_ES ; get port object
mov SP,BP
mov BX,tmp_page
cmp byte ptr ptype+[BX],PORTTYPE*2 ; check port type
je save_01
save_err: lea BX,sv_win_st
jmp src_err ; link to error handler
save_01: LoadPage ES,BX ; get page address
mov DI,tmp_disp
mov AX,word ptr ES:[DI+P_FLAGS]
and AX,WINDOW ; window object?
jz save_err
mov AX,word ptr ES:[DI+UL_LINE]
mov BX,word ptr ES:[DI+UL_COL]
mov CX,word ptr ES:[DI+N_LINES]
mov DX,word ptr ES:[DI+N_COLS]
mov wulline,AX
mov wulcol,BX
mov wnlines,CX
mov wncols,DX
mov AX,word ptr ES:[DI+B_ATTR] ; border attribute
cmp AX,-1 ; bordered?
je save_10 ; no, jump
lea AX,wulline
lea BX,wulcol
lea CX,wnlines
lea DX,wncols
pushm <DX, BX, CX, AX>
call adj4bord ; adjust window region
save_10: mov AX,wnlines
mov BX,wncols
; compute the length of string to save window contents
mul BL
shl AX,1 ; * 2
add AX,2 ; + 2
push AX
restore <AX>
mov CX,STRTYPE ; string type
pushm <CX, AX>
C_call alloc_bl,,Load_ES ; alloc_block
mov SP,BP
pushm <wncols,wnlines,wulcol,wulline>
restore <AX>
push AX
call save_scr ; save screen
jmp next_SP ; return to interpreter
;;;************************************************************************
;;; Restore Window Contents
;;;************************************************************************
public rest_win
rest_win: lods word ptr ES:[SI] ; load register operand
save <SI> ; save the location pointer
xor BX,BX
mov BL,AH
add BX,offset reg0 ; compute address of register
xor AH,AH
add AX,offset reg0
save <BX>
xor CX,CX
pushm <CX, AX>
C_call get_port,,Load_ES ; get the port object
mov SP,BP
restore <BX> ; BX = data to be restored
mov SI,[BX].C_page
cmp byte ptr ptype+[SI],STRTYPE*2 ; check type
jne rest_err
mov DI,tmp_page
cmp byte ptr ptype+[DI],PORTTYPE*2 ; check type
jne rest_err
LoadPage ES,DI ; get page address
mov DI,tmp_disp
mov AX,word ptr ES:[DI+P_FLAGS]
and AX,WINDOW ; window object?
jz rest_err
mov AX,word ptr ES:[DI+UL_LINE]
mov BX,word ptr ES:[DI+UL_COL]
mov CX,word ptr ES:[DI+N_LINES]
mov DX,word ptr ES:[DI+N_COLS]
mov wulline,AX
mov wulcol,BX
mov wnlines,CX
mov wncols,DX
mov AX,word ptr ES:[DI+B_ATTR] ; border attribute
cmp AX,-1
je rest_10
lea AX,wulline
lea BX,wulcol
lea CX,wnlines
lea DX,wncols
pushm <DX, BX, CX, AX>
call adj4bord ; adjust window region
rest_10: pushm <wncols, wnlines, wulcol, wulline>
restore <BX>
push BX
call rest_scr ; restore screen
jmp next_SP ; return to interpreter
rest_err: lea BX,rt_win_st
jmp src_err ; link to error handler
win_proc endp
;;;************************************************************************
;;; Set Window Attribute
;;;************************************************************************
setw_arg struc
dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
setw_reg dw ?
setw_att dw ?
setw_val dw ?
setw_arg ends
public set_wind
set_wind proc near
push ES
push BP
mov BP,SP
mov AX,1
pushm <AX, [BP].setw_reg>
C_call get_port,,Load_ES ; get port address
mov SP,BP
mov BX,tmp_page
cmp byte ptr ptype+[BX],PORTTYPE*2 ; check type
jne setw_err
mov SI,[BP].setw_att
cmp word ptr [SI].C_page,SPECFIX*2 ; check attribute type
jne setw_err
mov AX,[SI].C_disp ; get attribute value
shl AX,1
sar AX,1
cmp AX,0 ; check attribute value
jl setw_err
cmp AX,NUM_FLDS
jge setw_err
mov SI,[BP].setw_val ; get the value pointer
cmp word ptr [SI].C_page,SPECFIX*2 ; check type
je setw_10
setw_err: lea BX,gt_win_st ; address of error message
pushm <[BP].setw_val, [BP].setw_att, [BP].setw_reg>
mov AX,3
pushm <AX, BX>
C_call set_src_,,Load_ES ; set_src_err
mov SP,BP
mov AX,-1 ; return error status
jmp setw_ret
setw_10: mov CX,[SI].C_disp ; get the value
shl CX,1
sar CX,1
LoadPage ES,BX ; get page address of port
mov SI,tmp_disp ; displacement of port object
mov BX,AX
shl BX,1 ; get the word offset
jmp branchtab+[BX]
; cursor line/cursor column
setw_20: cmp CX,0
jl setw_err ; negative value, error
jmp setw_100
; upper left hand corner line number
setw_30: xor AX,AX
xor DH,DH
mov DL,MAX_ROWS
dec DX ; MAX_ROWS - 1
call fit_in_r
mov AX,word ptr ES:[SI+N_LINES]
inc DX
sub DX,CX ; MAX_ROWS - value
cmp AX,DX
jle setw_35
mov word ptr ES:[SI+N_LINES],DX
setw_35: jmp setw_100
; upper left hand corner column number
setw_40: xor AX,AX
xor DH,DH
mov DL,MAX_COLS
dec DX ; MAX_COLUMNS - 1
call fit_in_r
mov AX,word ptr ES:[SI+N_COLS]
inc DX
sub DX,CX ; MAX_COLUMNS - value
cmp AX,DX
jle setw_35
mov word ptr ES:[SI+N_COLS],DX
jmp setw_35
; number of lines
setw_50: mov AX,word ptr ES:[SI+UL_LINE]
xor DH,DH
mov DL,MAX_ROWS
sub DX,AX ; MAX_ROWS - UL_LINE
mov AX,1
call fit_in_r
jmp setw_100
; number of columns
setw_60: mov AX,word ptr ES:[SI+P_FLAGS]
and AX,WINDOW ; window?
jz setw_100 ; no, jump
mov AX,word ptr ES:[SI+UL_COL]
xor DH,DH
mov DL,MAX_COLS
sub DX,AX ; MAX_COLUMNS - UL_COL
mov AX,1
call fit_in_r
jmp setw_100
; chunk#
setw_70: mov BX,CHUNK
jmp setw_120
; store the value
setw_100: sar BX,1
cmp BX,11
jne setw_110
mov BX,6
jmp setw_120
setw_110: shl BX,1 ; word offset
add BX,10
setw_120: mov word ptr ES:[SI+BX],CX ; store the value
xor AX,AX
setw_ret: pop BP
pop ES
ret
set_wind endp
;;;************************************************************************
;;; Force Value into Range
;;; Purpose: To test a value (in CX) to determine if it falls within a
;;; range of values, as specified by an lower (in AX) and
;;; upper (in DX) bounds. If the value is within the range,
;;; the value is returned (in CX) unchanged. If it is outside
;;; the range, the value of the endpoint nearest its value
;;; is returned (in CX).
;;;************************************************************************
fit_in_r proc near
pop DI ; get the return address
cmp CX,AX ; value < lower?
jge fit_10
mov CX,AX ; yes, return lower
fit_01: jmp DI ; return to caller
fit_10: cmp CX,DX ; value > upper?
jle fit_01 ; no, return
mov CX,DX ; yes, return upper
jmp DI ; return to caller
fit_in_r endp
;;;************************************************************************
;;; Write message to the who-line
;;;************************************************************************
who_arg struc
pg dw ?
dis dw ?
who_BP dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
str dw ? ; pointer to message string
who_arg ends
extrn ssetadr:near
extrn printtxt:near
public who_writ
who_writ proc near
push ES
push BP
sub SP,offset who_BP ; allocate local storage
mov BP,SP
mov ax,port_pg ;save current port address
mov [BP].pg,ax
mov ax,port_ds
mov [BP].dis,ax
mov AX,WHO_DISP
mov BX,WHO_PAGE*2
pushm <AX, BX>
call ssetadr ;get new port address
mov SP,BP
xor BX,BX ;compute length of string
mov SI,[BP].str
who_010: cmp byte ptr [SI+BX],0 ;string end?
je who_020 ; yes, exit loop
inc BX
jmp who_010
; Write message to the who line
who_020: push BX ;bx = strlen(str)
push SI ;si = address of string
call printtxt
mov SP,BP
mov BX,[BP].pg ;restore original port
cmp byte ptr ptype+[BX],PORTTYPE*2 ;check port type
jne who_ret
LoadPage ES,BX ;get page address
mov SI,[BP].dis
cmp byte ptr ES:[SI],PORTTYPE ;check port type
jne who_ret
pushm <SI, BX>
call ssetadr ;set port address
mov SP,BP
who_ret: add SP,offset who_BP ;release local storage
pop BP
pop ES
ret
who_writ endp
prog ends
end


1903
realio.asm Normal file
View File

File diff suppressed because it is too large Load Diff

90
realio.equ Normal file
View File

@ -0,0 +1,90 @@
;*******************************************************************************
; *
; Macros and equates for i/o and graphics which are performed in real mode. *
; *
; *
;*******************************************************************************
IFNDEF DOS
DOS equ 021h ; Dos Function Request
ENDIF
IFNDEF RPC
RPC equ 0E1h ; Real Procedure Call
ENDIF
IFNDEF BLOCK_XFER
BLOCK_XFER equ 0EC00h ; Block Transfer
ENDIF
;
; Entry points within realio.asm for performing text I/O.
;
REAL_BELL equ 0 ;ring the bell
REAL_CLEAR equ 1 ;clear the screen
REAL_BORDER equ 2 ;draw window borders
REAL_SAVESCR equ 3 ;save screen contents
REAL_RESTSCR equ 4 ;restore screen contents
REAL_CURON equ 5 ;turn cursor on
REAL_CUROFF equ 6 ;turn cursor off
REAL_PUTCUR equ 7 ;position cursor
REAL_PUTC equ 8 ;write character
REAL_SCROLLUP equ 9 ;scroll up
REAL_SCROLLDN equ 10 ;scroll down
REAL_EGACURS equ 11 ;ega cursor
REAL_CHGVMODE equ 12 ;change video mode
REAL_WRTSTRNG equ 13 ;write string to port
REAL_WRTBLOCK equ 14 ;write string to display
;
; The following macro creates the code to call all of the real mode I/O
; routines. The arguments (which reside on the stack) are moved to the
; a buffer which resides in real mode, along with one of the above defined
; function indicators. Then an rpc call is performed, such that the correct
; real mode xli routine is envoked.
;
REALIO MACRO FUNCTION,ARGSTART,ARGEND,CONTINUE
; address arguments
push es
push si
push di
mov si,bp
add si,(ARGSTART - 2) ;ds:si => arguments
; move arguments to real mode buffer
push word ptr [si] ;save word at this location
mov word ptr [si],FUNCTION ;and replace with function opcode
IFDIF <ARGSTART>,<ARGEND> ;cx = length
mov cx,((ARGEND + 2) - (ARGSTART - 2))
ELSE
mov cx,(ARGEND - (ARGSTART - 2))
ENDIF
mov di,word ptr REAL_BUF_SELECTOR ;get real buffer selector
mov es,di
mov di,word ptr REAL_BUF_TOP ;get top address of buffer
sub di,cx ;es:di => real mode buffer
mov ax,BLOCK_XFER ;xfer block to real memory
int DOS
pop [si] ;restore word at this location
; issue call to real mode handler
mov al,rpc_handle ;real procedure handle
mov ah,RPC ;rpc function call
push di ;stack pointer
push XLI_REALIO ;real i/o function designator
mov dx,sp
mov cx,4 ;cx = # bytes in rpc buffer
IFNB <CONTINUE>
mov bx,2 ;bx = number return bytes
ELSE
xor bx,bx ;bx = number return bytes
ENDIF
int DOS
add sp,4
pop di
pop si
pop es
ENDM


1357
realschm.asm Normal file
View File

File diff suppressed because it is too large Load Diff

290
regschem.h Normal file
View File

@ -0,0 +1,290 @@
/* =====> SCHEME.H */
/* TIPC Scheme Data Declarations for Lattice C */
/* Last Modification: 01 January 1986 */
extern char *rtn_name;
#define ASSERT(arg) if(!(arg))asrt$(rtn_name,"arg")
#define ENTER(xyz) static char *rtn_name = "xyz"
/* Data conversion macros */
/* Adjust page number- this macro converts a logical page number to
the representation which is stored in the interpreter's registers
and pointers. "CORRPAGE" performs the reverse transformation */
#define ADJPAGE(x) ((x)<<1)
/* Correct page number- this macro converts the interpreter's encoding
of a page number into the logical page number. "ADJPAGE" performs
the reverse transformation. */
#define CORRPAGE(x) ((x)>>1)
/* Fetch value for Fixnum (immediate) from pointer */
#define get_fix(pg,ds) (((ds)<<1)>>1)
/* Fetch value for Character (immediate) from pointer */
#define get_char(pg,ds) ((ds) & 0x00ff)
/* define truth */
#define TRUE 1
#define FALSE 0
#define NULL 0 /* null pointer */
/* Position of page/displacement values in "registers" */
#define C_DISP 0
#define C_PAGE 1
/* Page Management Table Definitions */
#define NUMPAGES 128 /* maximum number of pages */
#define DEDPAGES 8 /* Number of dedicated pages */
#define MIN_PAGESIZE 0x0C00 /* minimum page size in bytes (fixed size) */
#define PTRMASK MIN_PAGESIZE-1 /* mask to isolate a pointer displacement */
#define PAGEINCR 2 /* increment to get to next page */
#define PAGEMASK 0x00FE /* mask to isolate a page number */
#define WORDSIZE 16 /* computer's word size (bits/word) */
#define WORDINCR 2 /* number of address units/word */
#define HT_SIZE 211 /* the oblist's hash table size */
#define STKSIZE 900 /* the stack's length (bytes) */
#define BLK_OVHD 3 /* number of overhead bytes in a block header */
#define NUM_REGS 64 /* number of registers in the Scheme VM */
/* Data Type Equates */
#define NUMTYPES 15 /* the number of data types */
#define LISTTYPE 0
#define FIXTYPE 1
#define FLOTYPE 2
#define BIGTYPE 3
#define SYMTYPE 4
#define STRTYPE 5
#define ARYTYPE 6
#define VECTTYPE ARYTYPE
#define CONTTYPE 7
#define CLOSTYPE 8
#define FREETYPE 9
#define CODETYPE 10
#define REFTYPE 11
#define PORTTYPE 12
#define CHARTYPE 13
#define ENVTYPE 14
#define EOFERR 1 /* Codes for function ERRMSG */
#define DOTERR 2
#define QUOTERR 3
#define RPARERR 4
#define OVERERR 5
#define DIV0ERR 6
#define SHARPERR 7
#define FULLERR -1
#define PORTERR -2
#define HEAPERR -3
#define BUFSIZE 80
#define SYM_OVHD 7
#define PTRSIZE 3
#define LISTSIZE 6
#define FIXSIZE 2
#define FLOSIZE 9
#define SMALL_SIZE 1024 /* a "small" length for a block */
#define SPECCHAR 1 /* special page of characters */
#define SPECFIX 3 /* special page of fixnums */
#define SFIXLEN 0 /* length (bytes) of special fixnum page */
#define SPECFLO 4 /* special page of flonums */
#define SFLOLEN 24 /* length (bytes) of special flonum page */
#define SPECSYM 5 /* special page of symbols */
#define SSYMLEN 0x51 /* length (bytes) of special symbol page */
#define SPECSTK 6
#define SPECPOR 6 /* special page of ports */
#define SPORLEN 92 /* length (bytes) of special port page */
#define SPECCODE 7 /* code page for the bootstrap loader */
#define END_LIST 0x7FFF /* end of linked list marker */
#define NIL_PAGE 0 /* Location of "nil" */
#define NIL_DISP 0
#define T_PAGE SPECSYM /* Location of "t" (for true) */
#define T_DISP 0x0000
#define UN_PAGE SPECSYM /* Location of "#!unassigned" */
#define UN_DISP 0x0009
#define NTN_PAGE SPECSYM /* Location of "#!not-a-number" */
#define NTN_DISP 0x001C
#define OVR_PAGE SPECSYM /* Location of overflow designator */
#define OVR_DISP 0x001C /* (same as "not a number" for now) */
#define DIV0_PAGE SPECSYM /* Location of divide-by-zero designator */
#define DIV0_DISP 0x001C /* (same as "not a number" for now) */
#define IN_PAGE SPECPOR /* Location of standard input port */
#define IN_DISP 0
#define OUT_PAGE SPECPOR /* Location of standard output port */
/* #define OUT_DISP 0x011f */
#define OUT_DISP 0 /* input=output for standard console device */
#define WHO_PAGE SPECPOR /* Location of "who-line" port */
#define WHO_DISP 0x0123
#define EOF_PAGE SPECSYM /* Location of non-interned "**eof**" symbol */
#define EOF_DISP 0x0031
#define NPR_PAGE SPECSYM /* Location of "#!unprintable" */
#define NPR_DISP 0x003D
#define ADD_OP 0 /* addition */
#define SUB_OP 1 /* subtraction */
#define MUL_OP 2 /* multiplication */
#define DIV_OP 3 /* divide */
#define MOD_OP 4 /* modulo */
#define AND_OP 5 /* bitwise and */
#define OR_OP 6 /* bitwise or */
#define MINUS_OP 7 /* minus */
#define EQ_OP 8 /* equal comparison */
#define NE_OP 9 /* not equal comparison */
#define LT_OP 10 /* less than comparison */
#define GT_OP 11 /* greater than comparison */
#define LE_OP 12 /* less than or equal comparison */
#define GE_OP 13 /* greater than or equal comparison */
#define ABS_OP 14 /* absolute value */
#define QUOT_OP 15 /* quotient */
#define TRUNC_OP 16 /* truncate */
#define FLOOR_OP 17 /* floor */
#define CEIL_OP 18 /* ceiling */
#define ROUND_OP 19 /* round */
#define FLOAT_OP 20 /* float */
#define ZERO_OP 21 /* zero? */
#define POS_OP 22 /* positive? */
#define NEG_OP 23 /* negative? */
/* Numeric Error Codes */
#define REF_GLOBAL_ERROR 1 /* reference of unbound global variable */
#define SET_GLOBAL_ERROR 2 /* SET! error-- global not defined */
#define REF_LEXICAL_ERROR 3 /* reference of unbound lexical variable */
#define SET_LEXICAL_ERROR 4 /* SET! error-- lexical variable not defined */
#define REF_FLUID_ERROR 5 /* reference of unbound fluid variable */
#define SET_FLUID_ERROR 6 /* SET-FLUID! error-- fluid not bound */
#define VECTOR_OFFSET_ERROR 7 /* vector index out of range */
#define STRING_OFFSET_ERROR 8 /* string index out of range */
#define SUBSTRING_RANGE_ERROR 9 /* invalid substring range */
#define INVALID_OPERAND_ERROR 10 /* invalid operand to VM instruction */
#define SHIFT_BREAK_CONDITION 11 /* SHFT-BRK key was depressed by user */
#define NON_PROCEDURE_ERROR 12 /* attempted to call non-procedural object */
#define TIMEOUT_CONDITION 13 /* timer interrupt */
#define WINDOW_FAULT_CONDITION 14 /* attempt to do I/O to a de-exposed window */
#define FLONUM_OVERFLOW_ERROR 15 /* flonum overflow/underflow */
#define ZERO_DIVIDE_ERROR 16 /* division by zero */
#define NUMERIC_OPERAND_ERROR 17 /* non-numeric operand */
#define APPLY_ARG_LIMIT_ERROR 18 /* too many arguments for APPLY to handle */
#define VECTOR_SIZE_LIMIT_ERROR 19 /* vector too big */
#define STRING_SIZE_LIMIT_ERROR 20 /* string too big */
#define DOS_FATAL_ERROR 21 /* DOS fatal i/o error (24H INT) */
/* Scheme VM Control Flags */
extern int PC_MAKE; /* variable denoting PC's manufacturer & type */
extern int VM_debug; /* VM debug mode flag */
extern int s_break; /* shift-break indicator */
extern int QUOTE_PAGE; /* Location of "quote" */
extern int QUOTE_DISP;
extern unsigned PAGESIZE;
extern unsigned pagetabl[NUMPAGES]; /* Paragraph Address (bases) */
extern struct {
unsigned atom:1;
unsigned listcell:1;
unsigned fixnums:1;
unsigned flonums:1;
unsigned bignums:1;
unsigned symbols:1;
unsigned strings:1;
unsigned arrays:1;
unsigned nomemory:1;
unsigned readonly:1;
unsigned continu:1;
unsigned closure:1;
unsigned refs:1;
unsigned ports:1;
unsigned code:1;
unsigned characters:1;
} attrib[NUMPAGES]; /* Page Attribute Bits */
extern int w_attrib[NUMPAGES]; /* Re-define attribute bits as integer */
extern int nextcell[NUMPAGES]; /* Next Available Cell Pointers */
extern int pagelink[NUMPAGES]; /* Next Page of Same Type */
extern int ptype[NUMPAGES]; /* Page Type Index */
extern unsigned psize[NUMPAGES]; /* Page Size Table */
extern int pageattr[NUMTYPES]; /* Page attribute initialization table */
extern int pagelist[NUMTYPES]; /* Page allocation table (by types) */
extern int listpage; /* Page for List Cell allocation */
extern int fixpage; /* Page for Fixnum allocation */
extern int flopage; /* Page for Flonum allocation */
extern int bigpage; /* Page for Bignum allocation */
extern int sympage; /* Page for Symbol allocation */
extern int strpage; /* Page for String allocation */
extern int arypage; /* Page for Array allocation */
extern int contpage; /* Page for Continuation allocation */
extern int clospage; /* Page for Closure allocation */
extern int freepage; /* Free page allocation list header */
extern int codepage; /* Page for Code Block allocation */
extern int refpage; /* Ref cell page allocation list header */
extern int nextpage; /* Next Page Number for Allocation in the
Logical Address Space */
extern unsigned nextpara; /* Next Paragraph Address for Allocation */
/* Scheme's Virtual Registers */
extern long reg0, regs[NUM_REGS];
extern int nil_reg[2];
extern int reg0_page, reg0_disp, tmp_reg[2], tmp_page, tmp_disp;
extern int tm2_reg[2], tm2_page, tm2_disp;
extern int FNV_reg[2], GNV_reg[2], CB_reg[2], PREV_reg[2];
extern int FNV_pag, FNV_dis, GNV_pag, GNV_dis, CB_pag, CB_dis;
extern int PREV_pag, PREV_dis, FP, BASE;
extern int CONSOLE_[2], CON_PAGE, CON_DISP;
extern int TRNS_reg[2], TRNS_pag, TRNS_dis; /* transcript file pointer */
extern int condcode, S_pc;
/* Stack */
extern int TOS; /* top of stack pointer (displacement in bytes */
extern char S_stack[STKSIZE]; /* the stack itself */
/* Hash Table */
extern char hash_page[HT_SIZE];
extern int hash_disp[HT_SIZE];
/* Property List Hash Table */
extern char prop_page[HT_SIZE];
extern int prop_disp[HT_SIZE];
/* State Variables for (reset) and (scheme-reset) */
extern int FP_save, RST_ent;
extern int FNV_save[2];
extern int STL_save[2];
/* Port fields */
#define pt_direc 6
#define pt_lnlen 20
#define pt_csrcol 12
#define dtaoffs 32
/* Error message text strings */
extern char m_error[], m_src[], m_dest[], m_first[], m_second[], m_third[];
/* Macros Normally Found in STDIO.H */
#define abs(x) ((x)<0?-(x):(x))
#define max(a,b) ((a)>(b)?(a):(b))
#define min(a,b) ((a)<=(b)?(a):(b))
/* Scheme Function Macros */
#define alloc_sym(dest,len) alloc_block(dest,SYMTYPE,len+PTRSIZE+1)
/* International Case Conversion Macros */
extern char locases[256];
extern char hicases[256];
#undef tolower
#define tolower(c) locases[(c)]
#undef toupper
#define toupper(c) hicases[(c)]
#undef islower
#define islower(c) ((c)!=hicases[(c)])
#undef isupper
#define isupper(c) ((c)!=locases[(c)])
#undef isspace
#undef isdigit
#define isdigit(c) isdig((c),10)
#undef isxdigit
#define isxdigit(c) isdig((c),16)


37
rpc.equ Normal file
View File

@ -0,0 +1,37 @@
;
; Dos function requests provided by AIA for performing real procedure calls
;
RPC_INIT equ 0E0h ; Initialize RPC
RPC equ 0E1h ; Issue RPC
;
; Real procedure entry points.
;
; REALSCHM.ASM is a real procedure which is loaded upon initialization of
; Scheme and accessed via real procedure calls. It currently contains a
; table of 25 entries (0-24) which contain routines accessable from our
; protected mode code. The first 20 entries will contain addresses to
; code within realschm.asm, primarily for things like xli support which
; can't be provided in protected mode. The next 5 entries are for system
; xli routines. An xli routine is distinguished as a system xli routine by
; having the FB_SYSINT flag in the file block set non-zero. Note that the
; system xli routines must be in a specified order, as defined in
; PRO2REAL.ASM.
;
;
RPCINIT equ 0 ;Initialize real procedure
RPCRETBUF equ 0 ;Return real procedure buffer address
RPCTYPE equ 1 ;Return pc type and graphics info
RPCLDEXE equ 2 ;Load an XLI file
RPCUNLDALL equ 3 ;Unload all XLI files
RPCXESC equ 4 ;Perform XESC to an XLI function
RPCXLISSR equ 5 ;XESC Special Services Return
RPCTAKCRT equ 6 ;takeover real mode crt interrupt
RPCRSTCRT equ 7 ;restore real mode system crt interrupt
; order dependent system xli files (see table in pro2real.asm & realschm.asm)
XLI_REALIO equ 20 ;Perform text I/O
XLI_GRAPH equ 21 ;Perform Graphics


247
saprop.asm Normal file
View File

@ -0,0 +1,247 @@
; =====> SAPROP.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Property List Support *
;* *
;* (C) Copyright 1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 7 May 1986 *
;* Last Modification: 11 May 1986 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;************************************************************************
;* Search for Property in Property List *
;* *
;* Calling Sequence: found? = prop_search(list,prop); *
;* *
;* Input Parameters: list - the property list for a symbol. *
;* prop - the property for which to search. *
;* *
;* Output Parameters: found? - if the property was found in the list, *
;* found?=1; else found?=0. *
;* list - a pointer to the property/value pair *
;* for the specified property. If not found, NIL. *
;* *
;* Note: This routine is an assembly language version of the following *
;* C source: *
;* prop_search(list, prop) *
;* int list[2],prop[2]; *
;* { *
;* int search[2]; /* current search entry in list */ *
;* int temp[2]; /* temporary "register" */ *
;* ENTER(prop_search); *
;* *
;* mov_reg(search, list); *
;* take_cdr(search); *
;* while(search[C_PAGE]) *
;* { *
;* mov_reg(temp, search); *
;* take_car(temp); *
;* if (eq(temp,prop)) *
;* { *
;* mov_reg(list, search); *
;* return(FOUND); *
;* } *
;* take_cddr(search); *
;* } /* end: while(search[C_PAGE]) */ *
;* return(NOT_FOUND); *
;* } /* end of function: prop_search(list, prop) */ *
;************************************************************************
p_arg struc
dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; return address
p_list dw ? ; addr of reg containing list to search
p_prop dw ? ; the property for which we're searching
p_arg ends
public prop_sea
prop_sea proc near
push ES ; save caller's ES register
push BP ; save caller's BP register
mov BP,SP ; establish addressability
; Load up the property for which we're searching into CL:DX
mov BX,[BP].p_prop
mov CL,byte ptr [BX].C_page
mov DX,[BX].C_disp
; Load up a pointer to the beginning of the property list
mov SI,[BP].p_list
xor BX,BX
mov BL,byte ptr [SI].C_page
mov DI,[SI].C_disp
jmp short start
; Property didn't match-- keep searching list
no_match: mov BL,ES:[DI].cdr_page
mov DI,ES:[DI].cdr
; Take CDR to get to first property/value pair or to follow list
start: cmp BL,0
je p_nf
cmp byte ptr ptype+[BX],LISTTYPE*2
jne p_nf
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,ES:[DI].cdr_page
mov DI,ES:[DI].cdr
; Test for valid list cell
cmp BL,0
je p_nf
cmp byte ptr ptype+[BX],LISTTYPE*2
jne p_nf
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
cmp DX,ES:[DI].car
jne no_match
cmp CL,ES:[DI].car_page
jne no_match
; Property found!-- return pointer to it
mov byte ptr [SI].C_page,BL ; move pointer to property entry
mov [SI].C_disp,DI ; into the "list" operand register
pop BP ; restore caller's BP register
pop ES ; restore caller's ES register
mov AX,1 ; indicate property found
ret ; return
; End of property list-- return not found
p_nf: xor AX,AX ; indicate no match found
pop BP ; restore caller's BP register
pop ES ; restore caller's ES register
ret ; return
prop_sea endp
;************************************************************************
;* Search for Symbol in Property List *
;* *
;* Calling Sequence: sym_search(sym) *
;* *
;* Input Parameters: sym - a register containing a symbol who's *
;* property list is to be located. *
;* *
;* Output Parameters: sym - the register is updated to point to the *
;* property list for the symbol. If no property *
;* list exists, it is set to NIL. *
;* *
;* Note: This routine is an assembly language version of the following *
;* C source: *
;* sym_search(sym) *
;* int sym[2]; *
;* { *
;* int hash_value; /* symbol's hash value */ *
;* int sym_save[2]; /* initial value of symbol argument */ *
;* int temp[2]; /* temporary "register" */ *
;* ENTER(sym_search); *
;* *
;* if (ptype[CORRPAGE(sym[C_PAGE])] == SYMTYPE*2) *
;* { *
;* /* save symbol's page and displacement for testing purposes */ *
;* mov_reg(sym_save, sym); *
;* *
;* /* obtain hash chain to search */ *
;* hash_value = sym_hash(sym); *
;* sym[C_PAGE] = prop_page[hash_value]; *
;* sym[C_DISP] = prop_disp[hash_value]; *
;* *
;* while(sym[C_PAGE]) *
;* { *
;* mov_reg(temp, sym); *
;* take_caar(temp); *
;* if (eq(temp, sym_save)) *
;* { *
;* /* symbol found-- return pointer to symbol's property list */*
;* take_car(sym); *
;* break; *
;* } *
;* else *
;* { *
;* take_cdr(sym); *
;* } *
;* } /* end: while(sym[C_PAGE]) */ *
;* } *
;* } /* end of function: sym_search(sym) */ *
;* *
;************************************************************************
sym_args struc
dw ? ; caller's ES register
dw ? ; caller's BP register
dw ? ; return address
s_sym dw ? ; address of symbol/result register
sym_args ends
public sym_sear
sym_sear proc near
push BP ; save the caller's BP register
push ES ; save the caller's ES register
mov BP,SP ; establish addressability
; Load a pointer to the symbol and get its hash value
mov SI,[BP].s_sym ; load symbol register's address
mov BX,[SI].C_page ; load symbol's page number
cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it?
jne s_nf ; if not a symbol, return NIL
mov SI,[SI].C_disp ; load symbol's displacement and
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; paragraph address
mov CX,BX ; copy the symbol into CL:DX
mov DX,SI
mov BL,ES:[SI].sym_hkey ; load hash key
mov DI,BX ; copy hash key into DI and
shl DI,1 ; multiply by two for word index
mov BL,prop_pag+[BX] ; load property list header for this
mov DI,prop_dis+[DI] ; symbol's bucket
jmp short go
; Search the next entry in the bucket
s_next: mov BX,AX
LoadPage ES,BX
;;; mov ES,AX ; restore ES register for bucket entry
s_next1: mov BL,ES:[DI].cdr_page ; load pointer to next bucket entry from
mov DI,ES:[DI].cdr ; the CDR field
go: cmp BL,0 ; end of bucket?
je s_nf ; if so, jump
cmp byte ptr ptype+[BX],LISTTYPE*2 ; list cell?
jne s_nf ; if not a pair (?), jump
LoadPage ES,BX
mov AX,BX ; Save Bucket entry page number
;;; mov ES,pagetabl+[BX] ; load list cell's paragraph address
; Fetch the property list from the CAR field of the bucket entry
mov BL,ES:[DI].car_page
mov SI,ES:[DI].car
cmp BL,0 ; no property list for this bucket entry?
je s_next1 ; if not (?), ignore it
cmp byte ptr ptype+[BX],LISTTYPE*2 ; it is a pair, isn't it?
jne s_next1 ; if not (?), ignore it
;;; mov AX,ES ; save ES register for bucket entry
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load the paragraph addr of prop list entry
cmp DX,ES:[SI].car ; entry for our symbol?
jne s_next ; if not, jump
cmp CL,ES:[SI].car_page ; entry for our symbol?
jne s_next ; if not, jump
; Symbol's property list found-- return in symbol register (or return NIL)
mov DI,[BP].s_sym ; reload source/destination register address
mov byte ptr [DI].C_page,BL ; store prop list pointer into
mov [DI].C_disp,SI ; the register
pop ES ; restore the caller's ES register
pop BP ; restore the caller's BP register
ret ; return
; Invalid list structure-- return NIL
s_nf: xor AX,AX ; create a NIL pointer
mov DI,[BP].s_sym
mov byte ptr [DI].C_page,AL
mov [DI].C_disp,AX
pop ES
pop BP
ret
sym_sear endp
prog ends
end


564
sasm.mac Normal file
View File

@ -0,0 +1,564 @@
; =====> SASM.MAC
;***************************************
;* TIPC Scheme '84 Assembler Macros *
;* (C) Copyright 1984,1984 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 14 May 1984 *
;* Last Modification: 1 April 1985 *
;***************************************
; Register equates
R0 equ 0
R1 equ 4
R2 equ 8
R3 equ 12
R4 equ 16
R5 equ 20
R6 equ 24
R7 equ 28
R8 equ 32
R9 equ 36
R10 equ 40
R11 equ 44
R12 equ 48
R13 equ 52
R14 equ 56
R15 equ 60
R16 equ 64
R17 equ 68
R18 equ 72
R19 equ 76
R20 equ 80
R21 equ 84
R22 equ 88
R23 equ 92
R24 equ 96
R25 equ 100
R26 equ 104
R27 equ 108
R28 equ 112
R29 equ 116
R30 equ 120
R31 equ 124
R32 equ 128
R33 equ 132
R34 equ 136
R35 equ 140
R36 equ 144
R37 equ 148
R38 equ 152
R39 equ 156
R40 equ 160
R41 equ 164
R42 equ 168
R43 equ 172
R44 equ 176
R45 equ 180
R46 equ 184
R47 equ 188
R48 equ 192
R49 equ 196
R50 equ 200
R51 equ 204
R52 equ 208
R53 equ 212
R54 equ 216
R55 equ 220
R56 equ 224
R57 equ 228
R58 equ 232
R59 equ 236
R60 equ 240
R61 equ 244
R62 equ 248
R63 equ 252
; Instruction macros
COPY_ macro dest,src
db 0,dest,src
endm
LD_CON_ macro dest,numb
db 1,dest,numb
endm
LD_IMM_ macro dest,val
db 2,dest,val
endm
LD_NIL_ macro dest
db 3,dest
endm
LD_LCL_ macro dest,entry
db 4,dest,entry
endm
LD_GLOBAL_ macro dest,src
db 7,dest,src
endm
LD_FLUID_ macro dest,src ; load fluid
db 8,dest,src
endm
LD_S_ macro dest,src,off
temp_ld = offset off
temp_ld = temp_ld/3
db 9,dest,src,temp_ld
endm
LD_L_ macro dest,src,off
temp_ld = offset off
temp_ld = temp_ld/3
db 10,dest,src
dw temp_ld
endm
LD_R_ macro dest,src,off
db 11,dest,src,off
endm
LD_GL_R_ macro dest,src
db 27,dest,src
endm
BIND_FL_ macro const,src ; bind fluid variable
db 29,const,src
endm
DEFINE_ macro dest,const
db 31,dest,const
endm
DEF_ENV_ macro sym,val,env
db 220,sym,val,env
endm
CLOSE_ macro dest,lbl,nargs
local x
db 60,dest
dw lbl-x
db nargs
x equ $
endm
LD_FL_R_ macro dest,src ; load fluid from symbol in register
db 63,dest,src ; temporary instruction?
endm
LD_CAR_ macro dest,src
db 64,dest,src
endm
LD_CDR_ macro dest,src
db 65,dest,src
endm
LD_CAAR_ macro dest,src
db 66,dest,src
endm
LD_CADR_ macro dest,src
db 67,dest,src
endm
LD_CDAR_ macro dest,src
db 68,dest,src
endm
LD_CDDR_ macro dest,src
db 69,dest,src
endm
LD_CAAAR_ macro dest,src
db 70,dest,src
endm
LD_CAADR_ macro dest,src
db 71,dest,src
endm
LD_CADAR_ macro dest,src
db 72,dest,src
endm
LD_CADDR_ macro dest,src
db 73,dest,src
endm
LD_CDAAR_ macro dest,src
db 74,dest,src
endm
LD_CDADR_ macro dest,src
db 75,dest,src
endm
LD_CDDAR_ macro dest,src
db 76,dest,src
endm
LD_CDDDR_ macro dest,src
db 77,dest,src
endm
LD_CADDDR_ macro dest,src
db 78,dest,src
endm
CONS_ macro dest,car,cdr
db 79,dest,car,cdr
endm
SETCAR_ macro dest,src
db 20,dest,src
endm
SETCDR_ macro dest,src
db 21,dest,src
endm
ST_S_ macro dest,src,off
db 17,dest,src,offset off
endm
ST_L_ macro dest,src,off
db 18,dest,src
dw offset off
endm
ST_R_ macro dest,src,off
db 19,dest,src,off
endm
SETREF_ macro val,ref
db 22,val,ref
endm
JMP_S_ macro label
db 32,label-$-1
endm
JMP_L_ macro label
db 33
dw label-$-2
endm
JNIL_S_ macro reg,label
db 34,reg,label-$-1
endm
JNIL_L_ macro reg,label
db 35,reg
dw label-$-2
endm
JNNIL_S_ macro reg,label
db 36,reg,label-$-1
endm
JNNIL_L_ macro reg,label
db 37,reg
dw label-$-2
endm
JATOM_S_ macro reg,label
db 38,reg,label-$-1
endm
JATOM_L_ macro reg,label
db 39,reg
dw label-$-2
endm
JNATOM_S_ macro reg,label
db 40,reg,label-$-1
endm
JNATOM_L_ macro reg,label
db 41,reg
dw label-$-2
endm
DEREF_ macro dest ; (deref x)
db 46,dest
endm
REF_ macro dest ; (ref x)
db 47,dest
endm
CALL_ macro label,dl_lvl,dl_heap
db 48
dw label-$-4
db dl_lvl,dl_heap
endm
CALL_TR_ macro label,dl_lvl,dl_heap
db 49
dw label-$-4
db dl_lvl,dl_heap
endm
CALL_CC_ macro label,dl_lvl,dl_heap
db 50
dw label-$-4
db dl_lvl,dl_heap
endm
CALL_CT_ macro label,dl_lvl,dl_heap
db 51
dw label-$-4
db dl_lvl,dl_heap
endm
CALL_CL_ macro reg,nargs
db 52,reg,nargs
endm
CLOSURP_ macro dest ; (closure? obj)
db 129,dest
endm
FLUID_P_ macro dest ; (fluid-bound? obj)
db 134,dest
endm
STRINGP_ macro dest ; (string? obj)
db 143,dest
endm
SYMBOLP_ macro dest ; (symbol? obj)
db 144,dest
endm
MINUS_ macro dest ; (minus n)
db 151,dest
endm
A_S_ macro dest ; (ascii->symbol n)
db 160,dest
endm
S_A_ macro dest ; (symbol->ascii sym)
db 161,dest
endm
ADD_ macro dest,src
db 80,dest,src
endm
ADDI_ macro dest,imm
db 81,dest,imm
endm
SUB_ macro dest,src
db 82,dest,src
endm
MUL_ macro dest,src
db 83,dest,src
endm
MULI_ macro dest,imm
db 84,dest,imm
endm
DIV_ macro dest,src
db 85,dest,src
endm
DIVI_ macro dest,imm
db 86,dest,imm
endm
MOD_ macro dest,src
db 88,dest,src
endm
JEQ_S_ macro reg1,reg2,label
db 42,reg1,reg2,label-$-1
endm
JEQ_L_ macro reg1,reg2,label
db 43,reg1,reg2
dw label-$-2
endm
JNEQ_S_ macro reg1,reg2,label
db 44,reg1,reg2,label-$-1
endm
JNEQ_L_ macro reg1,reg2,label
db 45,reg1,reg2
dw label-$-2
endm
EQ_ macro n1,n2
db 94,n1,n2
endm
NE_ macro n1,n2
db 97,n1,n2
endm
LT_ macro n1,n2
db 92,n1,n2
endm
GT_ macro n1,n2
db 95,n1,n2
endm
LE_ macro n1,n2
db 93,n1,n2
endm
GE_ macro n1,n2
db 96,n1,n2
endm
EQ_Z_ macro dest ; (=0 n)
db 146,dest
endm
LT_Z_ macro dest ; (<0 n)
db 147,dest
endm
GT_Z_ macro dest ; (>0 n)
db 148,dest
endm
ABS_ macro dest ; (abs n)
db 149,dest
endm
FLOOR_ macro dest ; (floor n)
db 152,dest
endm
FLOAT_ macro dest ; (float n)
db 150,dest
endm
GENSYM_ macro dest ; (gensym sym)
db 162,dest
endm
EXPLODE_ macro dest ; (explode sym)
db 163,dest
endm
IMPLODE_ macro dest ; (implode list)
db 164,dest
endm
LENGTH_ macro dest ; (length list)
db 165,dest
endm
LAST_PR_ macro dest ; (last-pair list)
db 166,dest
endm
POP_ macro dest
db 24,dest
endm
PUSH_ macro dest
db 25,dest
endm
DROP_ macro count
db 26,count
endm
EXECUTE_ macro code
db 58,code
endm
EXIT_ macro ; restore (return from call)
db 59
endm
APPLY_ macro ftn,arg ; apply funtion to args
db 56,ftn,arg
endm
APPLYTR_ macro ftn,arg ; apply funtion to args-tail recursive
db 57,ftn,arg
endm
CB_ALLOC_ macro dest ; allocate code block
db 172,dest
endm
ST_CONST_ macro src,cb,offset ; store constant
db 173,src,cb,offset
endm
ST_BYTE_ macro src,cb,offset ; store code byte
db 174,src,cb,offset
endm
OPEN_ macro file,mode ; open I/O port
db 176,file,mode
endm
CLOSEP_ macro file ; close I/O port
db 177,file
endm
PRIN1_ macro dest,port ; print s-expression
db 178,dest,port
endm
PRINC_ macro dest,port ; print s-expression
db 179,dest,port
endm
PRINT_ macro dest,port ; print s-expression
db 180,dest,port
endm
NEWLINE_ macro port ; print newline
db 181,port
endm
READ_ macro dest ; read s-expression
db 182,dest
endm
FASL_ macro dest ; fast load
db 191,dest
endm
HALT_ macro ; return to MS-DOS
db 248
endm
GC_ macro ; garbage collect
db 249
endm
PTIME_ macro ; display current time
db 250
endm
S_RESET_ macro ; scheme-reset
db 252
endm
CLR_REG_ macro ; clear registers
db 253
endm
DEBUG_ macro ; begin debug mode
db 255
endm


512
sbid.asm Normal file
View File

@ -0,0 +1,512 @@
;
;***************************************
;* TIPC Scheme Runtime Support *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 5 June 1985 *
;* Last Modification: 15 May 1986 *
;***************************************
page 60,132
MSDOS equ 021h ; MS-DOS service call interrupt
FREEMEM equ 049h ; Free memory function identifier
MODIFMEM equ 04Ah ; Modify allocated memory function id
BIDTASK equ 04Bh ; Load and execute program function id
PRSTRING equ 09h
CREATE_FL equ 3Ch ; Create file function
OPEN_FL equ 3Dh ; Open file function
CLOSE_FL equ 3Eh ; Close file function
READ_FL equ 3Fh ; Read file function
WRITE_FL equ 40h ; Write file function
DELETE_FL equ 41h ; Delete file function
GET_DRIVE equ 19h ; Current disk function
SET_DRIVE equ 0Eh ; Select disk function
GET_DIR equ 47h ; Return text of current directory function
SET_DIR equ 3Bh ; Change the current directory function
TI_CRTINT equ 49h*4 ; CRT dsr interrupt - TI
IBM_CRTINT equ 10h*4 ; CRT dsr interrupt - IBM
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
extrn _paras:word ; total number of paragraphs available
extrn _psp:dword ; program segment prefix paragraph address
; extrn first_pa:word ; seg addr of 1st page in Scheme heap
extrn first_dos:word ; seg addr of memory allocated to Scheme heap
extrn PC_MAKE:word ; type of machine
drive db ? ; place holder for current drive number
dir_path db ? ; Drive Letter (as part of the path name)
db ":\" ; GET_DIR function doesn't prepend "root"
path db 80 dup(?) ; dir path buffer, excluding drive
sav_file db "pc__s.sav",00 ; ASCIZ save file pathname
len_sav_name equ $-sav_file
cmd_ db "COMSPEC="
cmd_1 equ $
ENVPTR dw 0 ; DOS EXEC parameter block
CMDOFF dw 0 ; "
CMDSEG dw 0 ; "
FCB1OFF dw 5Ch ; "
FCB1SEG dw 0 ; "
FCB2OFF dw 6Ch ; "
FCB2SEG dw 0 ; "
data ends
XGROUP group PROGX
PROGX segment byte public 'PROGX'
assume CS:XGROUP
public install
public uninstall
;************************************************************************
;* Bid another Task *
;************************************************************************
bid_args struc
dw ? ; caller's BP
dw ? ; caller's ES
dd ? ; far return address to caller of bid_task
dw ? ; near return address to caller of bid
bid_file dw ? ; program's file name
bid_parm dw ? ; parameters
free_req dw ? ; requested # of free paragraphs
bid_args ends
sav_SP dw 0 ; save area for current stack pointer
sav_SS dw 0 ; save area for stack segment register
;
; Paragraph Addresses
;
; _paras --> +--------------------+ <----
; | /|\ | : Freed for bidded task,
; | | | : Saved to disk save file
; | | -- free_req | : start: _paras - free_req
; | | | : length: free_req
; | \|/ | : (free_req >= _paras - first_dos)
; |~~~~~~~~~~~~~~~~~~~~| <----
; | | :
; | (heap) | : Allocated to stay resident
; | | : # paras: _paras -
; first_pa --> +--------------------+ : _psp -
; | (unused area) | : free_req
; first_dos --> +--------------------+ :
; | | :
; | (PCS) | :
; | | :
; | | :
; _psp --> +--------------------+ <----
; | |
;
close proc near ; Closes the file whose handle is in BX
mov AH,CLOSE_FL
int MSDOS
ret
close endp
delete proc near ; Deletes the save file
assume DS:DGROUP
mov DX,offset dir_path
mov AH,DELETE_FL
int MSDOS
ret
delete endp
bid_task proc far
push ES
push BP
mov BP,SP ; establish local addressability
; Check if requested # of free paragraphs within bounds
cmp [BP].free_req,0 ; default to free max?
je free_all ; yes, branch
mov AX,_paras ; compute requested base of free area
sub AX,[BP].free_req ;
jb free_all ; request greater than all memory? branch
cmp AX,first_dos ; below base of free-able area?
jnb req_ok ; no, ok -- jump
free_all: mov AX,_paras ; compute max # of free-able paras
sub AX,first_dos ;
mov [BP].free_req,AX ; update # of paras to free
req_ok:
; Save Scheme's user memory
; First create save file
; Save current drive and directory path
mov AH,GET_DRIVE ; get current drive number (0=A,1=B,...,4=E)
int MSDOS
mov drive,AL ; and save it
inc AL ; "correct" current drive number
mov DL,AL ; put current drive into DL
add AL,40h ; (make it a capital letter)
mov dir_path,AL ; put the drive letter into dir_path
mov SI,offset path ; point DS:SI to path buffer
mov AH,GET_DIR ; get current path
int MSDOS
; Append save file's name to end of directory path
find_end: mov BX,offset path ; point to beginning of path name
mov CX,64 ; maximum length of path name
findloop: cmp byte ptr [BX],0
je name_end
inc BX
loop findloop
name_end: cmp byte ptr [BX-1],'\' ; was last character a backslash?
je add_save ; if so then don't append another one (jump!)
mov byte ptr [BX],'\' ; else append a backslash then the filename
inc BX
add_save: push SI ; Now add concat'nate filename (PC__S.SAV)
mov AX,DS
mov ES,AX
mov DI,BX ; load destination address
mov SI,offset sav_file
mov CX,len_sav_name
rep movsb ; appending the save file name + NULL
pop SI
; Now open the save file...
mov DX,offset dir_path ; point DS:DX to ASCIZ save file path
mov CX,20h ; file attribute
mov AH,CREATE_FL
int MSDOS ; do it
jnb crt_ok ; branch if create ok
jmp exit ; quit now if unable to create save file
crt_ok:
; Now dump memory to the file (file handle in AX)
mov BX,AX ; put file handle into BX
mov DI,[BP].free_req ; DI = number of paras to write
mov AX,_paras ; compute base of area to free
sub AX,[BP].free_req ;
push DS ; save DS
mov DS,AX ; init DS:DX to base of area to save
xor DX,DX ;
wrt_para: cmp DI,0FFFh ; can write all paras in one shot?
jbe wrt_last ; yes, jump
sub DI,0FFFh ; dec paras-to-write count
mov CX,0FFF0h ; write FFF0 bytes
mov AH,WRITE_FL
int MSDOS ; do it
jb wrt_err ; branch if error
cmp AX,CX ; wrote all bytes?
je wrt_ok1 ; yes, branch
mov AX,20 ; indicate write count error
jmp short wrt_err
wrt_ok1: mov AX,DS ; inc buffer pointer
add AX,0FFFh
mov DS,AX
jmp wrt_para ; write out next FFF paras
wrt_last: mov CL,4 ; shift para count to byte count
shl DI,CL
mov CX,DI ; put byte count into CX
mov AH,WRITE_FL
int MSDOS ; do it
jb wrt_err ; branch if error
cmp AX,CX ; wrote all bytes?
je wrt_ok2
mov AX,20 ; indicate write count error
wrt_err: pop DS ; restore DS
push AX ; save error code
call close ; close and delete save file
call delete
pop AX ; restore error code
jmp exit ; and quit
wrt_ok2: pop DS ; restore DS
call close ; close up file for safe keeping
jnb wrt_ok3 ; branch if all ok
jmp exit ; quit if can't close file
wrt_ok3:
; Free up Scheme's user memory
mov ES,first_dos ; point ES to base of allocated area
mov BX,_paras ; compute # paras to remain allocated
sub BX,first_dos ;
sub BX,[BP].free_req ;
mov AH,MODIFMEM ; load modify memory function id
int MSDOS ; change PCS memory allocation
jnc mem_ok
memerr: push AX ; save error code
call delete ; delete save file
pop AX ; restore error code
jmp exit ; and quit
mem_ok:
; Bid up specified program
; Set up parameter block
mov AX,[BP].bid_parm ; Set up dword pointer to command line
mov CMDOFF,AX
mov CMDSEG,DS
mov AX,word ptr _psp+2 ; Point to FCBs in program segment prefix
mov FCB1SEG,AX
mov FCB2SEG,AX
mov ES,AX
mov AX,ES:[02Ch] ; copy current environment ptr to
mov ENVPTR,AX ; parameter area
; Set ES:BX to address of parameter block
mov AX,DS
mov ES,AX
mov BX,offset ENVPTR
; Set DS:DX to address of ASCIZ pathname (of file to be loaded)
push DS ; save DS segment register
mov DX,[BP].bid_file
mov DI,DX
cmp byte ptr [di],0 ; check if pt'ed to string is empty
jne bid_it
; No filename-- bid up a new command interpreter;
; have to search environment for COMSPEC= string
mov ES,ENVPTR ; ES:DI points to 1st string in environment
xor DI,DI
; Test for end of environment
get_plop: cmp byte ptr ES:[DI],0 ; last entry in environment?
je cmd_err ; if so, COMSPEC= not found
mov SI,offset cmd_ ; load address of comparison string
mov CX,cmd_1-cmd_ ; and length of same
repe cmps cmd_,ES:[DI] ; does this entry begin "COMSPEC="?
je found ; if so, found it! (jump)
xor AX,AX ; clear AX for search
mov CX,-1 ; set CX for maximum length
repne scas byte ptr ES:[DI] ; find \0 which terminates string
jmp get_plop ; loop
; No command interpreter found
cmd_err: mov AX,10 ; treat as bad-environment error
jmp short bid_err
; Found COMSPEC=
found: mov DX,DI ; DS:DX is ptr to command interpreter
push DS ; (swap DS and ES)
push ES
pop DS
pop ES
; issue load task function call
bid_it: push BP ; Old IBM-PCs & XTs destroy BP on func 4B.
mov CS:sav_SP,SP ; save current stack pointer
mov CS:sav_SS,SS ; save stack segment register
xor AL,AL ; load and execute condition
mov AH,BIDTASK ; load "load and execute" ftn id
int MSDOS ; perform service call
cli ; disable all interrupts
mov SS,CS:sav_SS ; restore stack base pointer
mov SP,CS:sav_SP ; restore stack pointer
sti ; enable interrupts
pop BP ; restore BP (Thanks IBM) :-(
pop DS ; restore DS segment register
jb bid_err ; branch if error in bidding task
xor AX,AX ; indicate no error
bid_err: push AX ; save error code
; ReAllocate Scheme's user memory
mov ES,first_dos ; point ES to base of allocated area
mov BX,_paras ; compute # of all available paras
sub BX,first_dos ;
mov AH,MODIFMEM ; load modify memory function id
int MSDOS ; change PCS memory allocation
jnc read_mem
fatal: pop AX ; throw away bid error code
call delete ; delete save file
mov AX,0FFFFh ; indicate cannot continue, -1
jmp exit
; Restore Scheme's user memory
; First open save file
read_mem: mov DX,offset dir_path ; point DS:DX to ASCIZ save file path
mov AL,00 ; access code for reading
mov AH,OPEN_FL
int MSDOS ; do it
jb fatal ; abort if cannot open save file
; Now read memory from the file (file handle in AX)
mov BX,AX ; put file handle into BX
mov DI,[BP].free_req ; DI = number of paras to read
mov AX,_paras ; compute base of area to restore from disk
sub AX,[BP].free_req ;
push DS ; save DS
mov DS,AX ; init DS:DX to base of area to restore
xor DX,DX
rd_para: cmp DI,0FFFh ; can read all paras in one shot?
jbe rd_last ; yes, jump
sub DI,0FFFh ; dec paras-to-read count
mov CX,0FFF0h ; read FFF0 bytes
mov AH,READ_FL
int MSDOS ; do it
jb read_err ; branch if read error
cmp AX,CX ; read all bytes?
jne read_err ; no, branch
read_ok1: mov AX,DS ; inc buffer pointer
add AX,0FFFh
mov DS,AX
jmp rd_para ; read in next FFF paras
rd_last: mov CL,4 ; shift para count to byte count
shl DI,CL
mov CX,DI ; put byte count into CX
mov AH,READ_FL
int MSDOS ; do it
jb read_err ; branch if error reading file
cmp AX,CX ; read all bytes?
je read_ok2 ; yes, branch
read_err: pop DS ; restore DS
call close ; close save file
jmp fatal ; and abort
read_ok2: pop DS ; restore DS
call close ; close save file
call delete ; and delete it
pop AX ; restore bid error code
exit: pop BP ; restore caller's BP
pop ES ; restore ES segment register
ret ; return to caller
bid_task endp
;------------------------------------------------------------------------
; The following routines will inhibit text display to the screen for
; the duration of the dos-call.
;
; Note: Programs such as Lotus 1-2-3 which write directly to the
; screen memory will still be visible.
;
;------------------------------------------------------------------------
exec_args struc
dw ? ; caller's BP
dd ? ; far return address to caller of install
dw ? ; near return address to caller of exec
file dw ? ; program's file name
parm dw ? ; parameters
fre_req dw ? ; requested # of free paragraphs
display dw ? ; Indicates if screen should be disturbed
exec_args ends
CRTSAV dd ?
CRTINT dw ?
DSSAV dw ?
INSTALLED dw ?
install proc far
; This routine installs a routine at the CRT DSR interrupt
;
push bp
mov bp,sp
push bx
mov cs:INSTALLED,0 ; Assume routine won't be installed
mov bx,[BP].display ; Indicates if commands will be sent
cmp bx,0 ; Screen can be disturbed?
pop bx
jne non_null ; Install new interrupt routine
jmp xinstall ; exit
non_null:
mov cs:INSTALLED,1
push ds
push es
push ax
push bx
push dx
push si
push di
mov ax,ds
mov cs:DSSAV,ax
;
; Install new routine at the CRT DSR interrupt
;
mov ax,0 ; Save off routine adr of CRT DSR
mov ds,ax
mov si,offset xgroup:CRTSAV
mov word ptr cs:[CRTINT],IBM_CRTINT ; Assume its IBM
mov es,cs:DSSAV
cmp word ptr es:PC_MAKE,1 ; Is it a TI?
jne is_IBM
mov word ptr cs:[CRTINT],TI_CRTINT
is_IBM:
mov di,cs:CRTINT
mov ax,ds:[di]
mov cs:[si],ax
mov ax,ds:[di+2]
mov cs:[si+2],ax
cli ; Clear interrupts
mov ax,offset xgroup:crtdsr
mov ds:[di],ax
mov ds:[di+2],cs
sti ; Enable interrupts
pop di
pop si
pop dx
pop bx
pop ax
pop es
pop ds
xinstall:
pop bp
ret
install endp
; **************************************************************************
; This routine restores the original routine for the CRT DSR interrupt
;
uninstall proc far
cmp cs:INSTALLED,1 ; Was an int routine installed?
je non_null2
jmp xuninstall
non_null2:
push ds
push ax
push si
push di
mov ax,0
mov ds,ax
mov si,offset xgroup:CRTSAV ; Restore CRT DSR routine
mov ax,cs:[si]
mov di,cs:CRTINT
mov ds:[di],ax
mov ax,cs:[si+2]
mov ds:[di+2],ax
pop di
pop si
pop ax
pop ds
xuninstall:
ret
uninstall endp
;
; This is the do-nothing routine installed at the CRT DSR interrupt
;
crtproc proc far
crtdsr:
sti
mov ax,0
iret
crtproc endp
PROGX ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
extrn unfixint:near
extrn zcuron:near
extrn zcuroff:near
extrn fix_intr:near
public bid
bid proc near
call unfixint ; reset shift-break vector
call zcuron ; turn the cursor back on
call install
call bid_task
push AX ; save error code
call uninstall
call zcuroff ; turn the cursor back off
call fix_intr ; set shift-break vector
pop AX ; restore error code
ret
bid endp
prog ends
end


707
sbigmath.asm Normal file
View File

@ -0,0 +1,707 @@
; =====> SBIGMATH.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Bignum Math Utilities *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: June 1984 *
;* Last Modification: 27 May 1986 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
data ends
XGROUP GROUP PROGX
PROGX segment byte public 'PROGX'
assume CS:XGROUP,DS:DGROUP
; Convert a bignum to a flonum
; Calling sequence: big2flo(bigptr,floptr)
; Where: bigptr ---- pointer to bignum workspace
; floptr ---- pointer to flonum
b2fargs struc
dw ? ;Caller's BP
dd ? ;Return address
dw ? ;Another return address
big dw ? ;Pointer to bignum
flo dw ? ;Pointer to flonum
b2fargs ends
%big2flo proc far
push BP
mov BP,SP
cld ;Direction forward
mov SI,[BP].big ;Point DS:SI to working bignum
mov CX,[SI] ;Get size
cmp CX,3
ja all64 ;Jump if at least 64 bits
add SI,3 ;Point to bignum proper
xor BX,BX
xor DI,DI
lodsw ;Fetch least sig. word
mov DX,AX ;Store in DX
dec CX
jcxz smljust ;Jump if no more bignum words
lodsw ;Else get next least sig. word
mov DI,AX
dec CX
jcxz smljust ;Jump if no more bignum words
lodsw ;Get 3rd least sig. word
mov BX,AX
smljust: xor AX,AX ;Clear most sig. word
jmp short justify ;Left-justify the number
all64: shl CX,1 ;Point SI to 4th most sig. word
add SI,CX
sub SI,5
lodsw ;Load bignum into registers
mov DX,AX
lodsw
mov DI,AX
lodsw
mov BX,AX
lodsw
;JUSTIFY: At this stage, the 64 most significant bignum bits are in
; AX:BX:DI:DX respectively, AX most significant
justify: mov SI,[BP].big ;Fetch pointer to bignum again
mov CX,[SI] ;Get size (words)
cmp CX,40h
ja toobig ;Jump if bignum too big
cmp CX,4 ;Skip if not a small bignum
jae enough
mov CX,4 ;Otherwise, start with constant
enough: shl CX,1 ;Multiply by 16 (size in bits)
shl CX,1
shl CX,1
shl CX,1
justflp: dec CX ;Reduce exponent
shl DX,1 ;Shift bignum left
rcl DI,1
rcl BX,1
rcl AX,1
jnc justflp ;Until most significant 1 vanishes
add CX,3ffh ;Add flonum exponent constant
mov SI,DI ;Now use SI for num, DI for address
shftrt: shr CX,1 ;Shift CX:AX:BX:SI:DX as one
rcr AX,1
rcr BX,1
rcr SI,1
rcr DX,1
cmp CX,80h ;Until most sig. exponent bit is in 2nd
jae shftrt ; most sig. bit of CL
mov DI,[BP].big ;Get pointer to bignum again
test byte ptr[DI]+2,1 ;Negative?
jz posskip ;No, skip
or CL,80h ;Set sign bit
posskip: mov DI,[BP].flo ;Point ES:DI to flonum
push AX ;Save part of new flonum
mov AL,DH ;Write to flonum space
stosb
mov AX,SI
stosw
mov AX,BX
stosw
pop AX
stosw
mov AL,CL
stosb
xor AX,AX ;Return 0 if all well
pop BP ;Restore BP
ret
toobig: mov AX,1 ;Return 1 if conversion impossible
pop BP
ret
%big2flo endp
; Convert fixnum to bignum
; Calling sequence: fix2big(fixnum,bigptr)
; Where: fixnum ---- Integer of small absolute value
; bigptr ---- Pointer to bignum space
f2bargs struc
dw ? ;Caller's BP
dd ? ;Return address
dw ? ;Another return address
fix dw ? ;Fixnum
bigp dw ? ;Pointer to bignum
f2bargs ends
%fix2big proc far
push BP
mov BP,SP
mov DI,[BP].bigp ;Point ES:DI to bignum
mov AX,1 ;Fill size field
stosw
xor AL,AL ;Clear AL
mov BX,[BP].fix ;Fetch fixnum value
shl BX,1 ;Put sign bit in AL
rcl AL,1
stosb ;Fill sign field
sar BX,1 ;Restore fixnum
or AL,AL ;Negative fixnum?
jz posfx ;Skip if positive
neg BX ;Otherwise, find absolute value
posfx: mov [DI],BX ;Store magnitude of fixnum
pop BP ;Restore BP
ret
%fix2big endp
;;;; Decrement bignum
;;;; Calling sequence: sub1big(buf)
;;;; Where: buf ---- pointer to bignum
;;;unibig struc
;;; dw ? ;Return address
;;;bbuf dw ? ;Pointer to working bignum
;;;unibig ends
;;; public sub1big
;;;sub1big proc far
;;; mov BX,SP ;Get bignum pointer
;;; mov SI,SS:[BX].bbuf
;;; test byte ptr[SI]+2,1 ;Is bignum negative?
;;; jnz incbig ;If so, increase magnitude
;;; jmp short decbig ;Else decrease magnitude
;;;sub1big endp
;;;; Increment bignum
;;;; Calling sequence: add1big(buf)
;;; public add1big
;;;add1big proc far
;;; mov BX,SP ;Get bignum pointer
;;; mov SI,SS:[BX].bbuf
;;; test byte ptr[SI]+2,1 ;Is bignum negative?
;;; jnz decbig ;Yes, decrease magnitude
;;;;INCBIG increments magnitude of working bignum at DS:SI
;;;incbig: mov DI,SI ;Save bignum pointer
;;; mov CX,[SI] ;Get length (words)
;;; add SI,3 ;Point to bignum proper
;;;carrylp: inc word ptr[SI] ;Increment bignum
;;; jnz done ;If no carry, finished
;;; inc SI ;Else go to next word
;;; inc SI
;;; loop carrylp ;Loop while not end of bignum
;;; mov word ptr[SI],1 ;Else place final 1
;;; inc word ptr[DI] ;Lengthen bignum
;;;done: ret
;;;;DECBIG decrements magnitude of working bignum at DS:SI
;;;decbig: mov DI,SI ;Save pointer
;;; mov CX,[SI] ;Get length
;;; add SI,3 ;Point to bignum proper
;;; dec CX ;CX = (length - 1)
;;;borrowlp: lodsw ;Load current word
;;; sub AX,1 ;Decrement and store
;;; mov [SI-2],AX
;;; jnc done ;Jump if no borrow
;;; loop borrowlp ;Loop if not on last word
;;; dec word ptr[SI] ;Else decrement last word
;;; jnz done ;Jump if bignum not to be shortened
;;; dec word ptr[DI] ;Else shorten
;;; ret
;;;add1big endp
; set up big1's index for comparison, used with %magcomp
%pbig1 proc near
shl CX,1
dec SI
add SI,CX
shr CX,1
ret
%pbig1 endp
; set up big1's index for comparison, used with %magcomp
%pbig2 proc near
shl CX,1
dec DI
add DI,CX
shr CX,1
ret
%pbig2 endp
; Compare magnitudes of two bignums
; Calling sequence: data = magcomp(big1,big2)
; Where: big1,big2 -- pointers to bignum buffers
; data ------- a positive integer as follows:
; Bit 0 set iff |BIG1| < |BIG2|
; Bit 1 set iff |BIG1| > |BIG2|
; Bit 2 set iff BIG1 < BIG2
; Bit 3 set iff BIG1 > BIG2
; Bit 4 set iff BIG1,BIG2 have same sign
twobigs struc
dd ? ;Return address
dw ? ;Another return address
big1 dw ? ;First bignum
big2 dw ? ;Second bignum
twobigs ends
%magcomp proc far
xor AL,AL ;Clear AL
xor DX,DX ; clear DX
mov BX,SP ;Fetch bignum pointers
mov SI,[BX].big1
mov DI,[BX].big2
mov AH,[SI]+2 ;Get sign bits
mov DH,[DI]+2
xor DH,AH ;Put XOR of signs into carry
shr DH,1
jc sgnskp ;Jump if different signs
or AL,16 ;Else set proper bit in AL
sgnskp: rcl AH,1
mov CX,[SI] ;Get BIG1's length
mov DX,[DI] ; get BIG2's length
cld ;Direction forward
cmpsw ;Compare lengths
jb bigr2 ;Jump if BIG2 longer
ja bigr1 ;Jump if BIG1 longer
same_ln: call %pbig1 ;If same size, point SI,DI to last words
call %pbig2 ; (most significant)
std ;Direction backward
repe cmpsw ;Repeat until unequal
jb rbig2
ja rbig1
test AH,1 ;Signs same?
jz compend ;Yes, exit
difsign: test AH,2 ;Is BIG1 positive?
jnz grtr2 ;No, BIG2 is greater
jz grtr1 ;Else BIG1 is greater
bigr1: call %pbig1
cmp word ptr [SI],0 ; check high word,
jne rbig1 ; big1 is really bigger
mov SI,[BX].big1 ; restore SI
inc SI
inc SI
dec CX ; high order word is empty
cmp CX,DX ; compare length's again
je same_ln ; same length
jmp bigr1 ; repeat until unequal or same lengths
rbig1: or AL,2 ;Set the |BIG1|>|BIG2| bit
test AH,1 ;Signs same?
jnz difsign ;No, different signs
test AH,2 ;Both positive?
jnz grtr2 ;No, so BIG2 is greater
grtr1: or AL,8 ;Set the BIG1>BIG2 bit
cld ; Set direction forward (JCJ-12/6/84)
ret
bigr2: push CX
mov CX,DX ; swap CX and DX
pop DX
call %pbig2 ; Set up big2's pointers
cmp word ptr [DI],0 ; check high word
jne rbig2 ; big2 really is bigger
mov DI,[BX].big2 ; restore DI
inc DI
inc DI
dec CX ; high order word is empty
cmp DX,CX ; compare length's again
je same_ln ;
jmp bigr2 ; repeat until unequal or same lengths
rbig2: or AL,1 ;Set the |BIG1|<|BIG2| bit
test AH,1 ;Signs same?
jnz difsign ;No, different signs
test AH,2 ;Both positive?
jnz grtr1 ;No, BIG1 is greater
grtr2: or AL,4 ;Set the BIG1<BIG2 bit
compend: cld ; Set direction forward (JCJ-12/6/84)
ret
%magcomp endp
; Add magnitudes of bignums
; Calling sequence: bigadd(big1,big2)
; Where: big1 ---- bignum of lesser magnitude
; big2 ---- bignum of greater magnitude
; When done, BIG2 will hold the sum
%bigadd proc far
mov BX,SP ;Fetch bignum pointers
mov SI,[BX].big1
mov DI,[BX].big2
cld ;Direction forward
lodsw ;Get length of smaller bignum
mov CX,AX ;Save length
sub AX,[DI] ;Find and push difference in lengths
neg AX
push AX
inc SI ;Point SI,DI to bignums proper
add DI,3
clc ;Prepare to add
addlp: lodsw ;Fetch source addend
adc [DI],AX ;Add to destination addend
inc DI ;Point DI to next word
inc DI
loop addlp ;Do until smaller bignum exhausted
pop CX ;Fetch length difference (CF unchanged)
jnc doneadd ;Stop if no carry
mov SI,[BX].big2 ;Point SI to destination bignum
jcxz samlen ;Jump if bignums the same length
adclp: inc word ptr[DI] ;Otherwise, add carry
jnz doneadd ;Jump if no resultant carry
add DI,2 ;Point DI to next word
loop adclp ;Do until whole number is done or no carry
samlen: mov word ptr[DI],1 ;Store last carry
inc word ptr[SI] ;Note bignum's size increase
doneadd: ret
%bigadd endp
; Subtract magnitudes of bignums
; Calling sequence: bigsub(big1,big2)
; Where: big1 ---- bignum of lesser magnitude
; big2 ---- bignum of greater magnitude
; When done, BIG2 will hold the difference
; When done, BIG2 will hold the sum
%bigsub proc far
mov BX,SP ;Fetch pointers to bignums
mov SI,[BX].big1
mov DI,[BX].big2
cld ;Direction forward
lodsw ;Get length of smaller bignum
mov CX,AX
inc SI ;Point SI,DI to bignums proper
add DI,3
clc ;Prepare to subtract
sublp: lodsw ;Fetch subtrahend
sbb [DI],AX ;Subtract
inc DI ;Point DI to next word
inc DI
loop sublp ;Do until smaller bignum exhausted
jnc pack ;Jump if no borrow
borlp: mov AX,[DI] ;Fetch word
sub AX,1 ;Decrement and store
stosw
jc borlp ;Jump if further borrowing needed
pack: mov DI,[BX].big2 ;Fetch pointer to 2nd bignum
mov SI,DI ;Save pointer in SI
mov AX,[SI] ;Fetch bignum length
mov CX,AX ;Save (length-1) in CX
dec CX
shl AX,1 ;Point DI to last word of bignum
inc AX
add DI,AX
std ;Direction backward
xor AX,AX ;Find number of leading 0-words
repe scasw ; (not counting least sig. word)
jz smlskp ;Jump if only one non-0 word
inc CX ;Else, at least 2 non-0 words
smlskp: inc CX ;Form (length - # of leading 0-words)
mov [SI],CX ;Save in bignum size field
cld ;Clear the direction flag
ret
%bigsub endp
; Multiply two bignums
; Calling sequence: bigmul(big1,big2,big3)
; Where: big1,big2 -- factors
; big3 ------- destination of product
mulargs struc
carry dw ? ;Multiplication carry
dw ? ;Caller's BP
dd ? ;Return address
dw ? ;Another return address
mbig1 dw ? ;Factor of greater magnitude
mbig2 dw ? ;Factor of lesser magnitude
mbig3 dw ? ;Product destination
mulargs ends
; When done, BIG2 will hold the sum
%bigmul proc far
push BP ;Save BP
dec SP ;Create space for multiplication carry
dec SP
mov BP,SP ;Point BP to args
cld ;Direction forward
mov SI,[BP].mbig1 ;Fetch factor pointers
mov DI,[BP].mbig2
lodsw ;Fetch BIG1's length
mov CX,AX ;Put sum of lengths in CX
add CX,[DI]
scasw ;Which has greater magnitude?
jae xchgskp ;Jump if BIG1 is not smaller
xchg DI,SI
xchgskp: lodsb ;Fetch one factor's sign
xor AL,[DI] ;XOR with the other factor's sign
inc DI ;Point DI to bignum proper
mov BX,DI ;And store in BX
mov DI,[BP].mbig3 ;Store length into product
xchg AX,CX
stosw
push AX ;Save total length of product
xchg AX,CX ;Store sign byte into product
stosb
push DI ;Set product to 0 over whole length
xor AX,AX
rep stosw
pop DI
xchg DI,BX ;Restore BX and DI
mov CX,[DI]-3 ;Fetch length of BIG2
sub BX,SI ;Point [BX+SI-2] to product
dec BX
dec BX
mov [BP].mbig1,SI ;Store pointer to data of BIG1
mullp2: push CX ;Save counter of BIG2 words
;Add (BIG1*part of BIG2) to current product
mov word ptr[BP].carry,0 ;Clear carry in
mov SI,[BP].mbig1 ;Fetch bignum pointer
mov CX,[SI]-3 ;Get number of words in bignum
mullp: lodsw ;Get factor part from BIG1
mul word ptr[DI] ;Multiply by factor part from BIG2
add AX,[BP].carry ;Add carry in
adc DX,0
add [BX+SI],AX ;Add product part into BIG3
adc DX,0 ;Adjust and store carry
mov [BP].carry,DX
loop mullp ;Continue for all BIG1
mov [BX+SI+2],DX ;Store carry remaining
;
pop CX ;Restore BIG2 counter
inc DI ;Point DI to next word in BIG2
inc DI
inc BX ;Point BX to next word in BIG3
inc BX
loop mullp2 ;Continue for all BIG2
mov BX,[BP].mbig3 ;Fetch pointer to BIG3 (beginning)
pop SI ;Point SI to last word of product
shl SI,1
inc SI
add SI,BX
cmp word ptr[SI],0 ;Test last word for zero
jnz muldone ;Done if not zero
dec word ptr[BX] ;Decrement bignum length
muldone: inc SP ;Discard temporary carry variable
inc SP
pop BP ;Restore BP
ret
%bigmul endp
; Divide one bignum by another
; Calling sequence: bigdiv(dvdnd,dvsr,quot)
; Where: dvdnd ----- dividend
; dvsr ------ divisor
; quot ------ quotient
divargs struc
dw ? ;Caller's BP
dvsrsz dw ? ;Size of divisor (words)
bitcount dw ? ;Estimated bits in quotient
align dw ? ;Alignment of dividend to divisor
ldvsr dw ? ;Pointer to last word of divisor
dd ? ;Return address
dw ? ;Another return address
dvdnd dw ? ;Dividend
dvsr dw ? ;Divisor
quot dw ? ;Quotient
divargs ends
; When done, BIG2 will hold the sum
%bigdiv proc far
sub SP,8 ;Room for local variables
push BP
mov BP,SP
mov DI,[BP].quot ;Get pointers to arguments
mov SI,[BP].dvdnd
mov BX,[BP].dvsr
cld ;Direction forward
lodsw ;Get dividend length
mov CX,[BX] ;Fetch divisor length
cmp CX,1 ;Check divisor for 0
jne dvsrok
cmp word ptr[BX]+3,0 ;Check divisor data word
jnz dvsrok
mov AX,CX ;Put nonzero value in AX
pop BP
add SP,8 ;Restore stack
ret ;Exit
dvsrok: inc BX ;Point BX+1 to divisor sign
mov DX,CX ;Find & store pointer to last divisor word
shl DX,1
add DX,BX
mov [BP].ldvsr,DX
sub AX,CX ;Find dividend-divisor length difference
mov DX,AX ;Save in DX for now
inc AX ;Store maximum quotient length (words)
stosw
inc CX ;Save length of working divisor
mov [BP].dvsrsz,CX
dec AX ;Find and store quotient bit count
shl AX,1
shl AX,1
shl AX,1
shl AX,1
inc AX
mov [BP].bitcount,AX
lodsb ;Get dividend sign
xor AL,[BX]+1 ;Find and store quotient sign
stosb
mov [BP].dvdnd,SI ;Save pointer to dividend proper
mov [BP].quot,DI ;Save pointer to quotient proper
xor AX,AX ;Zero first two words of quotient
stosw
std
stosw
dec DX ;Account for extra divisor word
shl DX,1 ;Store divisor-dividend alignment
add DX,SI
mov [BP].align,DX
mov word ptr[BX],0 ;Put 0-word at start of divisor
mov [BP].dvsr,BX ;Save pointer to working divisor
bigdivlp: call divcmp ;Dividend less than aligned divisor?
jb divbit0 ;Yes, perform division
test word ptr[BX],8000h ;Can divisor be shifted left?
jnz divbit1 ;No, perform division
mov SI,[BP].dvsr ;Otherwise, shift entire divisor left
mov CX,[BP].dvsrsz
clc ;Start by shifting in 0
shllp: rcl word ptr[SI],1 ;Shift through divisor word
inc SI ;Point SI to next word
inc SI
loop shllp ;Do for entire divisor
inc [BP].bitcount ;Increase bit count
jmp bigdivlp ;See if divisor is big enough yet
divlp: call divcmp ;Dividend less than aligned divisor?
cld ; (Direction forward)
jb divbit0 ;Yes, rotate 0 into quotient
mov SI,[BP].align ;Otherwise, subtract divisor
mov DI,SI
mov BX,[BP].dvsr
sub BX,SI
dec BX
dec BX
mov CX,[BP].dvsrsz
clc ;No carry in
divsublp: lodsw
sbb AX,[SI+BX]
stosw
loop divsublp
divbit1: clc ;Clear carry (to rotate 1 in)
divbit0: cmc
mov SI,[BP].quot ;Fetch pointer to quotient
mov CX,[SI]-3 ;Fetch quotient length
quotlp: rcl word ptr[SI],1 ;Rotate bit in
inc SI
inc SI
loop quotlp ;Rotate bits through whole quotient
dec [BP].bitcount ;Last quotient bit rotated in?
jz divdone ;Yes, stop
mov SI,[BP].ldvsr ;Otherwise realign divisor (shr)
mov CX,[BP].dvsrsz
std ;Direction backward
cmp word ptr[SI],0 ;Time to shift divisor words?
jnz wshftskp ;No, don't bother
mov BX,SI ;Save last word pointer
mov DX,CX ;Save word count
mov DI,SI ;Destination = source+2
dec SI
dec SI
dec CX ;Shift significant divisor words
rep movsw
xor AX,AX ;Clear least significant word
stosw
mov SI,BX ;Restore last word pointer
mov CX,DX ;Restore count
sub [BP].align,2 ;Reset divisor alignment
wshftskp: clc ;Shift 0 in
shrlp: rcr word ptr[SI],1 ;Shift
dec SI
dec SI
loop shrlp ;Shift entire divisor
jmp divlp ;After all this, loop 'til division done
divdone: mov BX,[BP].dvdnd ;Fetch dividend pointer
mov DI,[BX]-3 ;Fetch former length of dividend
dec DI ;Put length-1 in CX
mov CX,DI
shl DI,1 ;Point DI to last dividend word
add DI,BX
std ;Direction backward
xor AX,AX ;Pack as in BIGSUB
repe scasw
jz smlskp2
inc CX
smlskp2: inc CX
mov [BX]-3,CX ;Save in bignum size field
mov BX,[BP].quot ;Fetch quotient pointer
mov DI,[BX]-3 ;Point BX+DI to last quotient word
dec DI
shl DI,1
cmp word ptr[BX+DI],0 ;If last word is 0, decrease length
jnz divex
dec word ptr[BX]-3
divex: pop BP ;Restore stack
add SP,8
xor AX,AX ;Return 0
cld ;Clear direction flag
ret
%bigdiv endp
;Compare working divisor to dividend
divcmp proc near
mov DI,[BP].ldvsr ;Get pointer to last divisor word
mov CX,[BP].dvsrsz ;Fetch number of compares to do
mov SI,[BP].align ;Get dividend pointer
mov AX,CX ;Save # of wrods for pointer adjust
cmp SI,[BP].dvdnd ;Dividend longer than divisor?
jae adjskp ;Yes, jump
dec CX ;Don't compare first divisor word
adjskp: dec AX ;Adjust pointer into dividend
shl AX,1
add SI,AX
mov BX,DI ;Save pointer to last divisor byte
std ;Direction backward
repz cmpsw ;Compare until unequal
ret
divcmp endp
PROGX ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
public big2flo
big2flo proc near
call %big2flo
ret
big2flo endp
public fix2big
fix2big proc near
call %fix2big
ret
fix2big endp
public magcomp
magcomp proc near
call %magcomp
ret
magcomp endp
public bigadd
bigadd proc near
call %bigadd
ret
bigadd endp
public bigsub
bigsub proc near
call %bigsub
ret
bigsub endp
public bigmul
bigmul proc near
call %bigmul
ret
bigmul endp
public bigdiv
bigdiv proc near
call %bigdiv
ret
bigdiv endp
prog ends
end


1277
sc.asm Normal file
View File

File diff suppressed because it is too large Load Diff

453
scannum.asm Normal file
View File

@ -0,0 +1,453 @@
; =====> SCANNUM.ASM
;****************************************
;* TIPC Scheme '84 Runtime Support *
;* Numeric I/O Support *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 12 June 1985 *
;* Last Modification: 22 July 1985 *
;****************************************
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
public decpoint
decpoint db '.'
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
; Classify numeric string ending with a control character
; Calling sequence: scannum(s,base)
; Where ---- s: pointer to start of character string
; base: default base
; This function returns 0 if not a number, -1 if a flonum, and n>0
; if an integer, where n is the number of digits in the integer.
;
; NOTE : DS is not guaranteed to point to the local data segment
;
scanargs struc
dw ? ;Caller's BP
dw ? ;Return address
sptr dw ? ;Pointer to string
scanbase dw ? ;Default base
scanargs ends
public scannum
scannum proc near
push BP
mov BP,SP
cld ;Direction forward
mov SI,[BP].sptr ;Point DS:SI to characters
mov BX,[BP].scanbase ;Set default base
xor CX,CX ;Initialize digit count
baselp: lodsb ;Fetch first char
cmp AL,'#' ;Skip over the base macros
jne nomac
lodsb ;Get base argument
sub AL,40h
js nonnum ;If not a base designator, not a number
and AL,0dfh ;Shift to upper case
xor BL,BL ;Zero current base
cmp AL,5 ;Check for #E,#I,#L,#S macros
je baselp ; (legal, but don't affect base)
cmp AL,9
je baselp
cmp AL,12
je baselp
cmp AL,19
je baselp
cmp AL,2 ;Jump if binary (#B)
je bbin
cmp AL,4 ;Jump if decimal (#D)
je bdec
cmp AL,15 ;Jump if octal (#O)
je boct
cmp AL,24 ;Jump if hexadecimal (#X)
je bhex
cmp AL,8 ;Jump if not #H (the only legal one left)
jne nonnum
bhex: mov BL,6
bdec: add BL,2
boct: add BL,6
bbin: add BL,2
jmp baselp ;Check for another switch
nomac: cmp AL,'+' ;If +, note its presence
je wassign
cmp AL,'-' ;If not -, skip next char fetch
jne notsign
wassign: lodsb ;Fetch next char
notsign: cmp AL,ss:decpoint ;Decimal point already?
je point1 ;Jump if so... must be a flonum
call isdg ;Otherwise, there must be a digit
jnc nonnum ;If not, not a number
wholelp: lodsb ;Else get next character
call isdg
jc wholelp ;Keep reading digits in whole part
cmp AL,32 ;End of string?
jb intnum ;Yes, we have an integer
cmp AL,ss:decpoint ;Jump on decimal point
je point
call ismarker ;Jump if exponent marker (E or L valid)
je expon
nonnum: xor AX,AX ;Return 0, forget all else
pop BP
ret
intnum: mov AX,CX ;Return digit count
pop BP
ret
point1: lodsb ;We must have digit here
call isdg
jnc nonnum
point: lodsb ;Get characters up to non-digit
call isdg
jc point
cmp AL,32 ;If end of string, we have flonum
jb flonum
call ismarker ;Otherwise, check for exponent marker
je expon
jne nonnum
expon: mov BL,10 ;Exponents are in base 10
lodsb ;Get next char
cmp AL,'-' ;Valid exponent sign
jne edig ;Jump if not signed
lodsb ;Else get next char
edig: call isdg ;We must end with a nonempty string
jnc nonnum ; of base 10 digits
exponlp: lodsb
call isdg
jc exponlp
cmp AL,32 ;If not end of string, nonnum
jae nonnum
flonum: mov AX,-1 ;Return -1 (flonum code)
pop BP
ret
;ISDG: CF is set iff the char in AL is a digit in base BX
; Also, if a digit, the digit count in CX is incremented
isdg: cmp AL,'0' ;Not if below 0
jl nodig
cmp AL,'1' ;0 or 1 anytime
jbe yesdig
cmp BL,2 ;Nothing else for base 2
je nodig
cmp AL,'7' ;2-7 for base 8,10,16
jbe yesdig
cmp BL,8 ;Nothing else for base 8
je nodig
cmp AL,'9' ;8 or 9 for bases 10 or 16
jbe yesdig
cmp BL,10 ;Nothing else for base 10
je nodig
and AL,0dfh ;Convert to upper case
cmp AL,'A' ;Base 16... Check for A-F
jb nodig
cmp AL,'F'
jbe yesdig
nodig: clc
ret
yesdig: inc CX ;Increment digit count
stc
ret
;ISMARKER: ZF is set iff the character in AL is an exponent marker
ismarker: cmp AL,'e'
je mark
cmp AL,'l'
je mark
cmp AL,'E'
je mark
cmp AL,'L'
je mark
mark: ret
scannum endp
; Check character for digit status in a given base
; Calling sequence: isdig(c,base)
; Where ---- c: character to check
; base: base in which to check
isdargs struc
dw ? ;Caller's BP
dw ? ;Return address
charg dw ? ;Character
barg dw ? ;Base
isdargs ends
public isdig
isdig proc near
push BP
mov BP,SP
mov AL,byte ptr[BP].charg ;Fetch character
mov BX,[BP].barg ;Fetch base
call isdg ;Determine digitness
jc wasdg ;Was a digit...don't zero AX
xor AX,AX ;Otherwise return 0
wasdg: pop BP
ret
isdig endp
; Convert digit character to its value
; Calling sequence: digval(c)
; Where ---- c: assumed to be a digit character
digargs struc
dw ? ;Caller's BP
dw ? ;Return address
carg dw ? ;Character
digargs ends
public digval
digval proc near
push BP
mov BP,SP
mov AL,byte ptr[BP].carg ;Fetch character
xor AH,AH
and AL,01fh ;Reduce bits
cmp AL,16 ;Number or letter?
jb hexdig ;Jump if letter
and AL,0fh ;Zero the high nibble
pop BP
ret
hexdig: add AL,9 ;Raise the lower nibble
pop BP
ret
digval endp
; Convert flonum in interval [1.0e15,1.0e16) to bignum
; Calling sequence: flo2big(flo,buf)
; Where ---- flo: flonum in interval [1e15,1e16)
; buf: bignum math buffer, minimum size 11 bytes
flo2args struc
dw ? ;Caller's BP
dw ? ;Return address
num dw ?,?,?,? ;Flonum (4 words)
big dw ? ;Pointer to math buffer
flo2args ends
public flo2big
flo2big proc near
push BP
mov BP,SP
mov DI,[BP].big ;Point DI to math buffer
cld ;Direction forward
mov AX,4 ;Store bignum size (words) in buffer
stosw
mov AX,[BP+6].num ;Fetch exponent
mov CX,AX ;Save exponent in CX
rol AX,1 ;Store sign in buffer
and AL,1
stosb
mov AX,CX ;Restore exponent to AX
xor CH,CH ;Put (433h-exponent) in CX
shr CL,1
shr CL,1
shr CL,1
shr CL,1
sub CL,3
neg CL
and AX,0fh ;Remove exponent from word in AX
or AL,10h
lea SI,[BP].num ;Point SI to flonum
movsw
movsw
movsw
stosw ;Word that used to have exponent
sub DI,8 ;Point DI back to start of bignum
cmp CL,-1 ;Branch if mantissa to be shifted left
je manleft
or CL,CL ;Branch if not to be shifted right
jz shifted
manright: shr word ptr[DI+6],1 ;Shift bignum right
rcr word ptr[DI+4],1
rcr word ptr[DI+2],1
rcr word ptr[DI],1
loop manright ;Loop until done
jmp short shifted
manleft: shl word ptr[DI],1 ;Shift bignum left
rcl word ptr[DI+2],1
rcl word ptr[DI+4],1
rcl word ptr[DI+6],1
shifted: pop BP
ret
flo2big endp
; Form floating-point ASCII representation from 16 digits and scale
; Calling sequence: formflo(digs,chars,scale,prec,exp)
; Where ---- digs: the digit characters of the flonum
; chars: buffer to store the formed flonum
; scale: flonum exponent part
; prec: desired precision
; exp: whether to use exponential format
; Returns the length of the formed flonum string
formargs struc
dw ? ;Caller's BP
dw ? ;Return address
digptr dw ? ;Pointer to digits
chrptr dw ? ;Pointer to result string
scale dw ? ;Exponent part
fprec dw ? ;Precision
fexp dw ? ;Exponential format specifier
formargs ends
public formflo
formflo proc near
push BP
mov BP,SP
mov SI,[BP].digptr ;Point SI to digit string
mov DI,[BP].chrptr ;Point DI to destination
cld ;Direction forward
mov DX,[BP].fexp ;Fetch form specifier
mov AL,[SI] ;Fetch first digit
cmp AL,'0'
je toosmall ;Jump if zero
cmp AL,'-' ;Negative sign?
jne nonsign ;Jump if not signed
signed: stosb ;Put sign in return buffer
inc [BP].digptr ;Adjust pointer to first digit
inc SI
nonsign: mov BX,14 ;Round off the last digit
call round
mov BX,[BP].fprec ;Fetch precision
or BX,BX
jz putspace ;Jump if arbitrary precision
;Determine location at which to begin rounding
cmp BX,14 ;If precision out of range, replace
jbe precok ; with highest possible
mov BX,14
precok: or DX,DX
jnz doround ;If exponential, round now
add BX,[BP].scale ;Add scale to precision
jns notsmall ;Jump unless number rounds to 0
cmp BX,-1
jne toosmall ;Jump if num definitely rounds to 0
cmp byte ptr[SI],'5' ;Check sigfig
jb toosmall ;Jump if too small
mov word ptr[SI],2031h ;Else round up and adjust scale
inc [BP].scale
jmp short spaced
toosmall: mov AL,'0' ;Put (prec+1) 0's at start of input
mov BX,[BP].fprec ; buffer
toosmlp: mov [SI],AL
inc SI
dec BL
jns toosmlp
mov byte ptr[SI],' ' ;Follow by space
mov DI,[BP].chrptr ;Start output over (wipe out any sign)
jmp short spaced
notsmall: cmp BX,16
jae spaced ;Jump if no sense in rounding
doround: call round ;Round the digits
jmp short spaced
;For arbitrary precision, change all trailing zeros to spaces
; (there exists at least one nonzero digit)
putspace: add SI,14 ;Point SI to last digit
spacelp: cmp byte ptr[SI],'0'
jne spaced
and byte ptr[SI],0efh
dec SI
jmp spacelp
;Now the spaces are in - start formatting
spaced: mov SI,[BP].digptr ;Point SI to digit string
mov BX,[BP].scale ;Fetch scale
mov CX,[BP].fprec ;Fetch precision
or DX,DX ;If exponent form desired
jnz exform ; supply it
cmp BX,-14 ;If scale>-15, check precision
jge midscale
or CL,CL ;If precision arbitrary, force expo-form
jz exform
midscale: cmp BX,0
jl smallfix ;Branch if explicit form called for
cmp BX,14
jle largefix ;Branch if explicit, but >1
;Form an exponential-format flonum
exform: movsb ;Transfer first digit
mov AL,decpoint ;Place decimal point
placex: stosb ;Store character
lodsb ;Transfer digits up to first space
cmp AL,' '
jne placex
mov AL,'e' ;Place exponent marker
stosb
cmp BH,0 ;If scale negative, negate & store sign
jge posscale
neg BX
mov AL,'-'
stosb
posscale: mov AX,BX ;Move scale to AX
mov BH,10 ;Put divisor in BH
mov DX,SP ;Save current stack pointer
divlpf: div BH ;Divide
mov BL,AH ;Push digit
add BL,'0'
push BX
xor AH,AH ;Remove the remainder
or AL,AL ;Loop until the quotient is zero
jnz divlpf
storelp: pop AX ;Restore exponent digit
stosb ;Place it
cmp SP,DX ;Loop until no more digits left
jne storelp
jmp short retlen
;Form a fixed-decimal flonum magnitude greater than 1
largefix: lodsb ;Fetch digit
or AL,10h ;Turn ' ' to '0'
stosb ;Store digit
dec BL ;Loop until all pre-point digs done
jns largefix
mov AL,decpoint ;Place decimal point
stosb
digmrg: or CL,CL
jnz preclp ;Jump if precision set
arblp: lodsb ;Otherwise, arbitrary; do until space
cmp AL,' '
je retlen
stosb
jmp arblp
llp: stosb
preclp: dec CL ;Last digit done?
js retlen ;Jump if so
dodigs: lodsb ;Now do digits until precision reached
cmp AL,' ' ;Space?
jne llp ;If not, store it
dec SI ;Restore SI
mov AL,'0' ;Prepare to place 0
jmp llp
;Form a fixed-decimal flonum magnitude less than 1
smallfix: mov CH,CL ;Copy precision to CH
mov AL,'0' ;Place "0."
stosb
mov AL,decpoint
slp: stosb
inc BX
jz digmrg ;If 0's done, do significant figures
or CH,CH ;If precision was zero
jz skpprec ; don't bother checking it
dec CL
js retlen ;If the precision is reached, stop
skpprec: mov AL,'0' ;Otherwise, place 0's until scale=0
jmp slp
;Formation complete
retlen: mov AX,DI ;Return length of string
sub AX,[BP].chrptr
pop BP
ret
;ROUND: Round the ASCII digits of a flonum, starting at [BX+SI]
; SI->start of digits and is unchanged; BX destroyed
round: mov AL,' ' ;Get digit after least-rounded and
xchg AL,[BX+SI+1] ; replace it with a space
cmp AL,'5'
jb rounded ;Jump if rounded down
roundlp: mov AL,[BX+SI] ;Otherwise, increment digit
inc AL
mov [BX+SI],AL ;Replace incremented digit
cmp AL,'9'
jbe rounded ;Jump if no carryover
mov byte ptr[BX+SI],'0' ;Else replace digit
dec BX ;Go to next digit
jns roundlp
mov byte ptr[BX+SI+1],'1' ;There are no more digits, place
inc [BP].scale ; leading 1 and adjust scale
rounded: ret
formflo endp
prog ends
end


651
scar_cdr.asm Normal file
View File

@ -0,0 +1,651 @@
; =====> SCAR_CDR.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;*Interpreter -- Car and Cdr operations*
;* *
;* (C) Copyright 1984,1985,1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 11 September 1984 *
;* Last Modification: 26 February 1986*
;***************************************
include scheme.equ
; Modification History:
; 26 Feb 86 - modified the "CONS" support to attempt a "short circuit"
; (JCJ) allocation of a list cell, instead of calling the
; "alloc_list_cell" support unconditionally.
include sinterp.mac
include sinterp.arg
take_car macro
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,ES:[SI].car_page
mov SI,ES:[SI].car
endm
take_cdr macro
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_cdr
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,ES:[SI].cdr_page
mov SI,ES:[SI].cdr
endm
; load arguments for cxr
load_arg macro
lods word ptr ES:[SI] ; fetch source/destination register numbers
save <SI> ; save the location pointer
mov BL,AH ; copy the source register number
mov SI,reg0_dis+[BX] ; load contents of the source register
mov BL,byte ptr reg0_pag+[BX]
endm
car_cdr2 macro arg1,arg2
mov CX,offset PGROUP:arg1&_last
mov DI,offset PGROUP:arg2&_CX
jmp load_ops
endm
car_cdr3 macro arg1,arg2,arg3
mov DX,offset PGROUP:arg1&_last
mov CX,offset PGROUP:arg2&_DX
mov DI,offset PGROUP:arg3&_CX
jmp load_ops
endm
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
m_car db "CAR",0
m_cdr db "CDR",0
m_caar db "CAAR",0
m_cadr db "CADR",0
m_cdar db "CDAR",0
m_cddr db "CDDR",0
m_caaar db "CAAAR",0
m_caadr db "CAADR",0
m_cadar db "CADAR",0
m_caddr db "CADDR",0
m_cdaar db "CDAAR",0
m_cdadr db "CDADR",0
m_cddar db "CDDAR",0
m_cdddr db "CDDDR",0
m_cadddr db "CADDDR",0
m_%car db "%CAR",0
m_%cdr db "%CDR",0
m_table dw m_car,m_cdr,m_caar,m_cadr,m_cdar,m_cddr,m_caaar,m_caadr
dw m_cadar,m_caddr,m_cdaar,m_cdadr,m_cddar,m_cdddr,m_cadddr
m_setcar db "SET-CAR!",0
m_setcdr db "SET-CDR!",0
m_apendb db "APPEND!",0
m_ltail db "LIST_TAIL",0
m_one dw 1 ; a constant "one" (1)
m_two dw 2 ; a constant "two" (2)
m_three dw 3 ; a constant "three" (3)
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
car_cdr proc near
; Entry points defined in "sinterp.asm"
extrn next:near ; Top of interpreter
extrn next_PC:near ; Reload ES,SI at top of interpreter
extrn next_SP:near ; Reload SP,ES,SI at top of interpreter
extrn src_err:near ; "source operand error" message display
extrn sch_err:near ; "source operand error" message display
extrn printf_c:near ; Error message print routine
;************************************************************************
;* %car %CAR DEST *
;* *
;* Purpose: To obtain the first element of a list. This support is *
;* similar to the usual "car" operation except that %car *
;* returns #!unassigned if one tries to take the car of *
;* nil. *
;************************************************************************
public ld_car1
ld_car1: lods byte ptr ES:[SI] ; load operand
save <SI> ; save the location pointer
mov BX,AX ; copy operand register number to BX
mov SI,reg0_dis+[BX] ; load the source operand
mov BL,byte ptr reg0_pag+[BX]
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car1 ; if not a list cell, error (jump)
cmp BL,0 ; is source operand nil?
jne car_last ; if not nil, jump
cxr_undf: mov BX,AX ; reload dest register number
mov byte ptr reg0_pag+[BX],UN_PAGE*2 ; set destination reg
mov reg0_dis+[BX],UN_DISP ; to #!unassigned
jmp next_PC
bad_car1: mov AX,offset m_%car
jmp bad_one
;************************************************************************
;* %cdr %CDR DEST *
;* *
;* Purpose: To obtain the rest of a list. This support is similar *
;* to the usual "cdr" operation except that %cdr returns *
;* #!unassigned if one tries to take the cdr of nil. *
;************************************************************************
public ld_cdr1
ld_cdr1: lods byte ptr ES:[SI] ; load operand
save <SI> ; save the location pointer
mov BX,AX ; copy operand register number to BX
mov SI,reg0_dis+[BX] ; load the source operand
mov BL,byte ptr reg0_pag+[BX]
cmp BL,0 ; is source operand nil?
je cxr_undf ; if nil, return #!unassigned (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2
je cdr_last ; if a list cell, continue processing (jump)
jmp bad_cdr1 ; if not a list cell, error (jump)
bad_cdr1: mov AX,offset m_%cdr
jmp bad_one
;************************************************************************
;* AL AH *
;* Take "car" of a list cell LD_CAR dest,src *
;************************************************************************
public ld_car
ld_car: load_arg
car_last: cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car ; if not a list cell, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load para addr of page containing cell
mov BL,AL ; copy destination register number
mov AL,ES:[SI].car_page ; copy contents of car field into
mov byte ptr reg0_pag+[BX],AL ; the destination register
mov AX,ES:[SI].car
mov reg0_dis+[BX],AX
jmp next_PC ; return to the interpreter
car_CX: take_car
jmp CX
car_DX: take_car
jmp DX
;************************************************************************
;* AL AH *
;* Take "cdr" of a list cell LD_CDR dest,src *
;************************************************************************
public ld_cdr
ld_cdr: load_arg
cdr_last: cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_cdr ; if not a list cell, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load para addr of page containing cell
mov BL,AL ; copy destination register number
mov AL,ES:[SI].cdr_page ; copy contents of cdr field into
mov byte ptr reg0_pag+[BX],AL ; the destination register
mov AX,ES:[SI].cdr
mov reg0_dis+[BX],AX
jmp next_PC ; return to the interpreter
; ***Error-- attempt to take "car" of non- list cell***
bad_car:
; ***Error-- attempt to take "cdr" of non- list cell***
bad_cdr: les SI,dword ptr [BP].save_SI ; load next instruction's address
xor BX,BX ; load opcode of failing instruction
mov BL,ES:[SI]-3
shl BX,1
mov AX,m_table+[BX]-128
bad_one: les SI,dword ptr [BP].save_SI ; load next instruction's address
xor BX,BX
mov BL,ES:[SI]-1 ; load register used as last operand
add BX,offset reg0
pushm <BX,m_one,AX>
C_call set_src_,,Load_ES
jmp sch_err ; display error message
cdr_CX: take_cdr
jmp CX
cdr_DX: take_cdr
jmp DX
;************************************************************************
;* AL AH *
;* Take "cadddr" of a list cell LD_CADDDR dest,src *
;************************************************************************
public ld_caddd
ld_caddd: load_arg
take_cdr
mov DX,offset PGROUP:car_last
mov CX,offset PGROUP:cdr_DX
jmp cdr_CX
load_ops: load_arg
jmp DI
;************************************************************************
;* AL AH *
;* Take "caar" of a list cell LD_CAAR dest,src *
;************************************************************************
public ld_caar
ld_caar: car_cdr2 car,car
;************************************************************************
;* AL AH *
;* Take "cadr" of a list cell LD_CADR dest,src *
;************************************************************************
public ld_cadr
ld_cadr: car_cdr2 car,cdr
;************************************************************************
;* AL AH *
;* Take "cdar" of a list cell LD_CDAR dest,src *
;************************************************************************
public ld_cdar
ld_cdar: car_cdr2 cdr,car
;************************************************************************
;* AL AH *
;* Take "cddr" of a list cell LD_CDDR dest,src *
;************************************************************************
public ld_cddr
ld_cddr: car_cdr2 cdr,cdr
;************************************************************************
;* AL AH *
;* Take "caaar" of a list cell LD_CAAAR dest,src *
;************************************************************************
public ld_caaar
ld_caaar: car_cdr3 car,car,car
;************************************************************************
;* AL AH *
;* Take "caadr" of a list cell LD_CAADR dest,src *
;************************************************************************
public ld_caadr
ld_caadr: car_cdr3 car,car,cdr
;************************************************************************
;* AL AH *
;* Take "cadar" of a list cell LD_CADAR dest,src *
;************************************************************************
public ld_cadar
ld_cadar: car_cdr3 car,cdr,car
;************************************************************************
;* AL AH *
;* Take "caddr" of a list cell LD_CADDR dest,src *
;************************************************************************
public ld_caddr
ld_caddr: car_cdr3 car,cdr,cdr
;************************************************************************
;* AL AH *
;* Take "cdaar" of a list cell LD_CDAAR dest,src *
;************************************************************************
public ld_cdaar
ld_cdaar: car_cdr3 cdr,car,car
;************************************************************************
;* AL AH *
;* Take "cdadr" of a list cell LD_CDADR dest,src *
;************************************************************************
public ld_cdadr
ld_cdadr: car_cdr3 cdr,car,cdr
;************************************************************************
;* AL AH *
;* Take "cddar" of a list cell LD_CDDAR dest,src *
;************************************************************************
public ld_cddar
ld_cddar: car_cdr3 cdr,cdr,car
;************************************************************************
;* AL AH *
;* Take "cdddr" of a list cell LD_CDDDR dest,src *
;************************************************************************
public ld_cdddr
ld_cdddr: car_cdr3 cdr,cdr,cdr
;************************************************************************
;* Macro support for set-car!/set-cdr! *
;************************************************************************
set_cc macro field
local x
lods word ptr ES:[SI] ; load register numbers
mov DX,ES ; save TIPC register ES
mov BL,AL
mov DI,reg0_pag+[BX] ; load dest register page number
cmp DI,0 ; are we trying to set car/cdr of nil?
je x ; if (set-cxr nil v), error (jump)
cmp byte ptr ptype+[DI],LISTTYPE*2 ; Is destination a list cell?
jne x ; If not, set_field! not defined
LoadPage ES,DI
;;; mov ES,pagetabl+[DI] ; Load paragraph addr for dest page
mov DI,reg0_dis+[BX] ; Load destination displacement
mov BL,AH ; Copy src register number
mov AL,byte ptr reg0_pag+[BX] ; redefine field's page number
mov ES:[DI].&field&_page,AL
mov AX,reg0_dis+[BX] ; redefine field's displacement
mov ES:[DI].&field,AX
mov ES,DX ; reload ES segment register
jmp next
x: mov BX,offset m_set&field ; load address of message text
IFIDN <&field>,<car>
bad_stcr: mov ES,DX
bad_st1: xor AX,AX
mov AL,ES:[SI]-1
add AX,offset reg0
push AX
xor AX,AX
mov AL,ES:[SI]-2
add AX,offset reg0
pushm <AX,m_two,BX>
C_call set_src_,<SI>,Load_ES
restore <SI>
jmp sch_err
ELSE
jmp bad_stcr
ENDIF
endm
;************************************************************************
;* AL AH *
;* Side effect car field (set-car! dest src) SET-CAR! dest,src *
;* *
;* Purpose: Interpreter support for the set-car! operation. *
;************************************************************************
public set_car
set_car: set_cc car
;************************************************************************
;* AL AH *
;* Side effect cdr field (set-cdr! dest src) SET-CDR! dest,src *
;* *
;* Purpose: Interpreter support for the set-cdr! operation. *
;************************************************************************
public set_cdr
set_cdr: set_cc cdr
purge set_cc
;************************************************************************
;* DL DH AL *
;* Cons - Create and define new list cell CONS dest,car,cdr *
;* *
;* Purpose: Interpreter support for the Scheme "cons" operation. *
;************************************************************************
public s_cons
s_cons: lods word ptr ES:[SI] ; load destination/car register numbers
mov DX,AX ; and save in DX
xor AX,AX
lods byte ptr ES:[SI] ; load cdr register number
save <SI> ; save the location pointer
; Attempt a "short circuit" list cell allocation
mov DI,listpage
;;; cmp DI,END_LIST
;;; je cons_no
shl DI,1
mov SI,nextcell+[DI]
cmp SI,END_LIST
je cons_no
LoadPage ES,DI
;;; mov ES,pagetabl+[DI] ; load list cell page's segment address
mov CX,ES:[SI].car
mov nextcell+[DI],CX
; Move contents of CDR register to CDR field of new list cell
cons_ok: mov BX,AX ; copy register number to BX
mov AL,byte ptr reg0_pag+[BX]
mov ES:[SI].cdr_page,AL
mov AX,reg0_dis+[BX]
mov ES:[SI].cdr,AX
; Move contents of CAR register to CAR field of new list cell
mov BL,DH ; copy CAR register number to BX
mov AL,byte ptr reg0_pag+[BX]
mov ES:[SI].car_page,AL
mov AX,reg0_dis+[BX]
mov ES:[SI].car,AX
; Update destination register number with pointer to new list cell
mov BL,DL
mov reg0_pag+[BX],DI
mov reg0_dis+[BX],SI
jmp next_SP
; "short circuit" list cell allocation failed-- go through channels
cons_no: push tmp_adr
C_call alloc_li,<AX,DX>,Load_ES
add SP,WORDINCR
restore <AX,DX>
mov DI,tmp_page
mov SI,tmp_disp
LoadPage ES,DI
;;; mov ES,pagetabl+[DI]
jmp cons_ok
;************************************************************************
;* List - Create and define new list cell w/ nil cdr LIST dest *
;* *
;* Purpose: Interpreter support for the Scheme "list" operation. *
;************************************************************************
public s_list
s_list: lods byte ptr ES:[SI] ; load destination register number
mov BX,offset tmp_reg ; load address of temporary register
pushm <AX,BX> ; push dest reg number, temp_reg address
C_call alloc_li,<SI>,Load_ES ; allocate list cell
add SP,WORDINCR ; dump argument from TIPC's stack
pop SI ; restore destination register pointer
mov BX,tmp_page ; load page number of new list cell
mov CX,BX
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list cell's page table address
mov DI,tmp_disp ; load displacement of new list cell
; copy car field into newly allocated list cell
mov AX,reg0_dis+[SI] ; load car's displacement, and
mov ES:[DI].car,AX ; store into new list cell
mov AL,byte ptr reg0_pag+[SI] ; load page number, and
mov ES:[DI].car_page,AL ; store it, too
; create nil cdr field into newly allocated list cell
xor AX,AX
mov ES:[DI].cdr,AX
mov ES:[DI].cdr_page,AL
; copy pointer to new list cell into destination register
mov byte ptr reg0_pag+[SI],CL
mov reg0_dis+[SI],DI
jmp next_PC
;************************************************************************
;* AL AH *
;* (list a b) LIST2 dest,src *
;* *
;* Purpose: Interpreter support for the (list a b) operation. *
;* *
;* Description: This operation: (list a b) *
;* is equivalent to: (cons a (cons b nil)) *
;************************************************************************
public list2
list2: lods word ptr ES:[SI] ; fetch operands
mov BL,AL ; save the destination register number
push BX
mov BL,AH ; copy the source register number
add BX,offset reg0 ; compute source register address
mov AX,offset nil_reg ; load "nil_reg" address
mov CX,offset tmp_reg ; load "tmp_reg" address
pushm <AX,BX,CX> ; push arguments to cons
C_call cons,<SI>,Load_ES ; call: cons(tmp_reg,src,nil_reg)
pop CX ; restore tmp_reg address
add SP,WORDINCR*2 ; drop arguments from TIPC's stack
pop BX ; restore destination register number
add BX,offset reg0 ; compute destination register address
pushm <CX,BX,BX> ; push arguments to cons
C_call cons ; call: cons(dest, dest, tmp_reg)
jmp next_SP ; return to the interpreter
;************************************************************************
;* (append! list obj) append! dest src *
;* *
;* Purpose: Scheme interpreter support for the append! primitive *
;************************************************************************
public appendb
appendb: lods word ptr ES:[SI] ; get args (AL=arg1, AH=arg2)
save <SI> ; save the location pntr
mov BL,AL
lea DI,reg0+[BX] ; DI=address of dest reg
mov BX,[DI].C_page ; load list header from dest reg
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is arg1 a list?
jne short not_list ; if not, error (jump)
;
cmp BL,NIL_PAGE*2 ; is arg1 == nil?
jne short find_end ; if not, continue (jump)
;
mov BL,AH ; else get 2nd arg & return it in dest reg
lea SI,reg0+[BX] ; SI=address of src reg
mov BX,[SI].C_page ; Copy src reg to dest reg
mov [DI].C_page,BX
mov BX,[SI].C_disp
mov [DI].C_disp,BX
jmp next_PC ; RETURN
;
find_end label near
mov CX,SB_CHECK ; load shift-break iteration count
mov DI,[DI].C_disp
next_cell label near
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list cell page para address
mov BL,ES:[DI].cdr_page ; load list cell's cdr's page
cmp BL,NIL_PAGE*2 ; CDR == nil?
je short eolist ; then end-of-list (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2 ; still pointing to cons nodes?
jne short weird_lst
mov DI,ES:[DI].cdr ; load list cell's cdr's displacement
loop next_cell
; Every one in awhile, check for shift-break
mov CX,SB_CHECK ; reload the shift-break iteration count
cmp s_break,0 ; has the shift-break key been depressed?
je next_cell ; if no shift-break, jump
push m_three ; push instruction length = 3
C_call restart ; link to Scheme debugger
; Note: control does not return from "restart"
;
weird_lst label near ; possible error checking here
; as list was non-nil terminated
eolist label near
mov BL,AH ; else get 2nd arg & return it in dest reg
lea SI,reg0+[BX] ; SI=address of src reg
mov BX,[SI].C_page ; Copy src reg to dest reg
; check page # for src?
mov ES:[DI].cdr_page,BL
mov BX,[SI].C_disp
mov ES:[DI].cdr,bx
jmp next_PC ; return to interpreter
not_list label near
mov BX,offset m_apendb
jmp bad_st1
;************************************************************************
;* (list_tail list count) l_tail list(dest) count *
;* *
;* Purpose: Scheme interpreter support for the list_tail primitive *
;************************************************************************
lt_args struc
COUNT dw ? ; Long integer count of list element
dw ?
REGSAVE dw ?
BP_SAVE dw ? ; Saved base pointer
ES_SAVE dw ? ; Saved ES reg
lt_args ends
public l_tail
l_tail:
lods word ptr ES:[SI] ; get register operands
save <SI> ; save instruction pointer
push ES ; save local registers
push BP
sub SP,offset BP_SAVE ; allocate local storage
mov BP,SP
xor BH,BH
mov BL,AL
add BX,offset reg0 ; reg holding list ptr
mov [BP].REGSAVE,BX ; save for later
xor BH,BH
mov BL,AH
add BX,offset reg0 ; get register containing count
push BX ; and push for call
lea BX,[BP+COUNT] ; get location for return value
push BX ; and push for call
mov DX,DS
mov ES,DX ; set ES for C routine
C_call int2long ; convert register to long
mov SP,BP
or ax,ax
jnz lt_err ; jump on error
mov ax,[BP].COUNT+2 ; get high word of long integer
or ax,ax ; if negative
js lt_rtn ; return
mov SI,[BP].REGSAVE ; reg holding list ptr
mov BX,[SI].C_page ; BX <= page of list
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is it a list ?
jne lt_err ; no, jump
mov AX,BX ; AX <= page of list
mov BX,[SI].C_disp ; BX <= disp of list
lt_loop:
mov CX,[BP].COUNT+2 ; get lsw of long int
or CX,[BP].COUNT
jz lt_rtn ; jump if long int = zero
cmp AX,NIL_PAGE ; end of list?
je lt_rtn ; yes, return
LoadPage ES,AX ; ES <= page address of list cell
mov AL,ES:[BX].cdr_page ; AX <= page # of cdr
mov BX,ES:[BX].cdr ; BX <= disp of cdr
sub word ptr [BP].COUNT,1 ; decrement count
sbb word ptr [BP].COUNT+2,0
jmp lt_loop ; and loop
lt_rtn:
mov byte ptr [SI].C_page,AL ; save page in reg
mov [SI].C_disp,BX ; save disp in reg
add SP,BP_SAVE
pop BP
pop ES
jmp next_SP
lt_err:
add SP,BP_SAVE
pop BP
pop ES ; restore ES register
restore <SI> ; and instruction pointer
xor AX,AX
mov AL,ES:[SI]-1
add AX,offset reg0 ; get last operand
push AX ; and push for call
xor AX,AX
mov AL,ES:[SI]-2
add AX,offset reg0 ; get first operand
push AX ; and push for call
mov BX,offset m_ltail ; load address of message text
pushm <m_two,BX> ; and push
C_call set_src_,<SI>,Load_ES
restore <SI>
jmp sch_err
car_cdr endp
prog ends
end


18
schars.h Normal file
View File

@ -0,0 +1,18 @@
/************************************************************************/
/* Scheme Special Character Declarations */
/* */
/* Copyright 1985 by Texas Instruments Incorporated. */
/* All Rights Reserved. */
/************************************************************************/
#define test_num 8 /* the number of "special" characters */
/* Text Representations for Special Characters */
static char *test_string[test_num] = {"NEWLINE", "SPACE", "RUBOUT",
"PAGE", "TAB", "BACKSPACE",
"RETURN", "ESCAPE"};
/* Values for Special Characters */
static char test_char[test_num] = {'\n', ' ', '\177',
'\f', '\t', '\b',
'\r', '\033'};


5
scheme.equ Normal file
View File

@ -0,0 +1,5 @@
include schemed.equ
include schemed.ref
include schemed.mac
include smmu.mac


4
scheme.h Normal file
View File

@ -0,0 +1,4 @@
/* =====> SCHEME.H */
#include "memtype.h"
#include "schmdefs.h"


607
schemed.asm Normal file
View File

@ -0,0 +1,607 @@
; =====> SCHEMED.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* (C) Copyright 1984,1985,1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: April 1984 *
;* Last Modification: 10 Feb 1987 *
;***************************************
include schemed.equ
include screen.equ
; Modification History:
; 26 Feb 86 - Modified the initial value of the global variable "listpage"
; (JCJ) so that it points to page zero (0) instead of END_LIST. This
; causes it to always point to a valid page, thus eliminating
; one check for each CONS operation.
; rb 5/22/86 - changed debug flag in R2 used as VM starts up;
; if none, R2=0 (nil), else R2=Scheme 0 (i.e. tagged fixnum zero)
; tc 2/10/87 - Changed page 5 special symbols to for #T instead of #!TRUE
; for the R^3 Report.
;************************************************************************
;* Segment Alignment Macro *
;* *
;* Purpose: This macro causes "define bytes" to be inserted in the *
;* current data section to force the data item which *
;* follows it to be aligned on a paragraph boundary. *
;* *
;* Note: For this macro to work, the current data segment must be *
;* aligned on a paragraph boundary. This is accomplished *
;* through the "para" option of the "segment" assembler *
;* directive, e.g., *
;* *
;* data segment para public 'DATA' *
;* *
;************************************************************************
align macro
AL_TMP = $ - AL_start ; get current location
AL_TMP = AL_TMP MOD 16 ; isolate low order 4 bits
AL_TMP = 16 - AL_TMP ; determine "correction"
AL_TMP = AL_TMP MOD 16 ; adjust if already aligned
IF AL_TMP
db AL_TMP dup (0)
ENDIF
endm
DGROUP group data
data segment para public 'DATA'
assume DS:DGROUP
AL_start equ $ ; Start of data segment for align macro
;;; Page Table - This area of memory holds the table of base
;;; (paragraph) addresses for each of the page
;;; frames in Scheme's memory system.
public pagetabl
pagetabl label word
dw page0 ; page 0 - 'nil or cdr nil
dw 0 ; page 1 - characters (immediates)
dw 0 ; page 2 - forwarded pointer
dw 0 ; page 3 - 15-bit fixnums (immediates)
dw page4 ; page 4 - special 32-bit flonums
dw page5 ; page 5 - special symbols
dw page6 ; page 6 - standard port page
dw page7 ; page 7 - code for test programs
dw page8 ; page 8 - initial environments
; remainder of page table
dw NUMPAGES-PreAlloc dup (0)
; Page Attribute Table - The bits in the following table are
; used to indicate the state of each of the pages
; in the Scheme memory system. Only one kind of data
; object can be stored in a given page, so a single bit
; can be used to classify all references to a page.
public attrib,w_attrib
w_attrib equ $ ; Special redefinition for C to use as int
attrib dw ATOM+READONLY ; page 0 - 'nil
dw ATOM+CHARS+READONLY+NOMEMORY
dw NOMEMORY
dw ATOM+FIXNUMS+READONLY+NOMEMORY
dw ATOM+FLONUMS+READONLY
dw ATOM+SYMBOLS+READONLY
dw ATOM+PORTS+READONLY
dw ATOM+CODE
dw ATOM ; Initial Environments
dw NUMPAGES-9 dup (NOMEMORY)
; Next available location table - The following table contains
; the offsets of the next available location which
; may be allocated in each page. A negative value
; indicates that the page is full and that no further
; allocation is possible within a page.
public nextcell
nextcell dw 8 dup (END_LIST)
dw env_nxt-page8 ; Environments page
dw NUMPAGES-9 dup (END_LIST)
; Page link table - Pages which contain data objects of the same
; type are linked together via the following table.
public pagelink
pagelink dw NUMPAGES dup (END_LIST)
; Page type table - This table holds the "type" of each page for
; pointer classification purposes. The values in
; this table may be used as indicies into branch
; tables.
public ptype
ptype dw LISTTYPE*2 ; Page 0 contains list cells
dw CHARTYPE*2 ; Page 1 is for character immediates
dw FREETYPE*2 ; Page 2 is for "forwarded pointers"
dw FIXTYPE*2 ; Page 3 is for fixnum immediates
dw FLOTYPE*2 ; Page 4 contains pre-defined flonums
dw SYMTYPE*2 ; Page 5 contains pre-defined symbols
dw PORTTYPE*2 ; Page 6 contains standard I/O ports
dw CODETYPE*2 ; Page 7 contains test programs
dw ENVTYPE*2 ; Page 8 contains environments
dw NUMPAGES-9 dup (FREETYPE*2) ; Rest of pages not pre-allocated
public psize
psize dw page0_end-page0 ; Page 0 contains special list cells
dw 0 ; Page 1 is a tag for immediate characters
dw 0 ; Page 2 reserved for "forwarded pointers"
dw 0 ; Page 3 is a tag used for immediate fixnums
dw page4_end-page4 ; Page 4 contains pre-defined flonums
dw page5_end-page5 ; Page 5 contains pre-defined symbols
dw page6_end-page6 ; Page 6 contains standard I/O ports
dw page7_end-page7 ; Page 7 contains test programs
dw page8_end-page8 ; Page 8 contains environments
dw NUMPAGES-9 dup (MIN_PAGESIZE) ; Initialize default page size
; Table of pages for allocation by type
public pagelist,listpage,fixpage,flopage,bigpage,sympage,strpage
public vectpage,contpage,clospage,freepage,codepage,refpage,portpage
public envpage
pagelist equ $
listpage dw 0 ; [0] Page number for list cell allocation
fixpage dw END_LIST ; [1] Page number for fixnum allocation
flopage dw END_LIST ; [2] Page number for flonum allocation
bigpage dw END_LIST ; [3] Page number for bignum allocation
sympage dw END_LIST ; [4] Page number for symbol allocation
strpage dw END_LIST ; [5] Page number for string allocation
vectpage dw END_LIST ; [6] Page number for vector allocation
contpage dw END_LIST ; [7] Page number for continuation allocation
clospage dw END_LIST ; [8] Page number for closure allocation
freepage dw END_LIST ; [9] Free page list header
codepage dw END_LIST ; [10] Page number for code block allocation
refpage dw END_LIST ; [11] Page number for ref cell allocation
portpage dw END_LIST ; [12] Page number for port allocation
charpage dw END_LIST ; [13] Page number for characters
envpage dw ENV_PAGE ; [14] Page for environments
; Table of page attributes by data object type
public pageattr
pageattr dw LISTCELL ; [0] List cell attributes
dw ATOM+FIXNUMS ; [1] Fixnum attributes
dw ATOM+FLONUMS ; [2] Flonum attributes
dw ATOM+BIGNUMS ; [3] Bignum attributes
dw ATOM+SYMBOLS ; [4] Symbol attributes
dw ATOM+STRINGS ; [5] String attributes
dw ATOM+VECTORS ; [6] Vector (array) attributes
dw ATOM+CONTINU ; [7] Continuation attributes
dw ATOM+CLOSURE ; [8] Closure attributes
dw 0 ; [9] Free page has no attributes
dw ATOM+CODE ; [10] Code block attributes
dw ATOM+REFS ; [11] Ref cell attributes
dw ATOM+PORTS ; [12] Port attributes
dw ATOM+CHARS ; [13] Character attributes
dw ATOM ; [14] Environment attributes
public nextpage,lastpage,nextpara,PAGESIZE
nextpage dw 9 ; Next unused page number
lastpage dw 9 ; Will hold last page # for ext memory
nextpara dw 0 ; Next available paragraph number
PAGESIZE dw MIN_PAGESIZE
; Table of bit settings to "or" in
public bitable
bitable dw 08000H,04000H,02000H,01000H,00800H,00400H,00200H,00100H
dw 00080H,00040H,00020H,00010H,00008H,00004H,00002H,00001H
public rtn_name
rtn_name db "You didn't use the ENTER macro!",0
; "Registers" for the Scheme Virtual Machine
public nil_reg,regs,reg0,reg0_pag,reg0_dis
nil_reg dw NIL_DISP
dw NIL_PAGE*2
regs equ $
reg0 equ $ ; Virtual register 0 - always nil
reg0_dis dw NIL_DISP
reg0_pag dw NIL_PAGE*2
public reg1,reg1_pag,reg1_dis
reg1 equ $ ; Virtual register 1
reg1_dis dw UN_DISP
reg1_pag dw UN_PAGE*2
rept NUM_REGS-2 ; define the VM's remaining registers
dw UN_DISP,UN_PAGE*2
endm
public FNV_reg,FNV_pag,FNV_dis
FNV_reg equ $ ; Fluid Environment Pointer
FNV_dis dw NIL_DISP
FNV_pag dw NIL_PAGE*2
public GNV_reg,GNV_pag,GNV_dis
GNV_reg equ $ ; Global Environment Pointer
GNV_dis dw g_env-page8
GNV_pag dw ENV_PAGE*2
public CB_reg,CB_pag,CB_dis
CB_reg equ $ ; Code Base Pointer
CB_dis dw 0
CB_pag dw 14
public tmp_reg,tmp_page,tmp_disp ; GC'ed temporary register
tmp_reg equ $
tmp_disp dw NIL_DISP
tmp_page dw NIL_PAGE*2
public tm2_reg,tm2_page,tm2_disp ; GC'ed temporary register
tm2_reg equ $
tm2_disp dw NIL_DISP
tm2_page dw NIL_PAGE*2
public tmp_adr,tm2_adr ; addresses of temporary registers
tmp_adr dw tmp_reg
tm2_adr dw tm2_reg
; Transcript File pointer
public TRNS_reg,TRNS_pag,TRNS_dis
TRNS_reg equ $
TRNS_dis dw NIL_DISP
TRNS_pag dw NIL_PAGE*2
; Storage for interned symbol 'quote
public QUOTE_PA,QUOTE_DI
QUOTE_DI dw NIL_DISP
QUOTE_PA dw NIL_PAGE*2
public CONSOLE_,CON_PAGE,CON_DISP ; 'console interned symbol
CONSOLE_ equ $
CON_DISP dw NIL_DISP
CON_PAGE dw NIL_PAGE*2
public S_pc
S_pc dw entry - page7
; Storage for oblist hash table
public hash_pag,hash_dis
hash_pag db HT_SIZE dup (0)
hash_dis dw HT_SIZE dup (0)
; Storage for property list hash table
public prop_pag,prop_dis
prop_pag db HT_SIZE dup (0)
prop_dis dw HT_SIZE dup (0)
; Storage for object hash table
public obj_ht
obj_ht db OHT_SIZE*3 dup (0)
; Stack storage (stack buffer)
public S_stack
S_stack db NIL_PAGE*2 ; caller's code base pointer
dw NIL_DISP
db SPECFIX*2 ; return address displacement
dw 0
db SPECFIX*2 ; caller's FP
dw 0
db ENV_PAGE*2 ; current heap environment
dw g_env-page8
db SPECFIX*2 ; static link
dw 0
db NIL_PAGE*2 ; closure pointer ('nil means open call)
dw NIL_DISP
STK_HEAD equ $-S_stack
db STKSIZE-STK_HEAD dup (0)
public TOS,FP,BASE,PREV_reg,PREV_pag,PREV_dis
TOS dw STK_HEAD-PTRSIZE ; current top-of-stack pointer
FP dw 0 ; current stack frame pointer
BASE dw 0 ; stack buffer base
PREV_reg equ $ ; pointer to previous stack segment
PREV_dis dw NIL_DISP
PREV_pag dw NIL_PAGE*2
; State variables for (reset) and (scheme-reset)
public FP_save,FNV_save,STL_save,RST_ent,ERR_ent
FP_save dw 0 ; save area for nominal stack
FNV_save dw NIL_DISP,NIL_PAGE*2 ; fluid enviornment pointer save area
STL_save dw NIL_DISP,NIL_PAGE*2 ; scheme-top-level value save area
RST_ent dw reset_x - page7 ; entry point for reset code
ERR_ent dw err_rtn - page7 ; entry point for error handler invocation
; Flags for VM Control
public PC_MAKE,VM_debug,s_break
PC_MAKE dw 1 ; PC's manufacturer flag
VM_debug dw 0 ; flag indicating VM_debug mode
s_break dw 0 ; flag indicating shift-break key depressed
; Current port
public iooffs,ioseg
iooffs dw 0
ioseg dw 0
; Stack pointer for abort
public abadr
abadr dw 0
; Special storage for nil
align
public page0
page0 db NIL_PAGE*2 ; Special constant: (cons nil nil)
dw NIL_DISP
db NIL_PAGE*2
dw NIL_DISP
page0_end equ $ ; end of Page 0
; Special 32-bit floating point constants area
align
public page4
page4 db FLOTYPE,00,00,00,00,00,00,0F0H,0BFH ;-1.0
db FLOTYPE,00,00,00,00,00,00,00,00 ; 0.0
db FLOTYPE,00,00,00,00,00,00,0F0H,03FH ; 1.0
page4_end equ $ ; end of Page 4
; Define symbol constant
symbol MACRO str
local x,y
x db SYMTYPE ; tag
dw y-x ; length field
db NIL_PAGE*2 ; link field page number - initially null
dw NIL_DISP ; link field displacement - initially null
db 0 ; hash key - 0 for "special symbols"
db str ; character data
y equ $
endm
; Special storage for single character symbols
align
public page5
page5 equ $
t_symbol equ $
symbol "#T" ; #T for #!true for 't for true
symbol "#!UNASSIGNED" ; the proverbial undefined value
symbol "#!NOT-A-NUMBER" ; undefined result of arithmetic
eof_sym equ $
symbol "#!EOF" ; end-of-file indicator
non_prt equ $
symbol "#!UNPRINTABLE" ; value of *the-non-printing-object*
page5_end equ $ ; end of Page 5
align
public page6
page6 equ $
BUFFSIZE equ 256 ; buffer size
; Standard Input Port (for now, a file)
stdinp db PORTTYPE ; tag=PORT
dw stdinp_-stdinp ; length of object in bytes
db 0,0,0 ; null pointer
dw 03Eh ; flags (r/w,window,open,transcript,binary)
dw 0 ; handle (stdin CON)
dw 0 ; cursor line
dw 0 ; cursor column
dw 0 ; upper left line
dw 0 ; upper left column
dw DEFAULT_NUM_ROWS ; number of lines
dw DEFAULT_NUM_COLS ; number of columns
dw -1 ; border attributes (none)
dw 000FH ; text attributes (white, enable)
dw 1 ; window flags (wrap)
dw 0 ; current buffer position
dw 0 ; current end of buffer
db BUFFSIZE dup (0) ; input buffer
db "CON" ; pathname
stdinp_ equ $
; The following point object is now used for the pcs-status-window
stdoutp db PORTTYPE ; tag=PORT
dw stdoutp_-stdoutp ; length of object in bytes
db 0,0,0 ; null pointer
dw 02Eh ; flags (r/w,window,open,no transcript,bin)
dw 1 ; handle (stdout CON)
dw 0 ; cursor line
dw 0 ; cursor column
dw DEFAULT_NUM_ROWS - 1 ; upper left line
dw 0 ; upper left column
dw 1 ; number of lines
dw DEFAULT_NUM_COLS ; number of columns
dw -1 ; border attributes (none)
dw 001CH ; text attrs (reverse video, green, enable)
dw 1 ; window flags (wrap)
dw 0 ; current buffer position
dw 0 ; current end of buffer
db BUFFSIZE dup (0) ; output buffer
db "CON" ; pathname
stdoutp_ equ $
page6_end equ $ ; end of Page 6
fxn MACRO val
db SPECFIX*2
dw val
endm
; Environments
align
public page8
ENV_PAGE equ 8
page8 equ $
; define USER-GLOBAL-ENVIRONMENT
g_env db ENVTYPE
dw (HT_SIZE*3)+BLK_OVHD+PTRSIZE
db 0,0,0 ; parent pointer (there is no parent)
db HT_SIZE*3 dup (0)
; define USER-INITIAL-ENVIRONMENT
u_env db ENVTYPE
dw (HT_SIZE*3)+BLK_OVHD+PTRSIZE
db ENV_PAGE*2
dw g_env-page8
db HT_SIZE*3 dup (0)
env_nxt equ $
;;; dw MIN_PAGESIZE-(env_nxt-page8)
;;; db MIN_PAGESIZE-($-page8) dup (0)
page8_siz equ (env_nxt-page8)+(1*ENV_SIZE) ;allow room for 1 environment
db FREETYPE
dw page8_siz-(env_nxt-page8)
db page8_siz-($-page8) dup (0)
page8_end equ $
; Assembly area for test programs
include sasm.mac
align
public page7
page7 equ $
db CODETYPE ; Block header
dw firstend-page7
db SPECFIX*2 ; Code starting offset
dw entry-page7
; Constant (pointers) go here
cstart equ *
CSTL equ 0
db 0,0,0 ; "scheme-top-level" symbol goes here
CREAD equ 1
db 0,0,0 ; "read" symbol goes here
CEOF equ 2
db 0,0,0 ; interned "eof" symbol goes here
CINP equ 3
db 0,0,0 ; interned "input-port" symbol goes here
COUTP equ 4
db 0,0,0 ; interned "output-port" symbol goes here
CCONS equ 5
db 0,0,0 ; interned "console" symbol goes here
CNO_PRT equ 6
db 0,0,0 ; interned "*the-non-printing-object*" sym
CUGENV equ 7
db 0,0,0 ; interned "user-global-environment" sym
CUIENV equ 8
db 0,0,0 ; interned "user-initial-environment" sym
ERR_NAME equ 9
db 0,0,0 ; interned "*error-handler*" symbol
CWHO equ 10
db 0,0,0 ; interned "pcs-status-window"
T_ equ 11
db 0,0,0 ; interned "t"
NIL_ equ 12
db 0,0,0 ; interned "nil"
ENGINE_ equ 13
db 0,0,0 ; interned "PCS-KILL-ENGINE"
CEOFX equ 14
db SPECSYM*2 ; special non-interned "eof" symbol
dw eof_sym-page5
CNO_PRTX equ 15
db SPECSYM*2 ; special non-interned "#!unprintable" sym
dw non_prt-page5
CUGENVX equ 16
db ENV_PAGE*2 ; pointer to user-global-environment
dw g_env-page8
CUIENVX equ 17
db ENV_PAGE*2 ; pointer to user-initial-environment
dw u_env-page8
CWHOX equ 18
db SPECPOR*2 ; pointer to "who-line" window object
dw stdoutp-page6
CT_ equ 19
db SPECSYM*2 ; pointer to #!true
dw t_symbol-page5
; Entry point follows
entry equ $
; STRINGP_ R2 ; second input argument specified?
JNIL_S_ R2,no_debug ; if not, don't begin debug (jump)
DEBUG_ ; initiate debug mode
no_debug equ $
; define "eof"
LD_CON_ R63,CEOFX
DEFINE_ R63,CEOF
; define "*the-non-printing-object*" to "#!unprintable"
LD_CON_ R63,CNO_PRTX
DEFINE_ R63,CNO_PRT
; define "user-global-environment" to point to said
LD_CON_ R63,CUGENVX
DEFINE_ R63,CUGENV
; define "user-initial-environment" to point to said
LD_CON_ R63,CUIENVX
DEFINE_ R63,CUIENV
; define "who-line"
LD_CON_ R63,CWHOX
DEFINE_ R63,CWHO
; (define t #!true)
LD_CON_ R63,CT_
DEFINE_ R63,T_
; (define nil '())
DEFINE_ R0,NIL_
; fluid-bind "input-port", "output-port" to 'console
LD_CON_ R63,CCONS
BIND_FL_ CINP,R63
BIND_FL_ COUTP,R63
; fluid-bind "scheme-top-level" to nil
BIND_FL_ CSTL,R0
; establish the default error handler
LD_CON_ R63,ERR_NAME
CLOSE_ R63,err_dflt,0
DEFINE_ R63,ERR_NAME
; establish the default PCS-KILL-ENGINE
LD_CON_ R63,ENGINE_
CLOSE_ R63,ret_dflt,0
DEFINE_ R63,ENGINE_
; check the input parameter to see if it's a filename
FASL_ R1 ; fast load first program unit
next_rd equ $
COPY_ R8,R0
FASL_ R8
LD_CON_ R9,CEOFX
JEQ_S_ R9,R8,end_rd
PUSH_ R8 ; save program just read
EXECUTE_ R1 ; execute the previously read program
POP_ R1 ; restore pointer to most recently read pgm
JMP_S_ next_rd ; see if more procedures follow
end_rd equ $
EXECUTE_ R1 ; Load program-Create the closure
COPY_ R2,R1 ; Copy returned value to R2
SYMBOLP_ R2 ; Was a symbol returned?
JNIL_S_ R2,not_sym ; If not, don't try to look it up
COPY_ R2,R1
FLUID_P_ R2
JNIL_S_ R2,glob_sym
LD_FL_R_ R1,R1
JMP_S_ not_sym
glob_sym equ $
LD_GL_R_ R1,R1 ; Look up symbol in global environment
not_sym equ $
COPY_ R2,R1
CLOSURP_ R2
JNIL_S_ R2,not_clos
CALL_CL_ R1,0 ; Execute the closure
not_clos equ $
LD_NIL_ R2
PRINT_ R1,R2 ; Print the result (if any)
HALT_
; Reset Code
S_RESET_ ; debugger entry for forced reset
reset_x equ $
LD_GLOBAL_ R1,ENGINE_ ; call PCS-KILL-ENGINE
CALL_CL_ R1,0
CLR_REG_ ; clear all registers
LD_FLUID_ R1,CSTL ; load value for 'scheme-top-level
CALL_CL_ R1,0 ; call said closure
JMP_S_ reset_x ; if control returns, reset again
; Error Handler Invocation
err_rtn equ $
reg_ctr = R1
rept NUM_REGS-1
PUSH_ reg_ctr
reg_ctr = reg_ctr+4
endm
LD_GLOBAL_ R1,err_name
CALL_CL_ R1,0
reg_ctr = (NUM_REGS-1)*4
rept NUM_REGS-1
POP_ reg_ctr
reg_ctr = reg_ctr-4
endm
EXIT_
err_dflt equ $
DEBUG_
ret_dflt equ $
EXIT_
firstend equ $ ; end of first code block
page7_end equ $
data ends
end


539
schemed.equ Normal file
View File

@ -0,0 +1,539 @@
; =====> SCHEMED.EQU
page 60,132
; TIPC Scheme Runtime Data Structure Equates
; Copyright 1984,1985 by Texas Instruments Incorporated.
; All Rights Reserved.
;
; Last Update:
;
; tc 10 Feb 1987 - Modified Page 5 special symbols to reflect #T
; per the R^3 Report.
include memtype.equ
; The following equates set the limits on the virtual memory (paging)
; system:
NUMPAGES equ 128 ; Total number of pages
DEDPAGES equ 8 ; Number of dedicated pages
PreAlloc equ DEDPAGES+1 ; Pre-allocated pages
PAGEINCR equ 2
PAGEMASK equ 000FEH
PTRMASK equ MIN_PAGESIZE-1
WORDSIZE equ 16 ; The computer's word size (16 bits/word)
WORDINCR equ 2 ; The number of address units per word
HT_SIZE equ 211 ; The oblist's hash table size
OHT_SIZE equ 17 ; The object hash table's size
STKSIZE equ 900 ; Length of Scheme's internal stack (bytes)
NUM_REGS equ 64 ; Number of general regs in the Scheme VM
SB_CHECK equ 16 ; Iteration count for shift-break checks
; Page attribute bits
ATOM equ 08000H ; 1 = Atomic data
LISTCELL equ 04000H ; 1 = List (cons) cells
FIXNUMS equ 02000H ; 1 = 16-bit integer data
FLONUMS equ 01000H ; 1 = 32-bit floating point data
BIGNUMS equ 00800H ; 1 = big integer values
SYMBOLS equ 00400H ; 1 = symbols
STRINGS equ 00200H ; 1 = strings
VECTORS equ 00100H ; 1 = vector (array) storage
NOMEMORY equ 00080H ; 1 = no memory allocated
READONLY equ 00040H ; 1 = memory is read only (constant)
CONTINU equ 00020H ; 1 = continuation object
CLOSURE equ 00010H ; 1 = closure object
REFS equ 00008H ; 1 = ref cells
PORTS equ 00004H ; 1 = I/O ports
CODE equ 00002H ; 1 = code block
CHARS equ 00001H ; 1 = characters
NUMBERS equ FIXNUMS+FLONUMS+BIGNUMS ; number (fixnums, flonums, bignums)
; Data type equates (classes of data objects)
NUMTYPES equ 15 ; Number of data types
LISTTYPE equ 0
FIXTYPE equ 1
FLOTYPE equ 2
BIGTYPE equ 3
SYMTYPE equ 4
STRTYPE equ 5
VECTTYPE equ 6
CONTTYPE equ 7
CLOSTYPE equ 8
FREETYPE equ 9
CODETYPE equ 10
REFTYPE equ 11
PORTTYPE equ 12
CHARTYPE equ 13
ENVTYPE equ 14
; Data type lengths for fixed length objects
BLK_OVHD equ 3 ; size of a block header
PTRSIZE equ 3 ; size of a Scheme pointer (3 bytes)
FLOSIZE equ 9
; Special pre-allocated pages
SPECCHAR equ 1
SPECFIX equ 3
SPECFLO equ 4
SPECSYM equ 5
SPECPOR equ 6
SPECCODE equ 7
; Predefined constants
T_PAGE equ SPECSYM ; symbol 't' (representing true)
T_DISP equ 0000H
UN_PAGE equ SPECSYM ; symbol '#!unassigned' (unbound variable)
UN_DISP equ 0009H
NTN_PAGE equ SPECSYM ; symbol '#!not-a-number'
NTN_DISP equ 001CH
DIV0_PAGE equ SPECSYM ; symbol for divide by 0
DIV0_DISP equ 001CH
EOF_PAGE equ SPECSYM ; symbol for '#!EOF
EOF_DISP equ 00031H
NPR_PAGE equ SPECSYM ; symbol for '#!unprintable'
NPR_DISP equ 003DH
NIL_PAGE equ 0 ; symbol 'nil' (representing itself)
NIL_DISP equ 0
IN_PAGE equ SPECPOR ; standard input port
IN_DISP equ 0
OUT_PAGE equ SPECPOR ; standard output port
OUT_DISP equ 0
WHO_PAGE equ SPECPOR ; "who-line"
WHO_DISP equ 0123H
; End of linked list indicator
END_LIST equ 07FFFH
; Garbage Collector "marked" bit
GC_BIT equ 080H
NOT_GC_BI equ 07FH
; Special Characters
CR equ 0DH ; ASCII Carriage Return
LF equ 0AH ; ASCII Line Feed
; Numeric operator sub-opcodes
ADD_OP equ 0 ; add
SUB_OP equ 1 ; subtract
MUL_OP equ 2 ; multiply
DIV_OP equ 3 ; divide
MOD_OP equ 4 ; modulo
AND_OP equ 5 ; bitwise-and
OR_OP equ 6 ; bitwise-or
MINUS_OP equ 7 ; minus
EQ_OP equ 8 ; = (equal comparison)
NE_OP equ 9 ; <> (not equal comparison)
LT_OP equ 10 ; < (less than comparison)
GT_OP equ 11 ; > (greater than comparison)
LE_OP equ 12 ; <= (less than or equal comparison)
GE_OP equ 13 ; >= (greater than or equal comparison)
ABS_OP equ 14 ; absolute value
QUOT_OP equ 15 ; quotient (integer division)
ZERO_OP equ 21 ; zero?
POS_OP equ 22 ; positive?
NEG_OP equ 23 ; negative?
XOR_OP equ 24 ; bitwise-xor
; Numeric Error Codes
REF_GLOBAL_ERROR equ 1 ; reference of unbound global variable
SET_GLOBAL_ERROR equ 2 ; SET! error-- global not defined
REF_LEXICAL_ERROR equ 3 ; reference of unbound lexical variable
SET_LEXICAL_ERROR equ 4 ; SET! error-- lexical variable not defined
REF_FLUID_ERROR equ 5 ; reference of unbound fluid variable
SET_FLUID_ERROR equ 6 ; SET-FLUID! error-- fluid not bound
VECTOR_OFFSET_ERROR equ 7 ; vector index out of range
STRING_OFFSET_ERROR equ 8 ; string index out of range
SUBSTRING_RANGE_ERROR equ 9 ; invalid substring range
INVALID_OPERAND_ERROR equ 10 ; Invalid operand to VM instruction
SHIFT_BREAK_CONDITION equ 11 ; SHFT-BRK key was depressed by user
NON_PROCEDURE_ERROR equ 12 ; Attempted to call non-procedural object
TIMEOUT_CONDITION equ 13 ; Timer interrupt
WINDOW_FAULT_CONDITION equ 14 ; Attempt to do I/O to a de-exposed window
FLONUM_OVERFLOW_ERROR equ 15 ; Flonum Over/Under-flow
ZERO_DIVIDE_ERROR equ 16 ; Division by zero
NUMERIC_OPERAND_ERROR equ 17 ; non-numeric operand
APPLY_ARG_LIMIT_ERROR equ 18 ; too many arguments for APPLY to handle
VECTOR_SIZE_LIMIT_ERROR equ 19 ; attempt to allocate vector which is too big
STRING_SIZE_LIMIT_ERROR equ 20 ; attempt to allocate string which is too big
IO_ERRORS_START equ 21 ; Errors between 21 and 84 are DOS I/O errors
DOS_FATAL_ERROR equ 21 ; Generic fatal I/O error
EXTEND_START_ERROR_CODE equ 1 ; Extended error codes from INT 59h
EXTEND_END_ERROR_CODE equ 88
DISK_FULL_ERROR equ 200 ; Our own home-grown error codes
LAST_ERROR equ 200 ; Future errors should start here
; List Cell
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-------------+-+-+-----+-----------------------+
; | car page no.|0|g|0 0 0| car displacement |
; +-------------+-+-+-----+-----------------------+
; | cdr page no.|0|0 0 0 0| cdr displacement |
; +-------------+-+-------+-----------------------+
; where g = used during garbage collection
listdef struc
car_page db ? ; CAR's page number
car dw ? ; CAR's displacement
cdr_page db ? ; CDR's page number
cdr dw ? ; CDR's displacement
listdef ends
list_gc equ car+1 ; High order bit used by GC
LISTSIZE equ size listdef
; Bignum
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| type | length in bytes |
; +-+-------------+-------------------------------+
; | sign | least significant word |
; +---------------+--------------------------------
; : :
; ----------------+-------------------------------+
; | most significant word |
; ----------------+-------------------------------+
; where g = used during garbage collection
bigdef struc
big_type db BIGTYPE ; tag = bignum
big_len dw ? ; length of entire data structure in bytes
big_sign db ? ; sign of the bignum
big_data dw ? ; data bits, stored with least significant
; bits appearing first
big_2nd dw ? ; second word of significant bits
bigdef ends
big_gc equ big_type
; Flonum
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+---------------+---------------+
; |g| type | 64 bit IEEE floating |
; +-+-------------+---------------+---------------+
; | |
; +---------------+---------------+---------------+
; | |
; +---------------+---------------+---------------+
; where g = used during garbage collection
flodef struc
flo_type db FLOTYPE ; tag = flonum
flo_data db 8 dup (?) ; IEEE floating point number
flodef ends
flo_gc equ flo_type
; Vector (Array)
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-+-----------+-------------------------------+
; |g|b| type | length in bytes |
; +-+-+-----------+-------------------------------+
; | first data element, second, ...
; +------------------------------------------------
; : :
; ------------------------------------------------+
; ..., last data element |
; ------------------------------------------------+
; where g = used during garbage collection
; b = unboxed array (contains no type info)
vecdef struc
vec_type db VECTTYPE
vec_len dw ?
vec_page db ?
vec_disp dw ?
vecdef ends
vec_gc equ vec_type
vec_data equ vec_page
; Symbol
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| SYMTYPE | length in bytes |
; +-+-------------+-------------------------------+
; | link page no. | link displacement |
; +-+-------------+-------------------------------+
; | hash value | characters ...
; +---------------+-------------------------------
; : :
; ------------------------------------------------+
; where g = used during garbage collection
symdef struc
sym_type db SYMTYPE ; tag = symbol
sym_len dw ? ; length of symbol structure in bytes
sym_page db ? ; link field page number
sym_disp dw ? ; link field displacement
sym_hkey db ? ; hash key
sym_data db ? ; character(s) in symbol
symdef ends
sym_gc equ sym_type
sym_ovhd equ sym_data-sym_type ; # bytes of overhead in symbol object
; String
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| STRTYPE | length in bytes |
; +-+-------------+-------------------------------+
; | characters ...
; +---------------+---------------+----------------
; : :
; ----------------+---------------+---------------+
; where g = used during garbage collection
strdef struc
str_type db strTYPE ; tag = string
str_len dw ? ; length of string structure in bytes
str_data db ? ; character(s) in string
strdef ends
str_gc equ str_type
str_ovhd equ str_data-str_type ; # bytes of overhead in string object
; Closure
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| CLOSTYPE | length in bytes |
; +-+-------------+-------------------------------+
; | Information Operand Pointer |
; +---------------+-------------------------------+
; | heap page no. | heap environment displacement |
; +---------------+-------------------------------+
; | CB page no. | CB displacement |
; +---------------+-------------------------------+
; | SPECFIX*2 | Entry Point Displacement |
; +---------------+-------------------------------+
; | SPECFIX*2 | Number of Arguments |
; +---------------+-------------------------------+
; where g = used during garbage collection
closdef struc
clo_type db CLOSTYPE ; tag = closure
clo_len dw ? ; length of closure object in bytes
clo_ipag db ? ; information operand page number
clo_idis dw ? ; information operand displacement
clo_hpag db ? ; heap environment pointer page number
clo_hdis dw ? ; heap environment pointer displacement
clo_cb_p db ? ; code base page number
clo_cb_d dw ? ; code base displacement pointer
clo_etag db SPECFIX*2 ; entry point tag = immediate
clo_edis dw ? ; entry point displacement
clo_atag db SPECFIX*2 ; number of arguments tag = immediate
clo_narg dw ? ; number of arguments
clo_dbug db ? ; optional debugging information?
closdef ends
clo_gc equ clo_type ; garbage collection mark bit field
CLO_OVHD equ clo_dbug-clo_type ; number of bytes of overhead in a closure
; Continuation
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| CONTTYPE | length in bytes |
; +-+-------------+-------------------------------+
; | tag=fixnum | stack base of continuation |
; +---------------+-------------------------------+
; | return address code base pointer |\
; +---------------+-------------------------------+ | return address
; | tag=fixnum | return address displacement |/
; +---------------+-------------------------------+
; | tag=fixnum | caller's dynamic link (FP) |
; +---------------+-------------------------------+
; | fluid environment pointer (FNV_reg) |
; +---------------+-------------------------------+
; | previous stack segment (continuation) pointer |
; +---------------+-------------------------------+
; | global environment pointer (GNV_reg) |
; +---------------+-------------------------------+
; : :< - BASE
; : [contents of stack at call/cc] :
; : :< - TOS
; +-----------------------------------------------+
; where g = used during garbage collection
contdef struc
con_type db CONTTYPE ; tag = continuation
con_len dw ? ; length of continuation structure in bytes
con_btag db SPECFIX*2 ; stack base of continuation object
con_base dw ?
con_cb_p db ? ; return address code base pointer
con_cb_d dw ?
con_rtag db SPECFIX*2 ; return address displacement
con_ret dw ?
con_dtag db SPECFIX*2 ; caller's dynamic link
con_ddis dw ?
con_fl_p db ? ; fluid environment pointer
con_fl_d dw ?
con_spag db ? ; previous stack segment pointer
con_sdis dw ?
con_gl_p db ? ; global environment pointer
con_gl_d dw ?
con_data db ? ; contents of stack at call/cc
contdef ends
con_gc equ con_type
; Code Block
;
; +-----------------------------------------------------+
; | 2 2 2 2 1 1 1 1 1 1 1 1 1 1 |
; | 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 |
; | +-+-------------+-------------------------------+ |
; | |g| CODETYPE | length in bytes | |
; | +-+-------------+-------------------------------+ |
; | | FIXTYPE*2 | entry offset |--+
; | +---------------+-------------------------------+
; | | page | displacement |\
; | +---------------+-------------------------------+ |
; | : : : > constants
; | +---------------+-------------------------------+ | area
; | | page | displacement |/
; | +---------------+---------------+---------------+
; +->| code | code | code |\
; +---------------+---------------+---------------+ |
; : : : : > code
; +---------------+---------------+---------------+ |
; | code | code | code |/
; +---------------+---------------+---------------+
; where g = used during garbage collection
codedef struc
cod_type db CODETYPE ; tag = code block
cod_len dw ? ; length of code block in bytes
cod_etag db FIXTYPE*2 ; entry offset tag = fixnum
cod_entr dw ? ; entry offset in bytes
cod_cpag db ? ; code block constants area
cod_cdis dw ?
codedef ends
cod_gc equ cod_type ; garbage collection tag field
; Environment Data Object
;
; 2 2 2 2 1 1 1 1 1 1 1 1 1 1
; 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
; +-+-------------+-------------------------------+
; |g| type | length in bytes |
; +-+-------------+-------------------------------+
; | parent pointer |
; +---------------+-------------------------------+
; | list of symbols (linked through cdr field) |
; +---------------+-------------------------------+
; | list of values (linked through car field) |
; +---------------+-------------------------------+
; where g = used during garbage collection
envdef struc
env_tag db ENVTYPE ; tag = environment
env_len dw ? ; length in bytes
env_ppag db ? ; parent pointer page number
env_pdis dw ? ; parent pointer displacement
env_npag db ? ; list of names page number
env_ndis dw ? ; list of names displacement
env_vpag db ? ; list of values page number
env_vdis dw ? ; list of values displacement
envdef ends
ENV_SIZE equ size envdef
; Port
; +--------+--------+--------+
; 0 |tag=port| length in bytes |
; +--------+--------+--------+
; 3 | string source pointer |
; +--------+--------+--------+--------+
; 6 | port flags | handle |
; +-----------------+-----------------+
; 10 | cursor line | cursor column |
; +-----------------+-----------------+
; 14 | upper left line |upper left column|
; +-----------------+-----------------+
; 18 | number of lines |number of columns|
; +-----------------+-----------------+
; 22 |border attributes| text attributes |
; +-----------------+-----------------+
; 26 | window flags | buffer position |
; +-----------------+-----------------+
; 30 | buffer end |
; +--------+--------+--------+--------+----... -----+
; 32 | input/output buffer |
; +--------+--------+-----------------+-------...---+
; | window label/file pathname |
; +--------+--------+-----------------+---------...-+
; where g = used during garbage collection
;
; 7 6 5 4 3 2 1 0
; +-+-+-+-+-+-+---+
;port flags: | |s|b|t|o|w|mod|
; +-+-+-+-+-+-+---+
;
; mod - mode: 0=read
; 1=write
; 2=read and write
; w - window/file: 0=file
; 1=window
; o - open/closed: 0=closed
; 1=open
; t - transcript: 0=disabled
; 1=enabled
; b - binary: 0=test file/window
; 1=binary file/window
; s - string I/O: 0=file/window I/O
; 1=string I/O
;
; 7 6 5 4 3 2 1 0
; +-----+-+-+-+-+-+
;window flags: | |e|w|
; +-----+-+-+-+-+-+
;
; w - wrap/clip: 0=clip
; 1=wrap
; e - exposed: 0=exposed
; 1=(partially) covered
;
portdef struc
pt_type db PORTTYPE ; tag = port
pt_len dw ? ; length of port structure in bytes
pt_ptr db ?,?,? ; pointer to string, if any
pt_pflgs dw ? ; port flags
pt_handl dw ? ; file's handle
pt_cline dw ? ; cursor line number
pt_ccol dw ? ; cursor column number
pt_ullin dw ? ; upper left hand corner's line number
pt_ulcol dw ? ; upper left hand corner's column number
pt_nline dw ? ; number of lines
pt_ncols dw ? ; number of columns/line length
pt_bordr dw ? ; window's border attributes
pt_text dw ? ; window's text attributes
pt_wflgs dw ? ; window flags
pt_bfpos dw ? ; buffer position (offset)
pt_bfend dw ? ; end of buffer offset
pt_buffr dw ? ; input/output buffer
portdef ends
port_gc equ pt_type
pt_chunk equ pt_ullin
W_CLIP equ 00h
W_WRAP equ 01h
READ_ONLY equ 00h
WRITE_ONLY equ 01h
READWRITE equ 02h
WINDOW equ 04h
OPEN equ 08h
TRANSCRI equ 10h
BINARY equ 20h
STRIO equ 40h
DIRTY equ 80h
; The following is the format of a scheme pointer as far as
; Lattice C is concerned:
C_ptr struc
C_disp dw ?
C_page dw ?
C_ptr ends


99
schemed.mac Normal file
View File

@ -0,0 +1,99 @@
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Assembler Macros *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 19 April 1984 *
;* Last Modification: 06 January 1986 *
;***************************************
; Adjust page number prior to store into pointer
adjpage MACRO reg
sal reg,1
ENDM
; Convert page number from physical representation to logical page
corrpage MACRO reg
shr reg,1
ENDM
; Test if an object in Scheme's memory has been "marked" by
; the Garbage Collector as referenced. If the GC "marked" bit
; is set in the "field" specified, a branch is taken to "label."
markedp MACRO field,label
cmp byte ptr field,0
jl label
ENDM
; Push the page number and displacement components of a Scheme
; pointer onto the runtime stack (parameter passing mechanism)
pushptr MACRO addr
push addr.car ; push the displacement
mov AL,addr.car_page ; load the page number,
and AX,PAGEMASK ; isolate it, and
push AX ; push it on the stack
ENDM
; Pop the page number and displacement components of a Scheme
; pointer from the runtime stack and restore a memory location
; (parameter return mechanism)
popptr MACRO addr
pop AX ; Retrieve the page number and
mov addr.car_page,AL ; update pointer in Scheme's memory
pop addr.car ; Restore displacement in memory
ENDM
; Save the registers in the macro's argument (a list) in the local
; stack in the variables "save_xx", where "xx" is the register name.
save MACRO regs
irp rr,<regs>
mov [BP].save_&&rr,rr
endm
endm
; Restore the registers in the macro's argument (a list) from the local
; stack in the variables "save_xx", where "xx" is the register name.
restore MACRO regs
irp rr,<regs>
mov rr,[BP].save_&&rr
endm
endm
; Push multiple
pushm MACRO objs
irp oo,<objs>
push oo
endm
endm
; Pop multiple
popm MACRO objs
irp oo,<objs>
pop oo
endm
endm
; Call Lattice C routine: C_call rtn,<regs>
; A call is made to "rtn". If "rtn" has not been declared, an "extrn"
; declaration is generated. "<regs>", if specified is the list of
; registers which are to be saved prior to the call (see the "save"
; macro above).
C_call macro rtn,regs,esp
IFNB <regs>
irp rr,<regs>
mov [BP].save_&&rr,rr
endm
ENDIF
IFNB <esp>
mov AX,DS ; make ES point to the current
mov ES,AX ; data segment
ENDIF
IFNDEF rtn
extrn rtn:near
ENDIF
call rtn
endm


309
schmdefs.h Normal file
View File

@ -0,0 +1,309 @@
/* =====> SCHMDEFS.H */
/* TIPC Scheme Data Declarations for Lattice C */
/* Last Modification: */
/* tc 2/10/87 modified Page 5 special symbols to reflect */
/* changes for the R^3 Report. */
/* */
extern char *rtn_name;
#define ASSERT(arg) if(!(arg))asrt$(rtn_name,"arg")
#define ENTER(xyz) static char *rtn_name = "xyz"
/* Data conversion macros */
/* Adjust page number- this macro converts a logical page number to
the representation which is stored in the interpreter's registers
and pointers. "CORRPAGE" performs the reverse transformation */
#define ADJPAGE(x) ((x)<<1)
/* Correct page number- this macro converts the interpreter's encoding
of a page number into the logical page number. "ADJPAGE" performs
the reverse transformation. */
#define CORRPAGE(x) ((x)>>1)
/* Fetch value for Fixnum (immediate) from pointer */
#define get_fix(pg,ds) (((ds)<<1)>>1)
/* Fetch value for Character (immediate) from pointer */
#define get_char(pg,ds) ((ds) & 0x00ff)
/* define truth */
#define TRUE 1
#define FALSE 0
#define NULL 0 /* null pointer */
/* Position of page/displacement values in "registers" */
#define C_DISP 0
#define C_PAGE 1
/* Page Management Table Definitions */
#define NUMPAGES 128 /* maximum number of pages */
#define DEDPAGES 8 /* Number of dedicated pages */
/* MIN_PAGESIZE is defined in either regmem.h, expmem.h, or extmem.h */
#define PTRMASK MIN_PAGESIZE-1 /* mask to isolate a pointer displacement */
#define PAGEINCR 2 /* increment to get to next page */
#define PAGEMASK 0x00FE /* mask to isolate a page number */
#define WORDSIZE 16 /* computer's word size (bits/word) */
#define WORDINCR 2 /* number of address units/word */
#define HT_SIZE 211 /* the oblist's hash table size */
#define STKSIZE 900 /* the stack's length (bytes) */
#define BLK_OVHD 3 /* number of overhead bytes in a block header */
#define NUM_REGS 64 /* number of registers in the Scheme VM */
/* Data Type Equates */
#define NUMTYPES 15 /* the number of data types */
#define LISTTYPE 0
#define FIXTYPE 1
#define FLOTYPE 2
#define BIGTYPE 3
#define SYMTYPE 4
#define STRTYPE 5
#define ARYTYPE 6
#define VECTTYPE ARYTYPE
#define CONTTYPE 7
#define CLOSTYPE 8
#define FREETYPE 9
#define CODETYPE 10
#define REFTYPE 11
#define PORTTYPE 12
#define CHARTYPE 13
#define ENVTYPE 14
#define EOFERR 1 /* Codes for function ERRMSG */
#define DOTERR 2
#define QUOTERR 3
#define RPARERR 4
#define OVERERR 5
#define DIV0ERR 6
#define SHARPERR 7
#define FULLERR -1
#define PORTERR -2
#define HEAPERR -3
#define BUFSIZE 80
#define SYM_OVHD 7
#define PTRSIZE 3
#define LISTSIZE 6
#define FIXSIZE 2
#define FLOSIZE 9
#define SMALL_SIZE 1024 /* a "small" length for a block */
#define SPECCHAR 1 /* special page of characters */
#define SPECFIX 3 /* special page of fixnums */
#define SFIXLEN 0 /* length (bytes) of special fixnum page */
#define SPECFLO 4 /* special page of flonums */
#define SFLOLEN 24 /* length (bytes) of special flonum page */
#define SPECSYM 5 /* special page of symbols */
#define SSYMLEN 0x51 /* length (bytes) of special symbol page */
#define SPECSTK 6
#define SPECPOR 6 /* special page of ports */
#define SPORLEN 92 /* length (bytes) of special port page */
#define SPECCODE 7 /* code page for the bootstrap loader */
#define END_LIST 0x7FFF /* end of linked list marker */
#define NIL_PAGE 0 /* Location of "nil" */
#define NIL_DISP 0
#define T_PAGE SPECSYM /* Location of "t" (for true) */
#define T_DISP 0x0000
#define UN_PAGE SPECSYM /* Location of "#!unassigned" */
#define UN_DISP 0x0009
#define NTN_PAGE SPECSYM /* Location of "#!not-a-number" */
#define NTN_DISP 0x001C
#define OVR_PAGE SPECSYM /* Location of overflow designator */
#define OVR_DISP 0x001C /* (same as "not a number" for now) */
#define DIV0_PAGE SPECSYM /* Location of divide-by-zero designator */
#define DIV0_DISP 0x001C /* (same as "not a number" for now) */
#define IN_PAGE SPECPOR /* Location of standard input port */
#define IN_DISP 0
#define OUT_PAGE SPECPOR /* Location of standard output port */
/* #define OUT_DISP 0x011f */
#define OUT_DISP 0 /* input=output for standard console device */
#define WHO_PAGE SPECPOR /* Location of "who-line" port */
#define WHO_DISP 0x0123
#define EOF_PAGE SPECSYM /* Location of non-interned "**eof**" symbol */
#define EOF_DISP 0x0031
#define NPR_PAGE SPECSYM /* Location of "#!unprintable" */
#define NPR_DISP 0x003D
#define ADD_OP 0 /* addition */
#define SUB_OP 1 /* subtraction */
#define MUL_OP 2 /* multiplication */
#define DIV_OP 3 /* divide */
#define MOD_OP 4 /* modulo */
#define AND_OP 5 /* bitwise and */
#define OR_OP 6 /* bitwise or */
#define MINUS_OP 7 /* minus */
#define EQ_OP 8 /* equal comparison */
#define NE_OP 9 /* not equal comparison */
#define LT_OP 10 /* less than comparison */
#define GT_OP 11 /* greater than comparison */
#define LE_OP 12 /* less than or equal comparison */
#define GE_OP 13 /* greater than or equal comparison */
#define ABS_OP 14 /* absolute value */
#define QUOT_OP 15 /* quotient */
#define TRUNC_OP 16 /* truncate */
#define FLOOR_OP 17 /* floor */
#define CEIL_OP 18 /* ceiling */
#define ROUND_OP 19 /* round */
#define FLOAT_OP 20 /* float */
#define ZERO_OP 21 /* zero? */
#define POS_OP 22 /* positive? */
#define NEG_OP 23 /* negative? */
#define XOR_OP 24 /* bitwise xor */
/* Numeric Error Codes */
#define REF_GLOBAL_ERROR 1 /* reference of unbound global variable */
#define SET_GLOBAL_ERROR 2 /* SET! error-- global not defined */
#define REF_LEXICAL_ERROR 3 /* reference of unbound lexical variable */
#define SET_LEXICAL_ERROR 4 /* SET! error-- lexical variable not defined */
#define REF_FLUID_ERROR 5 /* reference of unbound fluid variable */
#define SET_FLUID_ERROR 6 /* SET-FLUID! error-- fluid not bound */
#define VECTOR_OFFSET_ERROR 7 /* vector index out of range */
#define STRING_OFFSET_ERROR 8 /* string index out of range */
#define SUBSTRING_RANGE_ERROR 9 /* invalid substring range */
#define INVALID_OPERAND_ERROR 10 /* invalid operand to VM instruction */
#define SHIFT_BREAK_CONDITION 11 /* SHFT-BRK key was depressed by user */
#define NON_PROCEDURE_ERROR 12 /* attempted to call non-procedural object */
#define TIMEOUT_CONDITION 13 /* timer interrupt */
#define WINDOW_FAULT_CONDITION 14 /* attempt to do I/O to a de-exposed window */
#define FLONUM_OVERFLOW_ERROR 15 /* flonum overflow/underflow */
#define ZERO_DIVIDE_ERROR 16 /* division by zero */
#define NUMERIC_OPERAND_ERROR 17 /* non-numeric operand */
#define APPLY_ARG_LIMIT_ERROR 18 /* too many arguments for APPLY to handle */
#define VECTOR_SIZE_LIMIT_ERROR 19 /* vector too big */
#define STRING_SIZE_LIMIT_ERROR 20 /* string too big */
#define IO_ERRORS_START 21 /* Errors from 21 and 84 are DOS I/O errors */
#define DOS_FATAL_ERROR 21 /* Generic fatal I/O error */
#define EXTEND_START_ERROR_CODE 1 /* Extended error codes from INT 59h */
#define EXTEND_END_ERROR_CODE 88
#define DISK_FULL_ERROR 200 /* Our own home-grown error codes */
#define LAST_ERROR 200 /* Future errors should start here */
/* Scheme VM Control Flags */
extern int PC_MAKE; /* variable denoting PC's manufacturer & type */
extern int VM_debug; /* VM debug mode flag */
extern int s_break; /* shift-break indicator */
extern int QUOTE_PAGE; /* Location of "quote" */
extern int QUOTE_DISP;
extern unsigned PAGESIZE;
extern unsigned pagetabl[NUMPAGES]; /* Paragraph Address (bases) */
extern struct {
unsigned atom:1;
unsigned listcell:1;
unsigned fixnums:1;
unsigned flonums:1;
unsigned bignums:1;
unsigned symbols:1;
unsigned strings:1;
unsigned arrays:1;
unsigned nomemory:1;
unsigned readonly:1;
unsigned continu:1;
unsigned closure:1;
unsigned refs:1;
unsigned ports:1;
unsigned code:1;
unsigned characters:1;
} attrib[NUMPAGES]; /* Page Attribute Bits */
extern int w_attrib[NUMPAGES]; /* Re-define attribute bits as integer */
extern int nextcell[NUMPAGES]; /* Next Available Cell Pointers */
extern int pagelink[NUMPAGES]; /* Next Page of Same Type */
extern int ptype[NUMPAGES]; /* Page Type Index */
extern unsigned psize[NUMPAGES]; /* Page Size Table */
extern int pageattr[NUMTYPES]; /* Page attribute initialization table */
extern int pagelist[NUMTYPES]; /* Page allocation table (by types) */
extern int listpage; /* Page for List Cell allocation */
extern int fixpage; /* Page for Fixnum allocation */
extern int flopage; /* Page for Flonum allocation */
extern int bigpage; /* Page for Bignum allocation */
extern int sympage; /* Page for Symbol allocation */
extern int strpage; /* Page for String allocation */
extern int arypage; /* Page for Array allocation */
extern int contpage; /* Page for Continuation allocation */
extern int clospage; /* Page for Closure allocation */
extern int freepage; /* Free page allocation list header */
extern int codepage; /* Page for Code Block allocation */
extern int refpage; /* Ref cell page allocation list header */
extern int nextpage; /* Next Page # for Allocation in Address Space */
extern int lastpage; /* Last Page # for Allocation in Address Space */
extern unsigned nextpara; /* Next Paragraph Address for Allocation */
/* Scheme's Virtual Registers */
extern long reg0, regs[NUM_REGS];
extern int nil_reg[2];
extern int reg0_page, reg0_disp, tmp_reg[2], tmp_page, tmp_disp;
extern int tm2_reg[2], tm2_page, tm2_disp;
extern int FNV_reg[2], GNV_reg[2], CB_reg[2], PREV_reg[2];
extern int FNV_pag, FNV_dis, GNV_pag, GNV_dis, CB_pag, CB_dis;
extern int PREV_pag, PREV_dis, FP, BASE;
extern int CONSOLE_[2], CON_PAGE, CON_DISP;
extern int TRNS_reg[2], TRNS_pag, TRNS_dis; /* transcript file pointer */
extern int condcode, S_pc;
/* Stack */
extern int TOS; /* top of stack pointer (displacement in bytes */
extern char S_stack[STKSIZE]; /* the stack itself */
/* Hash Table */
extern char hash_page[HT_SIZE];
extern int hash_disp[HT_SIZE];
/* Property List Hash Table */
extern char prop_page[HT_SIZE];
extern int prop_disp[HT_SIZE];
/* State Variables for (reset) and (scheme-reset) */
extern int FP_save, RST_ent;
extern int FNV_save[2];
extern int STL_save[2];
/* Port fields */
#define pt_direc 6
#define pt_lnlen 20
#define pt_csrcol 12
#define dtaoffs 32
/* Error message text strings */
extern char m_error[], m_src[], m_dest[], m_first[], m_second[], m_third[];
/* Macros Normally Found in STDIO.H */
#define abs(x) ((x)<0?-(x):(x))
#define max(a,b) ((a)>(b)?(a):(b))
#define min(a,b) ((a)<=(b)?(a):(b))
/* Scheme Function Macros */
#define alloc_sym(dest,len) alloc_block(dest,SYMTYPE,len+PTRSIZE+1)
#ifdef PROMEM
#define outchar(ch) printcha(ch)
#define outtext(str,len) printtxt(str,len)
#else
#define outchar(ch) givechar(ch)
#define outtext(str,len) printstr(str,len)
#endif
/* International Case Conversion Macros */
extern char locases[256];
extern char hicases[256];
#undef tolower
#define tolower(c) locases[(c)]
#undef toupper
#define toupper(c) hicases[(c)]
#undef islower
#define islower(c) ((c)!=hicases[(c)])
#undef isupper
#define isupper(c) ((c)!=locases[(c)])
#undef isspace
#undef isdigit
#define isdigit(c) isdig((c),10)
#undef isxdigit
#define isxdigit(c) isdig((c),16)


4
screen.equ Normal file
View File

@ -0,0 +1,4 @@
DEFAULT_NUM_ROWS equ 25
DEFAULT_VGA_ROWS equ 30
DEFAULT_NUM_COLS equ 80


114
scroll.asm Normal file
View File

@ -0,0 +1,114 @@
; =====> SCROLL.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* Window Support Routine *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: October 1985 *
;* Last Modification: *
;***************************************
include pcmake.equ
TI_CRT equ 049h
IBM_CRT equ 010h
DGROUP group DATA
DATA segment word public 'DATA'
assume DS:DGROUP
extrn PC_MAKE:word
DATA ends
XGROUP group PROGX
PROGX segment byte public 'PROGX'
assume CS:XGROUP,DS:DGROUP
extrn crt_dsr:far
;************************************************************************
;* Scroll Window Down one line *
;************************************************************************
s_args struc
dw ? ; caller's BP
dd ? ; return address
dw ?
s_line dw ? ; upper left hand corner line number
s_col dw ? ; upper left hand corner column number
s_nline dw ? ; number of lines
s_ncols dw ? ; number of columns
s_attr dw ? ; text attributes (used for blanking)
s_args ends
scroll%d proc far
push BP ; save caller's BP
mov BP,SP
; scroll window's text down one line
mov CL,byte ptr [BP].s_nline ; load number of lines
dec CL ; decrease number of lines by one
jz blank ; Jump if scrolling 1-line and just blank it
mov CH,byte ptr [BP].s_ncols ; load number of columns
mov DL,byte ptr [BP].s_line ; load upper left line number
mov DH,byte ptr [BP].s_col ; load upper left column number
mov AX,0701h ; load "scroll text" code with no blanking
cmp DGROUP:PC_MAKE,TIPC
je ti_down
push AX ; else
mov AH,0Fh
int IBM_CRT ; Are we in graphics mode?
cmp AL,4 ; If we are then fix blank fill attributes
jl text_m ; so that the bar characters don't show up
cmp AL,7
je text_m
xor BH,BH ; zero attribute for fill blanks
jmp short wrte_atr
text_m: mov BH,byte ptr [BP].s_attr ; Blanked lines' attribute txt mode
wrte_atr: pop AX
xchg CX,DX ; CX=Upper left corner
xchg CH,CL ; Row,column instead of TI's column,row
xchg DH,DL ; ditto
add DX,CX ; DX=Lower right corner
dec DL ; adjust column count (0 is first column)
int IBM_CRT
jmp short quit ; IFF IBM is in graphics mode weird char's
; are used for blanks when scrolling. Do
; as TIPC does and "manual" blank 'em.
;
ti_down: mov BX,DX ; copy destination coordinates
inc BL ; compute dest by incrementing line number
int TI_CRT ; perform the block move
; paint the first line of the window with blank of proper attributes
blank: mov DH,byte ptr [BP].s_col ; load starting column number
mov DL,byte ptr [BP].s_line ; load upper line number
mov AH,02h ; load the "put cursor" code
xor BH,BH ; IBMism
call crt_dsr ; position cursor for write
mov AX,0920h ; load "write char/attr" code, write a blank
mov BL,byte ptr [BP].s_attr ; load attribute bit setting
xor BH,BH ; IBMism
mov CX,[BP].s_ncols ; load line length
call crt_dsr ; write a line of blanks
; return to caller
quit: pop BP ; restore caller's BP
ret
scroll%d endp
PROGX ends
;****************************************************************************
;* Link routine *
;****************************************************************************
PGROUP GROUP PROG
PROG SEGMENT BYTE PUBLIC 'PROG'
assume CS:PGROUP
public scroll_d
scroll_d proc near
call scroll%d ; link to window scroll down routine
ret
scroll_d endp
PROG ends
end


1052
senv.asm Normal file
View File

File diff suppressed because it is too large Load Diff

91
sexec.asm Normal file
View File

@ -0,0 +1,91 @@
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Operation Support *
;* *
;* (C) Copyright 1984,1985,1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 19 April 1984 *
;* Last Modification: 26 February 1986*
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
new_disp dw 0
new_page dw 0
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
; CONS Support -- combine two pointers in a new list cell
con_arg struc
dw ? ; return address
con_res dw ? ; address of result register
con_car dw ? ; address of reg. containing car
con_cdr dw ? ; address of reg. containing cdr
con_arg ends
extrn alloc_li:near ; C routine to allocate a list cell
public cons
cons proc near
; Attempt a "short circuit" allocation of a list cell
mov BX,listpage ; load current list cell allocation page no.
;;; cmp BX,END_LIST ; is allocation page specified?
;;; je cons_no
shl BX,1
mov SI,nextcell+[BX] ; load next available cell offset
cmp SI,END_LIST
je cons_no
; at this point, the allocation has succeeded
mov DX,ES ; save the caller's ES register
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list cell page's segment address
mov AX,ES:[SI].car ; load pointer to next available cell
mov nextcell+[BX],AX ; and update free cell chain header
; store CDR value into list cell
cons_ok: mov CX,BP ; save the caller's base pointer
mov BP,SP ; and establish addressability for args
mov DI,[BP].con_cdr ; fetch address of register containing CDR
mov AL,byte ptr [DI].C_page ; copy contents of register into
mov ES:[SI].cdr_page,AL ; the new list cell's CDR field
mov AX,[DI].C_disp
mov ES:[SI].cdr,AX
; store CAR value into list cell
mov DI,[BP].con_car ; fetch address of register containing CAR
mov AL,byte ptr [DI].C_page ; copy contents of register into
mov ES:[SI].car_page,AL ; the new list cell's CAR field
mov AX,[DI].C_disp
mov ES:[SI].car,AX
; store pointer to new list cell in destination register
mov DI,[BP].con_res ; fetch address of destination register
mov byte ptr [DI].C_page,BL
mov [DI].C_disp,SI
mov ES,DX ; restore caller's ES register
mov BP,CX ; restore caller's BP register
ret ; return to caller
; OOPS-- no list cell immediately available-- go through channels
cons_no: mov AX,offset new_disp ; push address of a dummy result
push AX ; register onto the TIPC's stack
call alloc_li ; allocate a list cell
add SP,WORDINCR ; drop argument from stack
mov BX,new_page ; fetch list cell's page number
mov SI,new_disp ; and displacement
mov DX,ES ; save the caller's ES register
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; make ES point to the new list cell
jmp cons_ok
cons endp
prog ends
end


329
sgcmark.asm Normal file
View File

@ -0,0 +1,329 @@
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Garbage Collection - Mark Phase *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: April 1984 *
;* Last Modification: 06 January 1986 *
;***************************************
include scheme.equ
arguments struc
dw ? ; Caller's BP
dw ? ; Return address
page_idx dw ? ; Page number of pointer
pointer dw ? ; Displacement of pointer
arguments ends
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
extrn _base:word ; base address of the TIPC runtime stack
sum_bt dw sum_list ; [0] List cells
dw sum_fix ; [1] Fixnums
dw sum_flo ; [2] Flonums
dw sum_big ; [3] Bignums
dw sum_sym ; [4] Symbols
dw sum_str ; [5] Strings
dw sum_ary ; [6] Arrays
dw sum_cont ; [7] Continuations
dw sum_clos ; [8] Closures
dw sum_free ; [9] Free page
dw sum_code ; [10] Code page
dw sum_free ; [11] (Formerly, Reference cells)
dw sum_port ; [12] Port data objects
dw sum_char ; [13] Characters
dw sum_env ; [14] Environments
; Branch table for pointer classification
branchtab dw gcmlist ; [0] List cells
dw gcmfix ; [1] Fixnums
dw gcmflo ; [2] Flonums
dw gcmbig ; [3] Bignums
dw gcmsym ; [4] Symbols
dw gcmstr ; [5] Strings
dw gcmary ; [6] Arrays
dw gcmcont ; [7] Continuations
dw gcmclos ; [8] Closures
dw gcmfree ; [9] Free page
dw gcmcode ; [10] Code page
dw gcmfree ; [11] (Formerly, Reference cells)
dw gcmport ; [12] Port data objects
dw gcmchar ; [13] Characters
dw gcmenv ; [14] Environments
m_oops db "[VM INTERNAL ERROR] sum_spac: infinite loop page %d",LF,0
m_format db "[VM INTERNAL ERROR] sgcmark: invalid pointer: %x:%04x "
db "(unadjusted)",LF,0
m_overfl db "[VM FATAL ERROR] Stack overflow during GC",LF,0
DS_addr dw DGROUP
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
public garbage
garbage proc near
push ES
mov ES,DS_addr
C_call garbage1
pop ES
ret
garbage endp
mark proc near
; ***error-- bad pointer found-- report error***
gcmfix: ; Fixnums are immediates
gcmchar: ; Characters are immediates
gcmfree: ; Why are we collecting in a free page?
bad_ptr:
push AX
mov AX,offset m_format ; load address of format text
push DX ; save the return address
pushm <SI,BX,AX> ; push arguments to printf
C_call printf,,Load_ES ; print error message
add SP,WORDINCR*3 ; drop arguments from stack
C_call force_de ; go into debug mode
pop DX ; restore the return address
pop AX
jmp gcmret ; go on as if nothing happened
public gcmark
gcmark: pop DX ; unload return address
pop BX ; fetch page number (x 2)
mov AX,BX ; save in AX
pop SI ; fetch displacement
push DX ; save return address
push ES ; save ES
mov DX,offset pgroup:gcmarkret
jmp gcm_tr
gcmarkret:
pop ES
pop DX
jmp DX ; return
; see if pointer is to one of the "special" non-collected pages
gcm_tr: cmp BX,DEDPAGES*PAGEINCR ; check for non-gc'ed pages
jge gcm_go ; if not one of the special pages, jump
jmp DX ; return
;
gcm_go: push AX ; Preserve the page number
; load pointer offset into ES:; displacement into SI
test BX,0FF01h ; valid pointer?
jnz bad_ptr ; if so, error (jump)
LoadPage ES,BX
mov AX,BX ; Use AX to store page number
; classify pointer according to data type
mov DI,ptype+[BX] ; load data type*2
cmp DI,NUMTYPES*2 ; valid page type?
jae bad_ptr ; if not, error (jump)
jmp branchtab+[DI]
; Process symbol or port
gcmport:
gcmsym: markedp ES:[SI].sym_gc,gcmret ; already marked? if so, return (jump)
or byte ptr ES:[SI].sym_gc,GC_BIT ; mark symbol/port as seen
mov BL,ES:[SI].sym_page ; fetch pointer from symbol/port object
mov SI,ES:[SI].sym_disp
pop AX ; restore saved page number
LoadPage ES,AX ; Get Page address
jmp gcm_tr ; make a tail recursive call to gcmark
; Process List Cell-- If marked, skip rest of processing
gcmlist: markedp ES:[SI].list_gc,gcmret ; if marked, jump to return
; Call gcmark with CAR of list cell
or byte ptr ES:[SI].list_gc,GC_BIT ; "mark" as referenced
mov BL,ES:[SI].car_page ; load page number of car field
cmp BX,DEDPAGES*PAGEINCR ; check for non-gc'ed pages
jl gcmls_ok ; if one of the special pages, jump
; Test for TIPC stack overflow
push AX
mov AX,SP ; copy the current stack top pointer
sub AX,_base ; and compute number of bytes remaining
cmp AX,64 ; enough space to continue?
pop AX
jb stk_ovfl ; if not enough room, abort (jump)
; Mark expression pointed to by the car field
push SI ; save offset of list cell
push DX ; save the previous return address
mov DX,offset PGROUP:gcmls_rt ; Load the return address
mov SI,ES:[SI].car ; Load car field pointer
and SI,07FFFh ; Clear out the GC bit
jmp gcm_go ; Call gcmark recursively
gcmls_rt:
pop DX ; Restore previous return address
pop SI ; Restore offset of list cell
; Call gcmark tail recursively with CDR of list cell
gcmls_ok: mov BL,ES:[SI].cdr_page ; load the pointer contained in the
mov SI,ES:[SI].cdr ; cdr field
pop AX ; restore saved page
LoadPage ES,AX ; Get Page address
jmp gcm_tr ; call gcmark tail recursively
; TIPC stack overflow-- Abort
stk_ovfl: mov AX,offset m_overfl ; load address of error message text
push AX ; and push it as an argument to printf
C_call printf,,Load_ES ; print the error message
C_call getch ; wait for any key to be pressed
C_call exit ; return to MS-DOS
; Return to caller
gcmret: pop AX ; restore saved page
LoadPage ES,AX ; Get Page address
jmp DX ; return to caller
; Process reference to variable length data object or flonum
gcmflo:
gcmbig:
gcmstr:
or byte ptr ES:[SI].vec_gc,GC_BIT
pop AX ; restore saved page
LoadPage ES,AX ; Get Page address
jmp DX ; return
; Process Code Block
gcmcode: markedp ES:[SI].cod_gc,gcmret ; If already processed, return
or byte ptr ES:[SI].cod_gc,GC_BIT
mov CX,ES:[SI].cod_entr ; load entry point offset as counter
jmp gcmlop1
; Process Variable Length Object Containing Pointers
gcmary:
gcmclos:
gcmcont:
gcmenv:
markedp ES:[SI].vec_gc,gcmret ; If already processed, jump to return
or byte ptr ES:[SI].vec_gc,GC_BIT ; mark as referenced
mov CX,ES:[SI].vec_len
cmp CX,PTRSIZE ; test for zero length vector
jle gcmret ; if no elements, jump
; Test the size of the TIPC stack to insure room to continue
gcmlop1: push AX
mov AX,SP ; load the current stack top pointer
sub AX,_base ; and compute the number of bytes remaining
cmp AX,64 ; are there at least 64 bytes left?
pop AX
jb stk_ovfl ; if not enough room, abort (jump)
; Call gcmark with pointer in this object
push DX ; Save previous return address
mov DX,offset PGROUP:gcml_ret ; Load return address into DX
gcmloop: add SI,PTRSIZE ; Increment address for next pointer
push CX ; Save counter across calls
push SI ; Save curr offset into vector (or whatever)
mov BL,ES:[SI].car_page ; load next element pointer from array,
mov SI,ES:[SI].car ; closure, etc.
jmp gcm_tr ; call gcmark recursively
gcml_ret: pop SI ; Restore current offset
pop CX ; Restore iteration count
sub CX,PTRSIZE ; Decrement counter
cmp CX,PTRSIZE ; and test for completion
jg gcmloop ; Loop through all pointers in object
pop DX ; Restore previous return address
pop AX ; Restore saved page
LoadPage ES,AX ; Get Page address
jmp DX ; Return
mark endp
sum_args struc
dw ? ; caller's ES
dw ? ; caller's BP
dw ? ; return address
sum_vctr dw ? ; pointer to summation vector (for results)
sum_args ends
public sum_spac
sum_spac proc near
push BP ; save the caller's BP on entry
push ES ; save the caller's ES
mov BP,SP ; update BP
; initialize
mov DI,[BP].sum_vctr ; load address of result vector
xor BX,BX ; start with zero-th page
; top of loop-- look at next page
sum_loop: xor AX,AX ; clear the free space counter
cmp BX,DEDPAGES*PAGEINCR
jl sum_end
test attrib+[BX],NOMEMORY ; is page allocated?
jnz sum_end ; if not, skip it (branch)
cmp ptype+[BX],FREETYPE*2
je sum_free ; Ignore free pages [TC]
LoadPage ES,BX ; load current paragraph's base address
mov SI,ptype+[BX] ; load type of current page
jmp sum_bt+[SI] ; branch on page type
; add up unused list cells
sum_list: mov CX,LISTSIZE ; load size of list cell data object
sum_l1st: mov SI,nextcell+[BX] ; load list cell free storage chain header
sum_lnxt: cmp SI,END_LIST ; end of list?
je sum_end ; if so, we're through here
add AX,CX ; increment the free list cell counter
jo sum_oops ; if overflow, we're stuck in a loop
mov SI,ES:[SI].car ; follow free cell chain
jmp sum_lnxt ; keep following linked list
; add up unused variable length things
sum_big:
sum_sym:
sum_str:
sum_clos:
sum_cont:
sum_ary:
sum_code:
sum_port:
sum_env:
mov SI,0 ; initialize pointer into page
mov CX,psize+[BX] ; load size of current page
sub CX,PTRSIZE ; adjust size for page boundary check
sum_vnxt: cmp SI,CX ; through with this page?
ja sum_end ; if so, branch
mov DX,ES:[SI].vec_len ; load block length
cmp DX,0 ;;; check for small string
jge sum_010
mov DX,BLK_OVHD+PTRSIZE ;;; get the exact length
sum_010: cmp ES:[SI].vec_type,FREETYPE ; free block?
jne sum_used ; if so, branch around add
add AX,DX ; add in number of free bytes
sum_used: add SI,DX ; update pointer to next block in page
jmp sum_vnxt ; look at next block
sum_free: mov AX,psize+[BX] ; load size of free page
sum_fix:
sum_char:
sum_end: mov [DI],AX ; store number of free bytes (AX)
add DI,2 ; increment array index
add BX,2 ; increment page index
cmp BX,NUMPAGES*2 ; test for completion
jl sum_loop ; if more pages, jump
sum_ret: pop ES ; restore caller's ES
pop BP ; restore caller's BP
ret ; return to caller
; add up unused flonums
sum_flo: mov CX,FLOSIZE ; load size of flonum
jmp sum_l1st ; process assuming linked list allocation
sum_oops: shr BX,1
lea SI,m_oops
pushm <BX,SI>
mov AX,DS
mov ES,AX
C_call printf
C_call exit
sum_spac endp
prog ends
end


335
sgcsweep.asm Normal file
View File

@ -0,0 +1,335 @@
; =====> SGCSWEEP.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Garbage Collector - Sweep Phase *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: April 1984 *
;* Last Modification: 06 January 1986 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
m_fix_er db "[VM INTERNAL ERROR] swpage: logical page not found",LF,0
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
public gcsweep
gcsweep proc near
push BP
mov BP,SP
; Initialize similar page type chain headers
push ES ; save the caller's ES register
mov AX,DS ; set ES to point to the current
mov ES,AX ; data segment
mov AX,END_LIST ; load the end of list indicator
mov CX,NUMTYPES ; load table length
mov DI,offset pagelist ; load table address
cld ; move direction = forward
rep stosw ; initialize the pagelist table
pop ES ; restore the caller's ES
; Process all except the "special" non-garbage collected pages
; mov DX,DEDPAGES-1 ;;;; mov dx,NUMPAGES
; Increment loop index, test for completion
;gcsloop: inc DX ;;;; dec dx
; cmp DX,NUMPAGES ;;;; cmp dx,DEDPAGES-1
; jl gcsl010 ;;;; ja gcsl010
mov DX,NUMPAGES
gcsloop: dec DX
cmp DX,DEDPAGES-1
ja gcsl010
pop BP
ret
gcsl010: push DX
call swpage ; "sweep" the page (GC it)
pop DX
mov BX,DX ; copy current page number
sal BX,1 ; double for use as index
test attrib+[BX],NOMEMORY ; is page frame allocated?
jnz gcsloop ; if not, skip list update
mov AX,DX ; copy current page number
mov SI,ptype+[BX] ; move current page's type to SI
xchg pagelist+[SI],AX ; pagelist[type] <- page
mov pagelink+[BX],AX ; pagelink[page] <- old pagelist[type]
jmp short gcsloop
gcsweep endp
arguments struc
page_len dw ? ; page boundary (length - fudge factor)
args_BP dw ? ; Caller's BP
dw ? ; Return address
page_no dw ?
arguments ends
; Test the current page to see if it's been allocated
public swpage
swpage proc near
push BP
sub SP,offset args_BP ; reserve local storage
mov BP,SP
push ES ; save caller's ES
mov BX,[BP].page_no
sal BX,1 ; double page number for index
test DGROUP:attrib+[BX],NOMEMORY ; allocated?
jz swp020 ; if not allocated, loop
swpfix: ; Fixnums are handled as immediates
swpchar: ; Characters are handled as immediates
swpfree: ; Why are we processing a free page?
swpref: ; Ref cells no longer exist?
swpret: pop ES
add SP,offset args_BP ; drop local storage from stack
pop BP
ret
swp020:
; Dispatch on the type of data stored in this page
mov DI,DGROUP:ptype+[BX] ; load data type for this page
cmp DI,FREETYPE*2 ; Ignore free pages [HS]
jz swpfree ; to relieve the swapper... [HS]
LoadPage ES,BX ; define base paragraph for this page[HS]
mov DI,CS:btable+[DI]
jmp DI
; Process List Cells (and other fixed length pointer objects)
swplist: mov AX,LISTSIZE
swpl010: xor SI,SI ; SI <- 0
xor DI,DI ; zero referenced cell counter
mov CX,END_LIST ; load end of list marker
mov DX,-1 ; marker for unused cell header
push BX ; save page number index
mov BX,psize+[BX] ; load page length and
sub BX,AX ; adjust for boundary check
swpl020: markedp ES:[SI].list_gc,swpl030 ; branch, if marked
; add cell to free list
mov ES:[SI].car,CX
mov ES:[SI].car_page,DL ; make page=FF for unused cell
mov CX,SI
jmp short swpl040
; clear GC bit
swpl030: and byte ptr ES:[SI].list_gc,NOT_GC_BI ; clear GC "marked" bit
inc DI ; increment referenced cell counter
; increment cell pointer and test for end of page
swpl040: add SI,AX
cmp SI,BX ; test for end of page
jbe swpl020
; end of page-- update free list header and process next page
pop BX ; restore page table index
mov DGROUP:nextcell+[BX],CX
cmp DI,0 ; any referenced cells in this page?
jne swpret ; if ref'd cells in page, branch
mov ptype+[BX],FREETYPE*2 ; mark empty page as free
mov attrib+[BX],0
jmp short swpret
; Process Page of Flonums
swpflo: mov AX,FLOSIZE ; load size of a single flonum
xor SI,SI ; SI <- 0
xor DI,DI ; zero referenced cell counter
mov CX,END_LIST ; load end of list marker
mov DX,-1 ; marker for unused cell header
push BX ; save page number index
mov BX,psize+[BX] ; load page length and
sub BX,AX ; adjust for boundary check
swpf020: cmp ES:[SI].flo_type,DL ; tag = free?
je swpf025 ; if a non-allocated cell, jump
markedp ES:[SI].flo_gc,swpf030 ; branch, if marked
; add flonum to free list
mov ES:[SI].car_page,DL ; make page=FF for unused cell
swpf025: mov ES:[SI].car,CX
mov CX,SI
jmp short swpf040
; clear GC bit
swpf030: and byte ptr ES:[SI].flo_gc,NOT_GC_BI ; clear GC "marked" bit
inc DI ; increment referenced cell counter
; increment cell pointer and test for end of page
swpf040: add SI,AX
cmp SI,BX ; test for end of page
jbe swpf020
; end of page-- update free list header and process next page
pop BX ; restore page table index
mov DGROUP:nextcell+[BX],CX
cmp DI,0 ; any referenced cells in this page?
jne swpf050 ; if ref'd cells in page, branch
mov ptype+[BX],FREETYPE*2 ; mark empty page as free
mov attrib+[BX],0
swpf050: jmp swpret
; Process variable length data object
swpbig:
swpsym:
swpstr:
swpary:
swpclos:
swpcont:
swpcode:
swpenv:
xor SI,SI
mov DI,-1
push BX ; save page table index
mov BX,psize+[BX] ; load size of current page and
sub BX,PTRSIZE ; adjust for boundary check
swpvloop: mov DX,ES:[SI].vec_len ; load length of current object
cmp DX,0
jge swp001
mov DX,BLK_OVHD+PTRSIZE
swp001: markedp ES:[SI].vec_gc,swpv020 ; branch if object referenced
; Object not referenced-- can we combine with previous free area?
cmp DI,0
jge swpv010 ; If prev obj free, branch
; Object not referenced, but previous area was
mov ES:[SI].vec_type,FREETYPE ; Mark this object as free
cmp ES:[SI].vec_len,0
jge swp002
mov ES:[SI].vec_len,BLK_OVHD+PTRSIZE
swp002: mov DI,SI ; Record this fact for next iteration
jmp short swpvnxt
; Object was not referenced and can be combined with prev free area
swpv010: add ES:[DI].vec_len,DX ; add length into previous free obj
jmp short swpvnxt
; Object was referenced
swpv020: and ES:[SI].vec_gc,NOT_GC_BI ; clear gc bit
mov DI,-1 ; Remember last object was referenced
; Processing of current object finished-- add length and iterate
swpvnxt: add SI,DX ; Increment area pointer by block length
cmp SI,BX ; Last object in block?
jb swpvloop ; Branch, if more space
; Processing of this page finished-- update next free area pointer
swppfin: pop BX ; Restore page table index
cmp DI,-1
je swpv030 ; If last block not free, skip it
sub SI,psize+[BX] ; Adjust in case last byte of page
neg SI ; not accounted for
add ES:[DI].vec_len,SI
mov nextcell+[BX],DI ; Update free pool header
cmp DI,0 ; is page empty?
jne swpv040 ; if not, jump
mov ptype+[BX],FREETYPE*2 ; mark page as being free
mov attrib+[BX],0
mov AX,psize+[BX]
cmp AX,PAGESIZE ; is page larger than default page size?
ja fix_big ; if a "large" page, must fix memory tables
jmp swpret
swpv030: mov nextcell+[BX],END_LIST ; Indicate no free pool
swpv040: jmp swpret
; Process page of ports-- close any open files before salvaging memory
swpport:
xor SI,SI
mov DI,-1
push BX ; save page table index
mov BX,psize+[BX] ; load size of current page and
sub BX,PTRSIZE ; adjust for boundary check
swpploop: mov DX,ES:[SI].pt_len ; load length of current object
markedp ES:[SI].port_gc,swpp020 ; branch if object referenced
cmp ES:[SI].pt_type,FREETYPE
je not_file
; Object not referenced-- is it an open file?
test ES:[SI].pt_pflgs,WINDOW+STRIO
; is this a file or a window?
jnz not_file ; if a window, don't bother with close (jump)
test ES:[SI].pt_pflgs,OPEN ; is file opened?
jz not_open ; if not open, skip close (jump)
; Close the file
push BX ; save BX across call
mov BX,ES:[SI].pt_handl ; load handle
push BX ; and push as argument
extrn zclose:near
call zclose
pop BX ; drop argument off stack
pop BX ; restore register BX
not_file:
not_open:
; Object not referenced-- can we combine with previous free area?
cmp DI,0
jge swpp010 ; If prev obj free, branch
; Object not referenced, but previous area was
mov ES:[SI].pt_type,FREETYPE ; Mark this object as free
mov DI,SI ; Record this fact for next iteration
jmp short swppnxt
; Object was not referenced and can be combined with prev free area
swpp010: add ES:[DI].pt_len,DX ; add length into previous free obj
jmp short swppnxt
; Object was referenced
swpp020: and ES:[SI].port_gc,NOT_GC_BI ; clear gc bit
mov DI,-1 ; Remember last object was referenced
; Processing of current object finished-- add length and iterate
swppnxt: add SI,DX ; Increment area pointer by block length
cmp SI,BX ; Last object in block?
jb swpploop ; Branch, if more space
jmp swppfin ; complete processing
public fix_big
; Restore memory management tables due to release of large page
fix_big label near
mov AX,PAGESIZE ; update page size of large page to
xchg AX,psize+[BX] ; the default page size
LoadPage DX,BX ; load para address of large page
IFDEF EXTMEM
and pagetabl+[BX],0FF00h
ENDIF
IFDEF PROMEM
mov CX,8 ; amount to get to next selector
ELSE
mov CX,PAGESIZE ; CX <- PAGESIZE/16
shr CX,1
shr CX,1
shr CX,1
shr CX,1
ENDIF
mov BX,PAGESIZE
fix_lop: sub AX,PAGESIZE ; decrease extended page size by one page
jbe fix_ret ; if all pages fixed, return
add DX,CX ; compute pointer to next physical page
mov SI,DEDPAGES*2 ; initialize page table index
fix_more: push BX
LoadPage BX,SI ; is this the page we're looking for?
cmp DX,BX
pop BX
je fix_fnd ; if so, jump
inc SI ; increment the page table index
inc SI ; twice
cmp SI,NUMPAGES*2 ; more pages?
jl fix_more ; if so, jump
lea BX,m_fix_er ; error-- loop should not exit
push BX
mov AX,DS ; set TIPC register ES for call to
mov ES,AX ; Lattice C routines
C_call print_an ; print error message and exit
fix_fnd: mov psize+[SI],BX ; reset page size to default
mov attrib+[SI],0 ; reset "no memory" bit in attribute table
IFDEF EXTMEM
and pagetabl+[SI],0FF00h ; strip attributes
ENDIF
mov ptype+[SI],FREETYPE*2 ; mark page as free
jmp short fix_lop ; continue to free extended pages
fix_ret: jmp swpret ; all pages released-- return
; Branch table for processing each data type
btable dw swplist ; [0] List cells
dw swpfix ; [1] Fixnums
dw swpflo ; [2] Flonums
dw swpbig ; [3] Bignums
dw swpsym ; [4] Symbols
dw swpstr ; [5] Strings
dw swpary ; [6] Arrays
dw swpcont ; [7] Continuations
dw swpclos ; [8] Closures
dw swpfree ; [9] Free space (unallocated)
dw swpcode ; [10] Code
dw swpref ; [11] Reference cells
dw swpport ; [12] Port data objects
dw swpchar ; [13] Characters
dw swpenv ; [14] Environments
swpage endp
prog ends
end


27
sinterp.arg Normal file
View File

@ -0,0 +1,27 @@
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Interpreter Local Data *
;* *
;* (C) Copyright 1984 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 2 May 1984 *
;* Last Modification: 7 June 1984 *
;***************************************
; Arguments and local storage for "sinterp"
sint_arg struc
save_SI dw ? ; place to save the PC ([SI])
save_ES dw ? ; place to save ES:
save_DI dw ? ; place to save DI
save_AX dw ? ; place to save AX
save_BX dw ? ; place to save BX
save_CX dw ? ; place to save CX
save_DX dw ? ; place to save DX
C_ES dw ? ; ES: needed by C routines
temp_reg dw 2 dup (?) ; temp register
sint_BP dw ? ; caller's BP
dw ? ; return address
cod_ent dw ? ; &entry offset
no_insts dw ? ; number of instructions to interpret
sint_arg ends

3213
sinterp.asm Normal file
View File

File diff suppressed because it is too large Load Diff

20
sinterp.mac Normal file
View File

@ -0,0 +1,20 @@
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* Interpreter Macros *
;* *
;* (C) Copyright 1984 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 2 May 1984 *
;* Last Modification: 14 Sept. 1984 *
;***************************************
; Call "printf" to produce error message
error macro args
irp txt,<args>
lea BX,txt
push BX
endm
jmp printf_c
endm


292
sio.asm Normal file
View File

@ -0,0 +1,292 @@
; =====> SIO.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;* I/O Utilities *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: June 1984 *
;* Last Modification: 09 July 1985 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;For space and performance reasons, some procedures have been written in the
; following style: the arguments are popped off the stack, and the
; procedure ends in an indirect JMP instead of a RET. In this source file,
; the following are such procedures:
; isspace, copybig
; Find approximate space left on stack
; Caling sequence: stkspc()
extrn _base:word
public stkspc
stkspc proc near
mov AX,SP
sub AX,DGROUP:_base
ret
stkspc endp
; Parse input integer
; Calling sequence: buildint(work,buf,base)
; Where ---- work: pointer to some workspace
; buf: pointer to integer characters
; base: numeric base
int_args struc
dw ? ;Caller's BP
dw ? ;Return address
bigptr dw ? ;Pointer to workspace
atptr dw ? ;Pointer to integer characters
bas dw ? ;Numeric base
int_args ends
public buildint
buildint proc near
push BP
mov BP,SP
cld ;Direction forward
mov SI,[BP].atptr ;Point DS:SI to characters
lodsb ;Fetch first character
cmp AL,'-' ;Negative?
pushf ;Save ZF
je negint ;Jump if negative
cmp AL,'+' ; or if signed positive
je negint
dec SI ;Point SI back to first char
negint: mov CX,1 ;At first, bignum is one word
add word ptr[BP].bigptr,3 ;Point BIGPTR to bignum proper
skiplp: lodsb ;Get first number char
cmp AL,'#' ;We know the base - skip all #x's
jne skipped ;All #x's skipped - parse number
inc SI ;Otherwise check again
jmp skiplp
biglp: lodsb ;Get next int character
skipped: mov DI,[BP].bigptr ;Point ES:DI to workspace
sub AL,'0' ;Character -> number
js bigend ;Jump if number ended
cmp AL,9 ;Jump if ordinary digit
jbe orddig
and AL,7 ;Otherwise, parse extra hex digit
add AL,9
orddig: xor AH,AH ;Clear AH
call bigx10 ;Multiply bignum by 10, adding digit
jmp biglp
bigend: sub DI,3 ;Point DI back to start of buffer
mov AX,CX ;Save integer size
stosw
xor AL,AL ;Clear AX
popf ;Get number's sign
jne stosgn ;Store it
inc AL
stosgn: mov [DI],AL
pop BP ;Restore BP
ret
;BIGX10: Multiply bignum at ES:[DI], size=CX words, by BASE and add AX
bigx10: push CX
mov DX,AX ;Transfer digit to add
cld
x10lp: mov AX,[DI] ;Get word to multiply
call wordx10 ;Multiply word by 10
stosw ;Replace result
loop x10lp ;Loop 'til done
pop CX ;Restore CX
or DX,DX ;Does a carry remain?
jz samlen ;Jump if not
mov ES:[DI],DX ;Otherwise, enlarge bignum
inc CX
samlen: ret
;WORDX10: Multiply AX by BASE and add DX; product in AX, carry in DX
wordx10: push CX ;Save value of CX
push DX ;Save carry in
mul word ptr[BP].bas ;Multiply by BASE
pop CX ;Restore carry to CX
add AX,CX ;Add carry
adc DX,0
pop CX ;Restore CX
ret
buildint endp
; Copy bignum data to a math buffer
; Calling sequence: copybig(pg,ds,buf)
; Where: pg,ds ---- page & displacement of bignum
; buf ------ pointer to math buffer
cb_args struc
dw ? ;Caller's BP
dw ? ;Return address
cbpg dw ? ;Page
cbds dw ? ;Displacement
cbbuf dw ? ;Buffer pointer
cb_args ends
public copybig
copybig proc near
pop BX ;Pop return address to BX
mov DX,DS ;Save DS in DX
pop SI ;Fetch logical page number
sal SI,1 ;Convert
LoadPage DS,SI ;Get page segment
;;; mov DS,DGROUP:pagetabl+[SI] ;Get page segment
pop SI ;Get displacement
mov AX,[SI]+1 ;Get size of bignum proper (words)
sub AX,4
shr AX,1
add SI,3 ;Point DS:SI to sign byte
pop DI ;Point ES:DI to math buffer
cld ;Direction forward
stosw ;Store bignum size in math buffer
movsb ;Copy sign byte
mov CX,AX ;Copy bignum proper
rep movsw
mov DS,DX ;Restore DS
jmp BX ;Return
copybig endp
; Convert buffered bignum to ASCII
; Calling sequence: big2asc(mathbuf,charbuf)
; Where: mathbuf --- pointer to buffered bignum
; charbuf --- pointer to ASCII charcater array
b2a struc
dw ? ;Caller's BP
dw ? ;Return address
mbuf dw ? ;Math buffer
cbuf dw ? ;Character buffer
b2a ends
public big2asc
big2asc proc near
push BP
mov BP,SP
mov SI,[BP].mbuf ;Fetch math buffer pointer
mov DI,[BP].cbuf ;Fetch character buffer pointer
cld ;Direction forward
lodsw ;Fetch bignum size
mov CX,AX
lodsb ;Fetch sign
test AL,1 ;Skip on positive bignum
jz posbig
mov AL,'-' ;First character: minus
stosb
posbig: mov BX,10 ;Set divisor to 10
and AX,1 ;Push 0 or 1 (1 if start with -)
prtbglp: push AX
call divbig ;Divide bignum by 10
mov AL,DL ;Store digit
add AL,'0'
stosb
pop AX ;Increment character counter
inc AX
or CX,CX ;Loop until bignum is zeroed
jnz prtbglp
mov CX,AX ;Transfer & save character count
push AX
sub DI,CX ;Point DI to beginning of string
call reverse ;Reverse digits in ASCII bignum
pop AX ;Restore character count
pop BP
ret
;Divide bignum at DS:SI, length CX words, by BX (ES=DS)
divbig: push CX ;Save count
push DI ;Save DI
add SI,CX ;Point SI to last word (most signif.)
add SI,CX
sub SI,2
cmp [SI],BX ;Will working length be reduced?
pushf
mov DI,SI ;ES:DI = DS:SI
std ;Direction backward
xor DX,DX ;Clear carry in
divlp: lodsw ;Fetch piece of dividend
div BX
stosw ;Store quotient (retain remainder)
loop divlp
add SI,2 ;Point SI again to first word
popf
pop DI
pop CX
jae divdone ;Jump if bignum length not reduced
dec CX
divdone: ret ;Remainder left in DX
;Reverse the string containing CX characters at ES:DI (ES=DS)
reverse: cmp byte ptr[DI],'-' ;Start with minus?
jne revpos ;No, reverse whole string
inc DI ;Otherwise, don't include minus in reverse
dec CX
revpos: mov SI,DI ;Point SI to last string char
add SI,CX
dec SI
shr CX,1 ;Number of switches
or CX,CX ;Jump if no switches to make
jz revend
revlp: mov AL,[DI] ;Exchange outside bytes
xchg AL,[SI]
stosb
dec SI ;Move pointers inward
loop revlp
revend: ret
big2asc endp
; Is character a whitespace?
; Calling sequence: isspace(ch)
; Where ch = character to check
; Returns zero iff not a whitespace
; NOTE: Before use, the C macro ISSPACE must not be defined
isspargs struc
dw ? ;Return address
issparg dw ? ;Argument
isspargs ends
public isspace
isspace proc near
pop DI ;Get return address
pop AX ;Get argument
cmp AL,' '
je issp
cmp AL,9
jb isntsp
cmp AL,13
jbe issp
isntsp: xor AX,AX ;Set to zero
issp: jmp DI ;Return
isspace endp
; Save stack pointer in case of abort
; Calling sequence: setabort()
; NOTE: Due to the program-sensitive nature of this routine, a call to
; SETABORT MUST be the very first in a C routine, and there must be
; NO preassigned local variables.
public setabort
setabort proc near
mov BX,SP ;Fetch stack pointer
mov SI,SS:[BX] ;Fetch return address
mov CL,CS:[SI-6] ;Fetch byte just before MOV BP,SP
cmp CL,55h ;Compare with PUSH BP opcode
je nolocal ;Jump if no extra stack space allocated
xor CH,CH ;Clear CH
add BX,CX ;Discount extra stack space
nolocal: add BX,2 ;Discount SETABORT's return address
mov DGROUP:abadr,BX ;Save pointer
ret
setabort endp
; Abort & set stack to saved pointer
; Calling sequence: abort(code)
; where: code ---- type of error message to print
public abort
abort proc
pop AX ;Discard return address (leaving CODE)
C_call errmsg ;Print error message
pop AX ;Get "value"
mov SP,DGROUP:abadr ;Restore stack for abort
pop BP ;Restore BP
ret ;Return (from aborted operation)
abort endp
prog ends
end


35
slink.h Normal file
View File

@ -0,0 +1,35 @@
/* =====> SLINK.H */
/* PC Scheme Lattice C Macros to Support Scheme to C Interface
Copyright 1985 by Texas Instruments Incorporated.
All Rights Reserved.
Author: John C. Jensen
Installation: Texas Instruments Incorporated, Dallas, Texas
Division: Central Research Laboratories
Cost Center: Computer Science Laboratory
Project: Computer Architecture Branch
Date Written: 22 June 1985
Last Modification: 23 June 1985
Purpose: The macros within this module provide the capability to
fetch values passed from the Scheme Runtime and return
values to the Scheme Runtime.
Description: For a description of parameter passing conventions, see the
module header in the file SLINK.C.
*/
#define INTEGER(x) *((int *)x)
#define LONG_INTEGER(x) *x
#define FLOAT(x) *((float *)x)
#define DOUBLE(x) *((double *)x)
#define CHARACTER(x) *((char *)x)
#define STRING(x) ((char*)x)
#define RETURN_NOVALUE() return(0)
#define RETURN_T_OR_NIL(x) **result = (x); return(1)
#define RETURN_INTEGER(x) **result = (x); return(2)
#define RETURN_FLONUM(x) *((double *) *result) = (x); return(3)
#define RETURN_CHARACTER(x) *((char *) *result) = (x); return(4)
#define RETURN_STRING(x) t_=(x);if(t_){*result=(long *)t_;return(5);}else{**result=0;return(1);}


25
slist.h Normal file
View File

@ -0,0 +1,25 @@
/************************************************************************/
/* C Equivalents for Scheme List Operations */
/* */
/* Copyright 1985 by Texas Instruments Incorporated. */
/* All Rights Reserved. */
/* */
/* Date Written: 29 March 1985 */
/* Last Modification: 1 April 1985 */
/************************************************************************/
/* copy contents of one "register" to another */
#define mov_reg(dest,src) dest[C_PAGE]=src[C_PAGE]; dest[C_DISP]=src[C_DISP]
/* test equality (eq? -ness) of two registers */
#define eq(r1,r2) (r1[C_DISP] == r2[C_DISP] && r1[C_PAGE] == r2[C_PAGE])
/* take caar of a "register" */
#define take_caar(reg) take_car(reg); take_car(reg)
/* take cadr of a "register" */
#define take_cadr(reg) take_cdr(reg); take_car(reg)
/* take cddr of a "register" */
#define take_cddr(reg) take_cdr(reg); take_cdr(reg)


173
smmu.asm Normal file
View File

@ -0,0 +1,173 @@
name SMMU
title Scheme Memory Management Utilities
page 62,132
; =====> SMMU.ASM
;****************************************************************
;* TIPC Scheme '84 Memory Management Utilities *
;* *
;* (C) Copyright 1985, 1987 by Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Author: Terry Caudill *
;* Date written: 18 March 1986 *
;* History: *
;* rb 4/ 5/87 "getbase" returns a page's swap state in carry *
;* (for compatibility with PCSEXT and PCSEXP) *
;****************************************************************
include schemed.equ
include schemed.ref
DOS equ 021h
DGROUP group data
PGROUP group prog
data segment word public 'DATA'
assume ds:DGROUP
extrn page0:byte, page4:byte, page5:byte, page6:byte
extrn page7:byte, page8:byte
extrn _top:word, _paras:word,first_pa:word,first_dos:word
public GC_ING
GC_ING dw 0
data ends
prog segment byte public 'PROG'
assume cs:PGROUP
;;======================================================================
;;
;; Get page base address of page
;;
;; On exit, carry is clear to indicate page is always in memory
;; (for compatibility with extended and expanded versions of this routine)
;;
;;======================================================================
public getbase
getbase proc near
push BP
mov BP,SP
mov BX,word ptr [BP+4]
mov AX,word ptr [BX+pagetabl] ;; Get table indicator
clc ;; page always avail in conv. memory
pop BP
ret
getbase endp
;;======================================================================
;;
;; InitMem()
;; Compute the best page size, but not smaller than MIN_PAGESIZE
;;
;;======================================================================
public InitMem
InitMem proc near
push BP
sub SP,2 ;; Local storage
mov BP,SP
mov BX,DS
mov ES,BX ;; Ensure ES = DS
;; Convert offset within pagetabl[0] into paragraph address
mov DI,offset pagetabl
mov AX,word ptr [DI]
mov CX,4
shr AX,CL
add AX,BX
mov word ptr [DI],AX
;; Same for pagetabl[4] through pagetabl[8]
mov DX,5
mov DI,offset pagetabl[8]
EmmP$0:
mov AX,word ptr [DI]
shr AX,CL
add AX,BX
mov word ptr [DI],AX
add DI,2
dec DX
jnz EmmP$0
;; Allocate all the memory that DOS will give us.
mov BX,0FFFFh ;; first ask for too much
mov AH,048h
int DOS ;; DOS gets an error, but tells us
;; in BX how much we CAN get
mov AH,048h
int DOS ;; reissue allocation request
mov first_dos,AX ;; save address for returning it to DOS
mov first_pa,AX ;; save address for Scheme heap
;; Compute the best page size, but not smaller than MIN_PAGESIZE
mov AX,_paras ;; max number of paragraphs
sub AX,first_pa ;; subtract first paragragh
xor DX,DX ;; get ready for divide
mov CX,NUMPAGES-PreAlloc ;; CX <= number heap allocated pages
idiv CX ;; AX <= paras-per-page
mov DX,(MIN_PAGESIZE shr 4)
cmp AX,DX ;; If paras-per-page < MIN_PAGESIZE/16
jge EmmP$05 ;; then
mov AX,DX ;; paras-per-page = MIN_PAGESIZE/16
EmmP$05:
mov [BP],AX ;; Save paras-per-page
;; Pagesize = (paras-per-page * 16)
mov CX,4
shl AX,CL
mov pagesize,AX
mov SI,AX
;; Initialize page management table
xor CX,CX ;; Keep number of pages in CX
mov DX,nextpage
mov freepage,DX ;; freepage = nextpage
mov AX,first_pa ;; AX <= next paragraph
mov DI,_paras ;; DI <= (_paras - paras per page)
sub DI,[BP]
EmmP$1:
cmp DI,AX ;; Did we reach it
jb EmmP$2 ;; Yes...no more
cmp DX,NUMPAGES ;; See if we have filled the table
jae EmmP$2
mov BX,DX
shl BX,1
mov word ptr [BX+pagetabl],AX
mov word ptr [BX+psize],SI
and word ptr [BX+attrib],not NOMEMORY
inc DX
mov word ptr [BX+pagelink],DX
mov word ptr [BX+nextcell],0
inc CX ;; page_count++
add AX,[BP] ;; nextpara = nextpara + para per page
jmp EmmP$1
EmmP$2:
mov nextpage,DX ;; nextpage = lastpage
mov lastpage,DX
mov AX,CX
pop BP
pop BP
ret
InitMem endp
prog ends
end


301
smmu.mac Normal file
View File

@ -0,0 +1,301 @@
;*******************************************************************************
;* TIPC Scheme '84 Runtime Support - Assembler Macros *
;* *
;* (C) Copyright 1984,1985 by Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Memory and Machine specific macros to aid in the building specific *
;* of PC Scheme. There are four versions of the PC Scheme system: *
;* 1. Conventional Memory Scheme *
;* 2. Expanded Memory Scheme *
;* 3. Extended Memory Scheme *
;* 4. Protected Mode Scheme *
;* These macros create version specific code for each of the above schemes. *
;* The Macro assembler symbols REGMEM, EXPMEM, EXTMEM, and PROMEM are used *
;* to conditionally define the correct macros. It can be (and must be) *
;* specified on the MASM command line during the assembly phase as follows: *
;* MASM /DREGMEM srcfile,objfile,... *
;* *
;* Date Written: 29 July 1987 *
;* *
;* *
;*******************************************************************************
;;;
;;; Macros for conventional memory version - default
;;;
; The LoadPage macros should be used to obtain the address of a given page
; from the pagetable. This must be done in order to access any given heap
; allocated object. For conventional memory, this just means indexing into
; the pagetable and accessing the paragraph address, however for extended
; and expanded memories, it is quite different. See the macro definitions
; for EXPMEM and EXTMEM for definitions for expanded and extended memorys.
LoadPage MACRO dst,src ; Get Page address from page table
IFIDN <src>,<BX>
mov dst,[SS:pagetabl+src]
ELSE
IFIDN <src>,<bx>
mov dst,[SS:pagetabl+src]
ELSE
IFIDN <src>,<DI>
mov dst,[SS:pagetabl+src]
ELSE
IFIDN <src>,<di>
mov dst,[SS:pagetabl+src]
ELSE
IFIDN <src>,<DI>
mov dst,[SS:pagetabl+src]
ELSE
IFIDN <src>,<si>
mov dst,[SS:pagetabl+src]
ELSE
IFIDN <src>,<SI>
mov dst,[SS:pagetabl+src]
ELSE
push BX
mov BX,src
mov dst,[SS:pagetabl+BX]
pop BX
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
ENDM
%LoadPage MACRO dst,src
LoadPage dst,src
ENDM
%LoadPage0 MACRO dst,src
LoadPage dst,src
ENDM
%LoadPage1 MACRO dst,src
LoadPage dst,src
ENDM
LoadCode MACRO dst,src
LoadPage dst,src
ENDM
; The following macros should be used whenever saving some value in a
; location within the code segment. For real mode, you may store anything
; within the code segment, however in protected mode, this causes a
; protection violation. See the macro expansions for PROMEM to see how
; this may be accomplished in protected mode.
STORE_WORD_IN_CS MACRO SEG,OFFSET,VALUE
mov word ptr CS:OFFSET,VALUE
ENDM
STORE_BYTE_IN_CS MACRO SEG,OFFSET,VALUE
mov byte ptr CS:OFFSET,VALUE
ENDM
XCHG_WORD_IN_CS MACRO SEG,OFFSET,VALUE
xchg word ptr CS:OFFSET,VALUE
ENDM
IFDEF REGMEM
; Access to pagetabl for LoadPage macros
extrn pagetabl:word
ENDIF
;;;
;;; Macros for expanded memory version
;;;
IFDEF EXPMEM
; get rid of default conventional memory definitions
purge LoadPage,%LoadPage,%LoadPage0,%LoadPage1,LoadCode
; Load page address
extrn _MMU:near
LoadPage MACRO dst,src
push src
call _MMU
pop dst
ENDM
; Load code block
extrn _MMUCB:near
LoadCode MACRO dst,src
push src
call _MMUCB
pop dst
ENDM
; SAME AS LoadPage EXCEPT CALLABLE FROM PROGX SEGMENT
extrn _%MMU:far
%LoadPage MACRO dst,src
IF1
IFIDN <dst>,<AX>
%OUT *AX as destination of %LoadPage not recommended*
ELSE
IFIDN <dst>,<ax>
%OUT *AX as destination of %LoadPage not recommended*
ENDIF
ENDIF
ENDIF
push AX
mov AX,src
call _%MMU
mov dst,AX
pop AX
ENDM
; Loads only Emm page 0
extrn _%MMU0:far
%LoadPage0 MACRO dst,src
IF1
IFIDN <dst>,<AX>
%OUT *AX as destination of %LoadPage0 not recommended*
ELSE
IFIDN <dst>,<ax>
%OUT *AX as destination of %LoadPage0 not recommended*
ENDIF
ENDIF
ENDIF
push AX
mov AX,src
call _%MMU0
mov dst,AX
pop AX
ENDM
; Loads only Emm page 1
extrn _%MMU1:far
%LoadPage1 MACRO dst,src
IF1
IFIDN <dst>,<AX>
%OUT *AX as destination of %LoadPage1 not recommended*
ELSE
IFIDN <dst>,<ax>
%OUT *AX as destination of %LoadPage1 not recommended*
ENDIF
ENDIF
ENDIF
push AX
mov AX,src
call _%MMU1
mov dst,AX
pop AX
ENDM
ENDIF
;;;
;;; Macros for extended memory version
;;;
IFDEF EXTMEM
; get rid of default conventional memory definitions
purge LoadPage,%LoadPage,%LoadPage0,%LoadPage1,LoadCode
; Load page address
extrn _MMU:near
LoadPage MACRO dst,src
push src
call _MMU
pop dst
ENDM
; SAME AS LoadPage EXCEPT CALLABLE FROM PROGX SEGMENT
extrn _%MMU:far
%LoadPage MACRO dst,src
IF1
IFIDN <dst>,<AX>
%OUT *AX as destination of %LoadPage not recommended*
ELSE
IFIDN <dst>,<ax>
%OUT *AX as destination of %LoadPage not recommended*
ENDIF
ENDIF
ENDIF
push AX
mov AX,src
call _%MMU
mov dst,AX
pop AX
ENDM
; The following macros are provided for comatibility with the
; Expanded memory version. They just perform a LoadPage.
; Load code block
LoadCode MACRO dst,src
LoadPage dst,src
ENDM
%LoadPage0 MACRO dst,src
%LoadPage dst,src
ENDM
%LoadPage1 MACRO dst,src
%LoadPage dst,src
ENDM
ENDIF
;;;
;;; Macros for protected mode version
;;;
IFDEF PROMEM
; get rid of default real mode definitions
purge STORE_WORD_IN_CS,STORE_BYTE_IN_CS,XCHG_WORD_IN_CS
; Access to pagetabl for LoadPage macros
extrn pagetabl:word
STORE_WORD_IN_CS MACRO SEG,OFFSET,VALUE
push DS
push AX
mov AX,CS
and AX,0FFF7H
mov DS,AX
pop AX
assume DS:SEG
mov word ptr DS:OFFSET,VALUE
assume DS:DGROUP
pop DS
ENDM
STORE_BYTE_IN_CS MACRO SEG,OFFSET,VALUE
push DS
push AX
mov AX,CS
and AX,0FFF7H
mov DS,AX
pop AX
assume DS:SEG
mov byte ptr DS:OFFSET,VALUE
assume DS:DGROUP
pop DS
ENDM
XCHG_WORD_IN_CS MACRO SEG,OFFSET,VALUE
push DS
push AX
mov AX,CS
and AX,0FFF7H
mov DS,AX
pop AX
assume DS:SEG
xchg word ptr DS:OFFSET,VALUE
assume DS:DGROUP
pop DS
ENDM
ENDIF

458
sobjhash.asm Normal file
View File

@ -0,0 +1,458 @@
; =====> SOBJHASH.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* Object Hashing Routines *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 25 June 1985 *
;* Last Modification: 3 November 1985 *
;***************************************
include scheme.equ
DGROUP group data
XGROUP group PROGX
PGROUP group prog
data segment word public 'DATA'
assume DS:DGROUP
obj_cntr dw OHT_SIZE dup (1)
branchtab dw ogc_list ; [0] List cells
dw ogc_mark ; [1] Fixnums
dw ogc_var ; [2] Flonums
dw ogc_var ; [3] Bignums
dw ogc_var ; [4] Symbols
dw ogc_var ; [5] Strings
dw ogc_var ; [6] Arrays
dw ogc_var ; [7] Continuations
dw ogc_var ; [8] Closures
dw ogc_mark ; [9] Free page
dw ogc_var ; [10] Code page
dw ogc_mark ; [11] Reference cells <not anymore>
dw ogc_var ; [12] Port data objects
dw ogc_mark ; [13] Characters
dw ogc_var ; [14] Environments
ret_sav1 dw 0 ; return address save area
ret_sav2 dw 0 ; return address save area
data ends
prog segment byte public 'PROG'
assume CS:PGROUP
;************************************************************************
;* Far Linkage to "lookup" Routine *
;************************************************************************
%lookup proc far
extrn lookup:near
call lookup
ret
%lookup endp
;************************************************************************
;* Far Linkage to "cons" Routine *
;************************************************************************
public %cons
%cons proc far
pop ret_sav1
pop ret_sav2
mov AX,DS ; make ES point to the data segment
mov ES,AX
extrn cons:near
call cons
push ret_sav2
push ret_sav1
ret
%cons endp
;************************************************************************
;* Far Linkage to "alloc_block" Routine *
;************************************************************************
public %allocbl
%allocbl proc far
pop ret_sav1
pop ret_sav2
mov AX,DS ; make ES point to the data segment
mov ES,AX
extrn alloc_bl:near
call alloc_bl
push ret_sav2
push ret_sav1
ret
%allocbl endp
prog ends
PROGX segment byte public 'PROGX'
assume CS:XGROUP
;************************************************************************
;* Object Hash *
;************************************************************************
oh_args struc
oh_key dw ? ; computed hash key
oh_key3 dw ? ; computed hash key * 3
oh_disp dw ? ; page number component of a pointer
oh_page dw ? ; displacement component of a pointer
oh_reg dw ? ; pointer to argument register (s=d)
oh_ctr dw ? ; bucket's current counter value
oh_ctag db SPECFIX*2,? ; tag for counter
oh_BP dw ? ; caller's BP
dw ? ; caller's SI
dw ? ; caller's ES
dd ? ; return address (far call)
dw ? ; return address (near call)
oh_args ends
%objhash proc far
lods byte ptr ES:[SI] ; fetch operand of object-hash
push ES ; save the caller's ES register
push SI ; save the location counter
push BP ; save the caller's BP register
sub SP,offset oh_BP ; allocate local storage
mov BP,SP ; establish local addressability
; load argument and compute hash index
mov BX,AX ; copy dest=src register number to BX
add BX,offset reg0 ; and compute the register's address
mov [BP].oh_reg,BX ; save the register address
;;;
;;; Note: computing of hash value turned off 'cause relocation of
;;; pointers screws things up. For now, all objects will
;;; hash to a key of zero. (JCJ 2 OCT 85)
;;; mov DX,[BX].C_page ; load the argument's page number
;;; mov AX,[BX].C_disp ; load the argument's displacement
;;; mov CL,AH ; copy high byte of displacement
;;; xor AH,AH
;;; xor CH,CH
;;; add AX,CX
;;; add AX,DX
;;; mov CX,OHT_SIZE ; load the hash table size for divisor
;;; cwd ; convert dividend to double word
;;; div CX ; divide hash value by table size
xor DX,DX ; ***TEMPORARY*** Load a hash key of zero
;;;
mov [BP].oh_key,DX ; save computed hash key
mov SI,DX
shl DX,1
add SI,DX ; SI <- hash_key * 3
mov [BP].oh_key3,SI
; if entries exist at this hash level, search bucket for object
cmp obj_ht+[SI],0 ; anyone home in this bucket?
je oh_nf ; if no entries exist, jump
; call "lookup" to search a-list
mov AX,[BX].C_disp ; reload object's displacement
mov DX,[BX].C_page ; and page for a-list search
xor BX,BX
mov BL,obj_ht+[SI]
%LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov SI,word ptr obj_ht+[SI]+1
call %lookup ; search the a-list
cmp BL,0
je oh_nf
; object found in hash bucket's chain-- return it
mov AX,ES:[DI].cdr ; load the hash counter
mov [BP].oh_ctr,AX ; and save it in 'oh_ctr'
jmp short oh_ret ; return hash value
; make a new entry in the current hash bucket
oh_nf: mov DI,[BP].oh_key
shl DI,1 ; multiply hash value by 2 for index
mov AX,obj_cntr+[DI] ; load obj hash counter for this bucket
inc obj_cntr+[DI] ; increment the obj hash counter
mov [BP].oh_ctag,SPECFIX*2 ; convert hash counter to a fixnum
mov [BP].oh_ctr,AX ; pointer
lea BX,[BP].oh_ctr ; load hash counter's "reg" address
mov AX,[BP].oh_reg ; load object's register address
mov CX,offset tmp_reg ; load offset of temporary register
pushm <BX,AX,CX> ; push arguments to call
call %cons ; cons(tmp_reg, object, hash-counter)
mov BX,offset nil_reg ; load address of "nil register"
mov CX,offset tmp_reg ; load address of temporary register
pushm <BX,CX,CX> ; push arguments to cons
call %cons ; cons(tmp_reg, (cons obj hash), nil)
mov SP,BP ; drop arguments from stack
mov DI,[BP].oh_key3 ; load hash bucket number * 3
mov BX,tmp_page ; load pointer to newest list cell
mov AX,tmp_disp
%LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov SI,AX ; pointer is in ES:[SI]
xchg obj_ht+[DI],BL ; header <- pointer to list cell
xchg word ptr obj_ht+[DI]+1,AX
mov ES:[SI].cdr_page,BL ; (set-cdr! list-cell chain-header)
mov ES:[SI].cdr,AX
; create a bignum to hold the hash value
oh_ret: mov AX,WORDINCR*2+1 ; load the size of bignum result
push AX ; and push it for use as argument
mov AX,BIGTYPE ; load type=bignum
push AX ; and push it for use as argument
push [BP].oh_reg ; push address of destination register
mov AX,DS ; ES <- DS
mov ES,AX
call %allocbl ; allocate the bignum
mov SP,BP ; drop arguments off the TIPC's stack
mov BX,[BP].oh_reg ; load destination register's address
mov SI,[BX].C_page ; load bignum's page number
%LoadPage ES,SI ; load bignum page's paragraph address
;;; mov ES,pagetabl+[SI] ; load bignum page's paragraph address
mov SI,[BX].C_disp ; load bignum's displacement
mov AX,[BP].oh_key ; load hash bucket number
mov ES:[SI].big_data,AX ; and store it into LSW of bignum
mov AX,[BP].oh_ctr ; load counter for this object
mov ES:[SI].big_2nd,AX ; and store it into MSW of bignum
mov ES:[SI].big_sign,0 ; sign <- 0 (positive number)
; return to caller
add SP,offset oh_BP ; deallocate local storage
pop BP ; restore caller's BP register
pop SI ; restore the location pointer
pop ES ; restore caller's ES register
ret ; return to calling procedure
%objhash endp
;************************************************************************
;* Object Unhash *
;************************************************************************
unhs_arg struc
un_reg dw ? ; argument register address
un_BP dw ? ; caller's BP
dw ? ; caller's SI
dw ? ; caller's ES
dd ? ; return address (far call)
dw ? ; return address (near call)
unhs_arg ends
%objunhs proc far
lods byte ptr ES:[SI] ; load the operand for object-unhash
push ES ; save the caller's ES register
push SI ; save the location pointer
push BP ; save the caller's BP register
sub SP,offset un_BP ; allocate local storage
mov BP,SP ; establish local addressability
; Begin the long process of validating the input
mov SI,AX
add SI,offset reg0
mov [BP].un_reg,SI
mov BX,[SI].C_page
cmp byte ptr ptype+[BX],BIGTYPE*2
je un_maybe
; This hash-key is invalid, or object not found-- return #!false
un_false: xor AX,AX ; create a nil pointer
mov SI,[BP].un_reg ; load destination register address
mov byte ptr [SI].C_page,AL ; store nil pointer into
mov [SI].C_disp,AX ; destination register
; Return to Scheme Interpreter
un_ret: add SP,offset un_BP ; deallocate local storage
pop BP ; restore caller's BP register
pop SI ; restore the location pointer
pop ES ; restore caller's ES register
ret
; Continue checking bignum value
un_maybe: mov SI,[SI].C_disp ; load bignum's offet
%LoadPage ES,BX ; and paragraph address
;;; mov ES,pagetabl+[BX] ; and paragraph address
cmp ES:[SI].big_sign,0
jne un_false ; if negative, not one of ours
cmp ES:[SI].big_len,8
jne un_false ; if more than four bytes of data, not ours
mov DI,ES:[SI].big_data ; load least significant word (bucket no.)
cmp DI,OHT_SIZE
jae un_false ; hash bucket index too large? if so, jump
mov DX,DI ; DX <- bucket number
mov AX,ES:[SI].big_2nd
shl DI,1 ; DI <- bucket number * 2
cmp AX,obj_cntr+[DI] ; test against next available counter value
jae un_false ; hash index too large? if so, jump
; Note: Search index (key) is in AX
add DI,DX ; DI <- bucket number * 3
add DI,offset obj_ht
mov DX,DS ; ES <- DS
mov ES,DX
; Note: Search list whose header is in ES:[DI]
call oh_search ; search "ES:[DI]" for "AX"
cmp BL,0 ; was index found?
je un_false ; if not found, return #!false (jump)
; Search successful-- object/hash-value pair pointed to by ES:[SI]
mov DI,[BP].un_reg ; load destination register's address
mov AX,ES:[SI].car ; copy car field of found pair into
mov [DI].C_disp,AX ; the destination register
mov AL,ES:[SI].car_page
mov byte ptr [DI].C_page,AL
jmp un_ret ; return to caller w/ object in dest reg
%objunhs endp
;************************************************************************
;* Local Support for Object Unhash *
;************************************************************************
oh_search proc near
; Compute pointer to current entry and save it
mov BL,ES:[DI].car_page
cmp BL,0
je oh_sret
mov DI,ES:[DI].car
%LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov DX,ES ; save ES in DX
; Compute pointer to object/hash-key pair
mov BL,ES:[DI].car_page
mov SI,ES:[DI].car
%LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
; Test cdr field (hash key) of pair for match
cmp ES:[SI].cdr,AX
jne oh_smore
; A match!-- Return pair address in ES:[SI]
oh_sret: ret
oh_smore: mov ES,DX ; restore ES
add DI,PTRSIZE ; adjust pointer to cdr field of curr entry
jmp oh_search ; iterate
oh_search endp
;************************************************************************
;* Object Hash Table Garbage Collection *
;************************************************************************
gc_args struc
prev_ES dw ? ; ES for previous entry
prev_off dw ? ; offset for previous entry
curr_PG dw ? ; ES for current entry
curr_off dw ? ; offset for current entry
pair_PG dw ? ; ES for object/hash-key pair
pair_off dw ? ; offset for object/hash-key pair
gc_BP dw ? ; caller's BP
dw ? ; caller's ES
dd ? ; return address (far call)
dw ? ; return address (near call)
gc_args ends
%gc_oht proc far
push ES ; save caller's ES register
push BP ; save caller's BP register
sub SP,offset gc_BP ; allocate local storage
mov BP,SP ; establish addressibility for local storage
; Initialize parameters
mov SI,offset obj_ht ; load address of object hash table
mov CX,OHT_SIZE ; load number of entries in obj hash table
gc_loop: mov AX,DS ; ES <- DS
mov ES,AX
push SI ; load current object hash table offset
push CX ; save iteration counter
call gc_nxt ; follow this entries chain
pop CX ; restore iteration counter
pop SI ; restore obj hash table offset
add SI,PTRSIZE ; advance offset pointer
loop gc_loop ; continue 'til all buckets processed
; Return to caller
gc_xit: add SP,offset gc_BP ; release local storage
pop BP ; restore the caller's BP register
pop ES ; restore the caller's ES register
ret ; return
%gc_oht endp
;************************************************************************
;* Local Support for Object Hash Table Garbage Collection *
;************************************************************************
gc_nxt proc near
xor BX,BX ; clear register BX
mov BL,ES:[SI].car_page ; load page number for next entry
cmp BL,0 ; does entry exist?
jne ogc_010 ; if null pointer, jump to exit
ret ; return to gc_oht
; save pointer to previous cell
ogc_010: mov [BP].prev_ES,ES
mov [BP].prev_off,SI
; compute and save pointer to current cell
mov DI,ES:[SI].car
%LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov [BP].curr_PG,BX
mov [BP].curr_off,DI
; compute and save pointer to object/hash-key pair
mov BL,ES:[DI].car_page
mov SI,ES:[DI].car
test SI,08000h ; is current cell marked as referenced?
jnz ogc_skip ; if marked, GC during OBJECT-HASH (jump)
%LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov [BP].pair_PG,BX
mov [BP].pair_off,SI
; see what object pointer points to
mov BL,ES:[SI].car_page
cmp BL,DEDPAGES*PAGEINCR ; is object a "special" one?
jb ogc_mark ; if a non-gc'ed page, must keep entry
mov SI,ES:[SI].car ; load object offset
%LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load object's paragraph address
mov DI,ptype+[BX] ; load type code for object
jmp branchtab+[DI] ; jump to appropriate routine
; object is a list cell-- test to see if it's marked
ogc_list: test byte ptr ES:[SI].list_gc,GC_BIT
jnz ogc_mark
jmp short ogc_del
; Variable length object
ogc_var: test byte ptr ES:[SI].vec_gc,GC_BIT
jnz ogc_mark
; Object not referenced-- delete object hash table entry for it
ogc_del: %LoadPage ES,[BP].curr_PG ; reload pointer to current entry
mov SI,[BP].curr_off
mov AX,ES:[SI].cdr ; load cdr field of current entry
mov BL,ES:[SI].cdr_page
mov ES,[BP].prev_ES ; reload pointer to previous entry
mov SI,[BP].prev_off
mov ES:[SI].car,AX ; store cdr field of current entry into
mov ES:[SI].car_page,BL ; previous entry
jmp gc_nxt ; process next entry
; Object is marked as referenced-- mark obj hash table cells as referenced
ogc_mark: %LoadPage ES,[BP].pair_PG ; load pointer to object/hash-key pair
mov SI,[BP].pair_off
or byte ptr ES:[SI].list_gc,GC_BIT ; mark pair entry referenced
ogc_skip: %LoadPage ES,[BP].curr_PG ; load pointer to current entry
mov SI,[BP].curr_off
or byte ptr ES:[SI].list_gc,GC_BIT ; mark curr entry referenced
add SI,PTRSIZE ; advance pointer to cdr field of curr entry
jmp gc_nxt ; process next entry
gc_nxt endp
PROGX ends
prog segment byte public 'PROG'
assume CS:PGROUP
;************************************************************************
;* Linkage to Object Hash Routine *
;************************************************************************
public obj_hash
obj_hash proc near
call %objhash
extrn next:near
jmp next ; return to the Scheme interpreter
obj_hash endp
public obj_unhs
obj_unhs proc near
call %objunhs
jmp next ; return to the Scheme interpreter
obj_unhs endp
public gc_oht
gc_oht proc near
call %gc_oht
ret
gc_oht endp
prog ends
end


136
sport.h Normal file
View File

@ -0,0 +1,136 @@
/* -----> SPORT.H */
/* TIPC Scheme Runtime Support - I/O Control Structure Definition
Copyright 1985 by Texas Instruments Incorporated.
All Rights Reserved.
Author: John C. Jensen
Installation: Texas Instruments Incorporated, Dallas, Texas
Division: Corporate Research Laboratories
Cost Center: Computer Science Laboratory
Project: Computer Architecture Branch
Date Written: 1 February 1985
Last Modification: 18 July 1985 by Mark Meyer
22 Jan 1987 by dbs - added random i/o
*/
/* The format of a window data object is:
+--------+--------+--------+
0 |tag=port| length in bytes |
+--------+-----------------+
3 | pointer |
+--------+--------+--------+--------+
6 | port flags | handle |
+-----------------+-----------------+
10 | cursor line | cursor column |
+-----------------+-----------------+
14 | upper left line |upper left column|
+-----------------+-----------------+
18 | number of lines |number of columns|
+-----------------+-----------------+
22 |border attributes| text attributes |
+-----------------+-----------------+
26 | window flags | buffer position |
+-----------------+-----------------+
30 | buffer end |
+--------+--------+--------+--------+----... -----+
32 | input buffer |
+--------+--------+-----------------+-------...---+
| window label |
+--------+--------+-----------------+---------...-+
7 6 5 4 3 2 1 0
+-+-+-+-+-+-+---+
port flags: | |s|b|t|o|w|mod|
+-+-+-+-+-+-+---+
mod - mode: 0=read
1=write
2=read and write
w - window/file: 0=file
1=window
o - open/closed: 0=closed
1=open
t - transcript: 0=disabled
1=enabled
b - binary flag: 0=text file/window
1=binary file/window
s - string I/O: 0=file or window
1=I/O from/to string
7 6 5 4 3 2 1 0
+-----------+-+-+
window flags: | |e|w|
+-----------+-+-+
w - wrap/clip: 0=clip
1=wrap
e - exposed: 0=exposed
1=(partially) covered
The format of a file data object is:
+--------+--------+--------+
0 |tag=port| length in bytes |
+--------+-----------------+
3 | null |
+--------+--------+--------+--------+
6 | port flags | handle |
+-----------------+-----------------+
10 | pathname offset | current column |
+-----------------+-----------------+
14 | chunk # | (reserved) |
+-----------------+-----------------+
18 |file size (high) |number of columns|
+-----------------+-----------------+
22 | file size (low) | (reserved) |
+-----------------+-----------------+
26 | (reserved) | buffer position |
+-----------------+-----------------+
30 | buffer end |
+--------+--------+--------+--------+----... -----+
32 | input/output buffer ... |
+--------+--------+-----------------+-------... --+
| file pathname ... |
+--------+--------+-----------------+---------... +
*/
#define READ 0x00
#define WRITE 0x01
#define APPEND 0x02
#define READ_WRITE 0x02
#define WINDOW 0x04
#define OPEN 0x08
#define TRANSCRIPT 0x10
#define BINARY 0x20
#define STRSRC 0x40
#define WRAP 0x01
#define MAX_LINES 25 /* number of lines on the VDT */
#define MAX_COLUMNS 80 /* number of columns on the VDT */
#define WINDSIZE 32-BLK_OVHD
#define BUFFSIZE 256 /* input/output buffer size (bytes) */
#define STR_PTR 3 /* pointer to source string, if any */
#define P_FLAGS 6 /* port flags */
#define HANDLE 8 /* file/device handle */
#define CUR_LINE 10 /* current line/record number */
#define CUR_COL 12 /* current column/record number */
#define UL_LINE 14 /* window: upper left corner's line number */
/* file: chunk # */
#define UL_COL 16 /* window: upper left corner's column number */
#define N_LINES 18 /* window: number of lines */
/* file: high word of file size */
#define N_COLS 20 /* line length */
#define B_ATTRIB 22 /* window: border attributes */
/* file: low word of file size */
#define T_ATTRIB 24 /* window: text attributes */
#define W_FLAGS 26 /* window: flags */
#define BUF_POS 28 /* current buffer position */
#define BUF_END 30 /* current end of buffer offset */
#define BUFR 32 /* input/output buffer */
#define LABEL 32+BUFFSIZE /* window label field */
#define PATHNAME 32+BUFFSIZE /* file pathname field */


753
squish.asm Normal file
View File

@ -0,0 +1,753 @@
; =====> SQUISH.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* Memory Compaction Routines *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 23 September 1985 *
;* Last Modification: 22 October 1985 *
;* *
;* rb 2/ 2/88 - put in TC's GC fix *
;* *
;***************************************
.286c ;; Utilize the expanded 80286 instruction set
include scheme.equ
DGROUP group data
XGROUP group PROGX
PGROUP group prog
MSDOS equ 021h
data segment word public 'DATA'
assume DS:DGROUP
ret_sav1 dw 0 ; return address save area
ret_sav2 dw 0 ; return address save area
;;;msg db " Compacting Memory *",0
;;;msg1a db "Moving List Cells",LF,0
;;;msg1b db "Moving Flonums",LF,0
;;;msg1c db "Moving Bignums",LF,0
;;;msg1d db "Moving Closures",LF,0
;;;msg1e db "Moving Code Blocks",LF,0
;;;msg1f db "Moving Vectors",LF,0
;;;msg1g db "Moving Continuations",LF,0
;;;msg1h db "Moving Symbols",LF,0
;;;msg1i db "Moving Strings",LF,0
;;;msg2 db "About to Relocate Pointers",LF,0
;;;msg3 db "Complementing GC Bits",LF,0
;;;msg4 db "About to Sweep",LF,0
data ends
prog segment byte public 'PROG'
assume CS:PGROUP
extrn %allocbl:far ; "alloc_block" linkage routine
;************************************************************************
;* Far Linkage to SUM_SPACE *
;************************************************************************
%sumspac proc far
pop ret_sav1
pop ret_sav2
extrn sum_spac:near
call sum_spac
push ret_sav2
push ret_sav1
ret
%sumspac endp
;************************************************************************
;* Far Linkage to GCSWEEP *
;************************************************************************
%gcsweep proc far
pop ret_sav1
pop ret_sav2
extrn gcsweep:near
call gcsweep
push ret_sav2
push ret_sav1
ret
%gcsweep endp
IFDEF EXPMEM
;************************************************************************
;* Far Linkage to GCCLEAN *
;************************************************************************
%gcclean proc far
pop ret_sav1
pop ret_sav2
extrn gcclean:near
call gcclean
push ret_sav2
push ret_sav1
ret
%gcclean endp
ENDIF
;************************************************************************
;* ***Temporary Long Linkage to PRINTF*** *
;************************************************************************
public %printf,%sdebug
%printf proc far
pop ret_sav1
pop ret_sav2
extrn printf:near
call printf
push ret_sav2
push ret_sav1
ret
%printf endp
;************************************************************************
;* ***Temporary Long Linkage to SDEBUG*** *
;************************************************************************
%sdebug proc far
pop ret_sav1
pop ret_sav2
extrn sdebug:near
call sdebug
push ret_sav2
push ret_sav1
ret
%sdebug endp
prog ends
PROGX segment byte public 'PROGX'
assume CS:XGROUP
extrn srelocat:near ; pointer relocation routine
extrn toggleGC:near ; complement GC bits
;************************************************************************
;* Garbage Collection -- Compaction Phase *
;************************************************************************
sq_args struc
sq_free dw NUMPAGES dup (?) ; amount of free space within each page
sq_plist dw NUMPAGES dup (?) ; list of pages
sq_BP dw ? ; caller's BP register
dw ? ; caller's ES register
dd ? ; return address (far call)
dw ? ; return address (near call)
sq_args ends
%squish proc far
push ES ; save caller's ES register
push BP ; and BP register
sub SP,offset sq_BP ; allocate local storage
mov BP,SP ; and establish addressability
; Compute the amount of free space in each page
lea BX,[BP].sq_free ; load address of size array
push BX ; and push as argument to "sum_space"
call %sumspac ; determine available space in each page
mov SP,BP ; drop argument from TIPC's stack
; Initialize table of page numbers
mov AX,DS ; make ES point to the data
mov ES,AX ; segment
mov CX,NUMPAGES ; load page count
lea DI,[BP].sq_plist ; load address of page number table
xor AX,AX ; initialize page number index to zero
pt_loop: stosw ; set page number to current position
add AX,WORDINCR ; increment page index
loop pt_loop ; process all page numbers
; Reset the similar page type chain headers
mov CX,NUMTYPES
mov AX,END_LIST
mov DI,offset pagelist
rep stosw
; Sort list of pages according to size available
mov DX,DEDPAGES*WORDINCR
sort_nxt: mov SI,DX
mov DI,[BP].sq_plist+[SI]
mov AX,[BP].sq_free+[DI] ; load amount of space in base page
sort_mor: add SI,WORDINCR ; increment inner loop index
mov DI,[BP].sq_plist+[SI] ; load page index
cmp AX,[BP].sq_free+[DI] ; has current page less space?
jbe sort_no ; if not, jump
mov AX,[BP].sq_free+[DI] ; load size of smaller free space
mov DI,DX
mov CX,[BP].sq_plist+[SI] ; exchange base page index
xchg CX,[BP].sq_plist+[DI] ; with current page
mov [BP].sq_plist+[SI],CX ; index
sort_no: cmp SI,NUMPAGES*WORDINCR-WORDINCR ; is inner loop complete?
jl sort_mor ; if not, jump
add DX,WORDINCR ; increment outer loop index
cmp DX,NUMPAGES*WORDINCR-WORDINCR ; is outer loop complete?
jl sort_nxt ; if not, keep on loopin'
; Update the similar page type chains
mov DI,DEDPAGES*WORDINCR
spt_loop: mov SI,[BP].sq_plist+[DI]
test attrib+[SI],NOMEMORY
jnz spt_end
mov BX,ptype+[SI]
mov AX,pagelist+[BX]
mov pagelink+[SI],AX
mov AX,SI
CORRPAGE AX
mov pagelist+[BX],AX
spt_end: add DI,WORDINCR
cmp DI,NUMPAGES*WORDINCR
jl spt_loop
IFDEF EXPMEM
call %gcclean ; Clean out Emm Page table for compaction
ENDIF
; Note: If printing messages, make ES point to the data segment
;;; mov AX,DS ;* Make ES point to the data
;;; mov ES,AX ;* segment
; Compact List Cells
;;; mov AX,offset msg1a ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting list cells
call sq_list
; Compact Flonums
;;; mov AX,offset msg1b ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting flonums
call sq_flo
; Compact Bignums
;;; mov AX,offset msg1c ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting bignums
mov AX,BIGTYPE*2 ; load type code index for bignums
push AX ; and push as argument to "sq_var"
call sq_var
mov SP,BP ; drop arguments from stack
; Compact Closures
;;; mov AX,offset msg1d ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting closures
mov AX,CLOSTYPE*2 ; load type code index for closures
push AX ; and push as argument to "sq_var"
call sq_var
mov SP,BP ; drop arguments from stack
; Compact Code Blocks
;;; mov AX,offset msg1e ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting code blocks
mov AX,CODETYPE*2 ; load type index for code blocks
push AX ; and push as argument to "sq_var"
call sq_var
mov SP,BP ; drop arguments from stack
; Compact Vectors
;;; mov AX,offset msg1f ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting vectors
mov AX,VECTTYPE*2 ; load type index for vectors
push AX ; and push as argument to "sq_var"
call sq_var
mov SP,BP ; drop arguments from stack
; Compact Continuations
;;; mov AX,offset msg1g ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting continuations
mov AX,CONTTYPE*2 ; load type index for continuations
push AX ; and push as argument to "sq_var"
call sq_var
mov SP,BP ; drop arguments from stack
;;; Note: Let's not compact symbols for now. There are a few "special"
;;; symbols which mess things up in the runtime support if they
;;; move. Notably, CONSOLE_ and QUOTE_reg(?)
;;;; Compact Symbols
;;; mov AX,offset msg1h ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting symbols
;;; mov AX,SYMTYPE*2 ; load type index for symbols
;;; push AX ; and push as argument to "sq_var"
;;; call sq_var
;;; mov SP,BP ; drop arguments from stack
; Compact Strings
;;; mov AX,offset msg1i ;*
;;; push AX ; * print message indicating we're
;;; call %printf ;* compacting strings
mov AX,STRTYPE*2 ; load type index for strings
push AX ; and push as argument to "sq_var"
call sq_var
mov SP,BP ; drop arguments from stack
; Relocate all moved pointers
;;; mov AX,offset msg2 ;*
;;; push AX ; * print a message that we're about
;;; call %printf ;* to perform pointer relocation
call srelocat ; relocate all pointers
; Toggle the GC bits used to denote forwarding
;;; mov AX,offset msg3 ;*
;;; push AX ; * print a message that we're
;;; call %printf ; * complementing the GC bits
call toggleGC ; complement the GC (forwarding) bits
IFDEF EXPMEM
call %gcclean ; Clean out Emm Page table
ENDIF
; Invoke the "sweep" portion of the garbage collector to reclaim memory
;;; mov AX,offset msg4 ;*
;;; push AX ; * print a message that it's
;;; call %printf ; * "sweep" time
call %gcsweep ; reclaim all freed memory
; Return to caller
mov SP,BP ; deallocate stack temporaries
add SP,offset sq_BP ; release local storage
pop BP ; restore caller's BP register
pop ES ; and ES register
ret ; return
%squish endp
;************************************************************************
;* Macro Support for List/Flonum Compaction *
;* *
;* Register usage during "move" phase of this routine: *
;* AX - backward chain header (destination page index) *
;* BX - (scratch register) *
;* CX - word count for block move *
;* DX - forward chain header (source page index) *
;* DS:[SI] - source list cell *
;* ES:[DI] - destination list cell *
;************************************************************************
sql_arg struc
sql_rev dw NUMPAGES dup (?) ; reversed linked list of list pages
sql_bptr dw ? ; reversed list header
sql_BP dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; return address
sql_type dw ? ; type code index (for variable len objects)
sql_arg ends
sq_L_F macro uppercase,lowercase
local sql_go,sql_010,sql_020,sql_025,sql_030,sql_035
local sql_040,sql_050,sql_060,sql_070,sql_done,sql_ret
push ES ; save caller's ES
push BP ; save caller's BP
sub SP,offset sql_BP ; allocate local storage
mov BP,SP ; establish local addressability
; Create a reverse order linked list of pages
lea BX,[BP].sql_rev ; load addr of reverse linked list array
mov AX,uppercase&TYPE*2 ; load type code
pushm <AX,BX> ; push type code, array addr as arguments
call sq_rever ; create the reverse linked list
mov SP,BP ; drop arguments off TIPC's stack
cmp AX,END_LIST ; is list of pages empty?
jne sql_go ; if list non-empty, continue (jump)
jmp sql_ret ; if empty list, return
sql_go: ADJPAGE AX ; convert list header to page index value
; Move list cells from least dense pages to most dense pages
mov DX,lowercase&page ; load page number of least dense
ADJPAGE DX ; page and convert to page index
mov BX,DX ; copy page index into BX
push DS ; save DS register
; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
; * * * WARNING: The DS Register Doesn't Point to the Data Segment * * *
; * * * in the code which follows: * * *
; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
%LoadPage0 DS,BX ; load paragraph address of source page
mov SI,-uppercase&SIZE ; load source page index
jmp short sql_020 ; jump
; Follow backward chain to get new destination page
sql_010: mov BX,AX ; set next available cell address to
mov SS:nextcell+[BX],DI ; END_LIST
mov BX,BP ; calculate address of current element in
add BX,AX ; reversed page list
mov AX,SS:[BX].sql_rev ; load next page in backward chain
ADJPAGE AX ; convert page number to page index
sql_020: cmp AX,DX ; another destination page available?
jne sql_025
jmp sql_done ; if source page = destination page, jump
sql_025:
mov BX,AX ; copy destination page index to BX
%LoadPage1 ES,BX ; load paragraph address of dest page
mov DI,SS:nextcell+[BX] ; load free cell header
IFDEF EXTMEM
mov BX,DX ; reload dest. page so it won't ever
%LoadPage0 DS,BX ; get swapped out
ENDIF
; Make sure a cell is available in the destination page
sql_030: cmp DI,END_LIST
je sql_010
; Is there a cell to move from the source page?
sql_040: mov BX,DX
mov BX,SS:psize+[BX] ; load the page size and
sub BX,uppercase&SIZE ; compute end of page boundary
sql_050: add SI,uppercase&SIZE ; increment source page offset
cmp SI,BX ; end of source page?
ja sql_070 ; if end of page, jump
cmp [SI].car_page,0FFh ; is this cell referenced?
je sql_050 ; if an unreferenced cell, jump
; Move the cell from source page to destination page
sql_060: mov BX,ES:[DI].car ; load offset of next free cell in dest page
IF uppercase&SIZE - (uppercase&SIZE/2)*2
mov CX,uppercase&SIZE
rep movsb
ELSE
mov CX,uppercase&SIZE/WORDINCR ; load number of words to move
rep movsw ; copy the contents of the list cell
ENDIF
sub SI,uppercase&SIZE ; back up the source and destination
sub DI,uppercase&SIZE ; pointers
IFIDN <uppercase>,<LIST>
mov [SI].car_page,AL ; store a forwarding pointer into the car
mov [SI].car,DI ; field of the source list cell
ELSE
IFIDN <uppercase>,<FLO>
mov [SI].flo_data,AL
mov word ptr [SI].flo_data+1,DI
ELSE
OOPS invalid data type: uppercase
ENDIF
ENDIF
or byte ptr [SI].&lowercase&_gc,GC_BIT ; set GC bit to indicate
; forward
mov DI,BX ; copy next free cell offset into DI
jmp sql_030 ; process next move
; Follow forward pointer to get a next source page
sql_070: mov BX,DX ; copy forward chain header to BX
mov DX,SS:pagelink+[BX] ; load next page in forward chain
ADJPAGE DX ; convert page number to page index
mov BX,DX
%LoadPage0 DS,BX ; load paragraph address of source page
IFDEF EXTMEM
mov BX,AX ; reload dest. page so it won't ever
%LoadPage1 ES,BX ; get swapped out
ENDIF
mov SI,-uppercase&SIZE ; initialize source page index
cmp AX,DX ; does source page = destination page?
je sql_035
jmp sql_040 ; if not, keep on moving cells (jump)
sql_035:
; No more cells to move-- update destination page available cell header
mov BX,AX ; update next available cell pointer
mov SS:nextcell+[BX],DI ; in the destination page
; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
; * * * WARNING: The DS Register Doesn't Point to the Data Segment * * *
; * * * in the code above * * *
; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
; Copying complete
sql_done: pop DS ; restore data segment register (DS)
sql_ret: mov SP,BP ; clean up TIPC's stack
add SP,offset sql_BP ; deallocate local storage
pop BP ; restore caller's BP
pop ES ; restore caller's ES
ret ; return to caller
endm
;************************************************************************
;* List Cell Compaction *
;************************************************************************
sq_list proc near
sq_L_F LIST,list
sq_list endp
;************************************************************************
;* Flonum Compaction *
;************************************************************************
sq_flo proc near
sq_L_F FLO,flo
sq_flo endp
;************************************************************************
;* Variable Length Object Compaction *
;* *
;* Register usage during "move" phase of this routine: *
;* AX - backward chain header (destination page index) *
;* BX - (scratch register) *
;* CX - word count for block move *
;* DX - forward chain header (source page index) *
;* DS:[SI] - source list cell *
;* ES:[DI] - destination list cell *
;* *
;* Notes: *
;* *
;* 1. Any object which is less than 6 bytes in length cannot be moved *
;* because there's no place to put a forwarding pointer. If a *
;* page is encountered with such an object (e.g., a zero length *
;* vector) that object, and the remaining objects in that page are *
;* not copied. Processing continues with the next source page. *
;* *
;* 2. The current code block cannot be relocated, since the offset *
;* into the current code block is held in register SI in most of *
;* the code of the Scheme Virtual Machine emulator. Since it is *
;* not possible to update this offset, the page containing the *
;* current code block is skipped, if encountered during *
;* compaction. *
;************************************************************************
sq_var proc near
push ES ; save caller's ES
push BP ; save caller's BP
sub SP,offset sql_BP ; allocate local storage
mov BP,SP ; establish local addressability
; Create a reverse order linked list of pages
lea BX,[BP].sql_rev ; load addr of reverse linked list array
pushm <[BP].sql_type,BX> ; push type code, array addr as arguments
call sq_rever ; create the reverse linked list
mov SP,BP ; drop arguments off TIPC's stack
cmp AX,END_LIST ; is list of pages empty?
jne sqv_020 ; if list non-empty, continue (jump)
sqv_010: jmp sqv_ret ; if empty list, return
sqv_020: ADJPAGE AX ; convert list header to page index value
mov [BP].sql_bptr,AX ; save destination list header
; Move list cells from least dense pages to most dense pages
mov BX,[BP].sql_type ; load type index for page type
mov DX,pagelist+[BX] ; load page number of least dense
ADJPAGE DX ; page and convert to page index
cmp AX,DX ; destination page available?
je sqv_010 ; if source page = destination page, jump
mov BX,DX ; copy page index into BX
push DS ; save DS register
; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
; * * * WARNING: The DS Register Doesn't Point to the Data Segment * * *
; * * * in the code which follows: * * *
; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
cmp DL,byte ptr CB_pag ; does page contain current code block?
je sqv_052 ; if so, skip it
IFDEF EXPMEM
cmp psize+[BX],MIN_PAGESIZE ; page size greater than minimum?
jne sqv_052
ENDIF
%LoadPage0 DS,BX ; load paragraph address of source page
;;; mov DS,pagetabl,[BX] ; load paragraph address of source page
xor SI,SI ; load source page index
; Is there an object to move from the source page?
sqv_040: mov BX,DX
mov BX,SS:psize+[BX] ; load the page size and
sub BX,BLK_OVHD ; compute end of page boundary
sqv_050: cmp SI,BX ; end of source page?
ja sqv_052 ; if end of page, jump
cmp [SI].car_page,FREETYPE ; is this object referenced?
jne sqv_060 ; if a referenced object, jump
add SI,[SI].vec_len
jmp sqv_050
sqv_052: jmp sqv_070 ; process next source page
; Find next possible destination page
sqv_054: mov BX,AX
add BX,BP
mov AX,SS:[BX].sql_rev
ADJPAGE AX
cmp AX,DX
jne sqv_061
jmp sqv_done
; Find a block into which to move the referenced object
sqv_060: mov CX,[SI].vec_len ; load length of object
cmp CX,0 ;;; check for small string
jge sqv_001
mov CX,BLK_OVHD+PTRSIZE ;;; get the right value
sqv_001: cmp CX,BLK_OVHD+PTRSIZE ; is object "too small" to relocate?
jae sqv001
jmp sqv_070 ; if "too small", abandon this page
sqv001: mov AX,[BP].sql_bptr ; load destination page list header
sqv_061: mov BX,AX ; copy index for destination page
IFDEF EXPMEM
cmp psize+[BX],MIN_PAGESIZE ; page size greater than minimum?
jne sqv_054
ENDIF
%LoadPage1 ES,BX ; load paragraph address of dest page
IFDEF EXTMEM
%LoadPage0 DS,DX ; reload src page so it won't get swapped out
ENDIF
xor DI,DI ; page and initialize its index pointer
mov BX,SS:psize+[BX] ; load page size and
sub BX,BLK_OVHD ; adjust for boundary check
jmp short sqv_064 ; jump over increment
sqv_062: cmp ES:[DI].vec_len,0 ;;; check for small string
jge sqv_002
add DI,BLK_OVHD+PTRSIZE ;;; add the exact length
jmp sqv_064
sqv_002: add DI,ES:[DI].vec_len ; advance destination page index
sqv_064: cmp DI,BX ; end of page?
ja sqv_054 ; if end of page, jump
cmp ES:[DI].vec_type,FREETYPE ; free block?
jne sqv_062 ; if not a free block, keep looking (jump)
; Free block found-- is it big enough?
cmp CX,ES:[DI].vec_len
ja sqv_062
je sqv_068 ; if an exact fit, jump
sub CX,ES:[DI].vec_len
neg CX
cmp CX,BLK_OVHD
jge sqv_066
mov CX,[SI].vec_len
cmp CX,0 ;;; check for small string
jge sqv_062
mov CX,BLK_OVHD+PTRSIZE ;;; get the right value
jmp sqv_062
sqv_066: cmp [SI].vec_len,0 ;;; check for small string
jge sqv_003
add DI,BLK_OVHD+PTRSIZE ;;; add the right value
jmp sqv_004
sqv_003: add DI,[SI].vec_len
sqv_004: mov ES:[DI].vec_type,FREETYPE
mov ES:[DI].vec_len,CX
mov CX,[SI].vec_len
cmp CX,0 ;;; check for small string
jge sqv_005
mov CX,BLK_OVHD+PTRSIZE
sqv_005: sub DI,CX
; Move the cell from source page to destination page
sqv_068: mov BX,CX ; save the number of bytes moved
rep movsb ; copy object from source page to dest page
sub SI,BX ; back up the source and destination
sub DI,BX ; pointers
mov [SI].vec_page,AL ; store a forwarding pointer into the car
mov [SI].vec_disp,DI ; field of the source object
or byte ptr [SI].vec_gc,GC_BIT ; set GC bit to indicate forward
add SI,BX ; advance source page index to next object
sqv_069: jmp sqv_040 ; process next move
; Follow forward pointer to get a next source page
sqv_070: mov BX,DX ; copy forward chain header to BX
mov DX,SS:pagelink+[BX] ; load next page in forward chain
ADJPAGE DX ; convert page number to page index
cmp AX,DX ; source = destination? ;rb for tc
je sqv_done ; yes, jump ;rb for tc
cmp DL,SS:byte ptr CB_pag ; current code block in this page?
je sqv_070 ; we can't relocate the current code block
mov BX,DX
IFDEF EXPMEM
cmp psize+[BX],MIN_PAGESIZE ; page size greater than minimum?
jne sqv_070
ENDIF
%LoadPage0 DS,BX ; load paragraph address of source page
IFDEF EXTMEM
%LoadPage1 ES,AX ; reload dest page so it won't get swapped
ENDIF
xor SI,SI ; initialize source page index
cmp AX,DX ; does source page = destination page?
jne sqv_069 ; if not, keep on moving objects (jump)
; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
; * * * WARNING: The DS Register Doesn't Point to the Data Segment * * *
; * * * in the code above * * *
; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
; Copying complete
sqv_done: pop DS ; restore data segment register (DS)
sqv_ret: mov SP,BP ; clean up TIPC's stack
add SP,offset sql_BP ; deallocate local storage
pop BP ; restore caller's BP
pop ES ; restore caller's ES
ret ; return to caller
sq_var endp
;************************************************************************
;* Local Support-- Create Reverse Linked List *
;* *
;* Purpose: To create a reversed copy of the similar page list for *
;* pages of a given type. *
;* *
;* Calling Sequence: header = sq_rever(dest_array, type_index) *
;* header = header pointer of reversed list. *
;* dest_array = array to hold the pointers of the reversed *
;* linked list. *
;* type_index = type index (type*2) of the page type for *
;* which the similar page linked list is *
;* to be reversed (e.g., LISTTYPE*2 causes *
;* the linked list for list cell pages to *
;* be reversed. *
;************************************************************************
sqr_args struc
dw ? ; caller's BP
dw ? ; return address
sqr_ary dw ? ; pointer to reversed list array
sqr_typ dw ? ; type code for desired page type
sqr_args ends
sq_rever proc near
push BP ; save caller's BP
mov BP,SP ; establish addressability
mov BX,[BP].sqr_ary ; load address of destination array
mov SI,[BP].sqr_typ ; load type code for list to reverse
mov SI,pagelist+[SI] ; load list header to appropriate page type
mov AX,END_LIST ; load an end of list indicator
sqr_loop: cmp SI,END_LIST ; end of list?
je sqr_ret ; if end of list, return
mov DX,SI ; save current page number in DX
ADJPAGE SI ; convert page number to page index
mov [BX]+[SI],AX ; store prev page number into reversed array
mov SI,pagelink+[SI] ; fetch next page in linked list
mov AX,DX ; prev page number <- current page number
jmp sqr_loop ; continue 'til end of list
sqr_ret: pop BP ; restore caller's BP
ret ; return with reversed list header in AX
sq_rever endp
PROGX ends
prog segment byte public 'PROG'
assume CS:PGROUP
;************************************************************************
;* Long Linkage to gcsquish *
;* *
;* Note: The lines which are commented out in the following code were *
;* used to print the "* compacting memory *" message in the *
;* who-line. Since it's a real pain in the a.. to allow the *
;* user to change the GC messages, it was decided that no *
;* message was the best way to go. *
;************************************************************************
public gcsquish
gcsquish proc near
push ES ; save caller's ES register
push BP ; save caller's BP register
mov BP,SP
mov AX,DS ; make sure ES points to the data segment
mov ES,AX
C_call gc_on ; light up the "garbage collecting" message
;;; mov AX,offset msg ; load address of compaction message
;;; push AX ; and push as argument
;;; C_call who_writ ; display "compacting memory" message
;;; mov SP,BP ; drop argument from stack
call %squish ; perform memory compaction
C_call gc_off ; reset the garbage collection message
pop BP ; restore caller's BP
pop ES ; restore caller's ES
ret ; return to caller
gcsquish endp
prog ends
end


1359
srch_str.asm Normal file
View File

File diff suppressed because it is too large Load Diff

490
srelocat.asm Normal file
View File

@ -0,0 +1,490 @@
; =====> SRELOCAT.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* GC Pointer Relocation Routines *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 23 September 1985 *
;* Last Modification: 18 October 1985 *
;***************************************
include scheme.equ
DGROUP group data
XGROUP group PROGX
PGROUP group prog
data segment word public 'DATA'
assume DS:DGROUP
msg_relp db "[VM INTERNAL ERROR] rel_ptr: invalid %x:%04x (unadjusted)"
db LF,0
page_sav dw ? ; Page number save area
; Branch table for processing each data type
btable dw rel_list ; [0] List cells
dw rel_fix ; [1] Fixnums
dw rel_flo ; [2] Flonums
dw rel_big ; [3] Bignums
dw rel_sym ; [4] Symbols
dw rel_str ; [5] Strings
dw rel_ary ; [6] Arrays
dw rel_cont ; [7] Continuations
dw rel_clos ; [8] Closures
dw rel_free ; [9] Free space (unallocated)
dw rel_code ; [10] Code
dw rel_ref ; [11] Reference cells
dw rel_port ; [12] Port data objects
dw rel_char ; [13] Characters
dw rel_env ; [14] Environments
ctable dw rep_list ; [0] List cells
dw rep_fix ; [1] Fixnums
dw rep_flo ; [2] Flonums
dw rep_big ; [3] Bignums
dw rep_sym ; [4] Symbols
dw rep_str ; [5] Strings
dw rep_ary ; [6] Arrays
dw rep_cont ; [7] Continuations
dw rep_clos ; [8] Closures
dw rep_free ; [9] Free space (unallocated)
dw rep_code ; [10] Code
dw rep_ref ; [11] Reference cells
dw rep_port ; [12] Port data objects
dw rep_char ; [13] Characters
dw rep_env ; [14] Environments
dtable dw fwd_list ; [0] List cells
dw fwd_fix ; [1] Fixnums
dw fwd_flo ; [2] Flonums
dw fwd_big ; [3] Bignums
dw fwd_sym ; [4] Symbols
dw fwd_str ; [5] Strings
dw fwd_ary ; [6] Arrays
dw fwd_cont ; [7] Continuations
dw fwd_clos ; [8] Closures
dw fwd_free ; [9] Free space (unallocated)
dw fwd_code ; [10] Code
dw fwd_ref ; [11] Reference cells
dw fwd_port ; [12] Port data objects
dw fwd_char ; [13] Characters
dw fwd_env ; [14] Environments
data ends
prog segment byte public 'PROG'
assume CS:PGROUP
extrn %printf:far
;************************************************************************
;* Far Linkage to FORCE_DEBUG *
;************************************************************************
%forcede proc far
extrn force_de:near
call force_de
ret
%forcede endp
prog ends
PROGX segment byte public 'PROGX'
assume CS:XGROUP
;************************************************************************
;* Garbage Collection -- Pointer Relocation Phase *
;************************************************************************
public srelocat
srelocat proc near
push ES ; save caller's ES register
push BP ; and BP register
mov BP,SP ; and establish addressability
; relocate the pointers within each page
mov BX,DEDPAGES*WORDINCR ; initialize page counter
srel_lop: test attrib+[BX],NOMEMORY
jnz srel_nxt
mov DI,SS:ptype+[BX] ; get data type for page
cmp DI,FREETYPE*2 ; Free Page?
je srel_nxt ; Yes...continue
push BX ; save the page counter
call rel_page ; relocate pointers in current page
pop BX ; restore page counter
srel_nxt: add BX,WORDINCR ; increment page counter
cmp BX,NUMPAGES*WORDINCR ; all pages processed?
jb srel_lop ; if more pages, jump
; relocate registers R1-R63
xor BX,BX ; clear BX
mov CX,NUM_REGS-1 ; load number of registers ('cept for R0)
mov DI,offset reg0 + size C_ptr ; load address of R1
srel_reg: call rel_reg ; relocate register Rn
add DI,size C_ptr ; increment pointer to next reigster
loop srel_reg ; loop until R1-R63 relocated
; relocate the other internal registers
mov DI,offset FNV_reg
call rel_reg ; relocate FNV_reg
mov DI,offset GNV_reg
call rel_reg ; relocate GNV_reg
mov DI,offset PREV_reg
call rel_reg ; relocate PREV_reg
mov DI,offset CB_reg
call rel_reg ; relocate CB_reg
mov DI,offset TRNS_reg
call rel_reg ; relocate TRNS_reg
mov DI,offset tmp_reg
call rel_reg ; relocate tmp_reg
mov DI,offset tm2_reg
call rel_reg ; relocate tm2_reg
mov DI,offset FNV_save
call rel_reg ; relocate FNV_save
mov DI,offset STL_save
call rel_reg ; relocate STL_save
; relocate the system oblist and the property lists
mov CX,HT_SIZE ; load iteration count
xor DX,DX ; zero the index
rel_tab: mov DI,DX ; copy loop index to DI
mov BL,hash_pag+[DI] ; fetch hash table entry page number
shl DI,1 ; double index value for use as word index
mov SI,hash_dis+[DI] ; fetch hash table entry displacement
call rel_ptr ; relocate the pointer
mov hash_dis+[DI],SI ; store the relocated
mov SI,DX ; pointer back into the
mov hash_pag+[SI],BL ; system hash table
mov BL,prop_pag+[SI] ; fetch property list entry page number
mov SI,prop_dis+[DI] ; and displacement
call rel_ptr ; relocate the property list entry pointer
mov prop_dis+[DI],SI ; store the relocated
mov DI,DX ; pointer back into the
mov prop_pag+[DI],BL ; system property list table
inc DX ; increment the loop index
loop rel_tab ; continue 'til all entries processed
; Relocate the pointers in the runtime stack
mov DI,offset S_stack ; load address of stack buffer
mov DX,TOS ; load current top of stack and
add DX,DI ; compute stack's ending address
rel_stk: mov BL,[DI].car_page ; load next stack entry from the
mov SI,[DI].car ; stack buffer
call rel_ptr ; relocate the pointer
mov [DI].car_page,BL ; store the relocated pointer back into
mov [DI].car,SI ; the stack buffer
add DI,PTRSIZE ; increment the stack buffer pointer
cmp DI,DX ; end of active stack buffer?
jbe rel_stk ; if more entries in stack, jump
; Relocate the pointers in the object hash table
mov CX,OHT_SIZE ; load count of object hash table entries
mov DI,offset obj_ht ; load address of object hash table
rel_oht: mov BL,[DI].car_page ; load next entry in the
mov SI,[DI].car ; object hash table
call rel_ptr ; relocate the pointer
mov [DI].car_page,BL ; store the relocated pointer back
mov [DI].car,SI ; into the object hash table
add DI,PTRSIZE ; increment the loop index
loop rel_oht ; continue until all entries processed
; Return to caller
rel_rtn: pop BP ; restore caller's BP register
pop ES ; and ES register
ret ; return
srelocat endp
;************************************************************************
;* Local Support-- Relocate pointers in a single page *
;************************************************************************
rel_page proc near
mov page_sav,BX ; Save this page number
%LoadPage ES,BX ; load the page's paragraph address
;;; mov ES,pagetabl+[BX] ; load the page's paragraph address
mov DX,psize+[BX] ; load the current page size
sub DX,PTRSIZE ; and adjust for end of page boundary
mov SI,ptype+[BX]
xor DI,DI ; zero the page index
xor BX,BX ; zero BX
jmp btable+[SI]
rel_list: ; [0] List cells
sub DX,LISTSIZE-PTRSIZE
rel_l010: mov BL,ES:[DI].car_page ; fetch the car field's page number
cmp BL,0FFh ; unused list cell?
je rel_l020 ; if unused, jump
test byte ptr ES:[DI].list_gc,GC_BIT ; is this a relocated pointer?
jnz rel_l020 ; if a relocated ptr, leave it alone
mov SI,ES:[DI].car ; fetch the car field's displacement field
call rel_ptr ; relocate the pointer
%LoadPage ES,page_sav ; Re-load source page
mov ES:[DI].car_page,BL ; store the relocated car pointer
mov ES:[DI].car,SI ; back into the list cell
mov BL,ES:[DI].cdr_page ; fetch the cdr field from
mov SI,ES:[DI].cdr ; the list cell
call rel_ptr ; relocate the pointer
%LoadPage ES,page_sav ; Re-load source page
mov ES:[DI].cdr_page,BL ; store the relocated cdr pointer
mov ES:[DI].cdr,SI ; back into the list cell
rel_l020: add DI,LISTSIZE ; increment the page index
cmp DI,DX ; end of page?
jbe rel_l010 ; if more list cells to process, jump
jmp rel_ret ; return
rel_sym: ; [4] Symbols
rel_port: ; [12] Port data objects
rel_s010: cmp ES:[DI].sym_type,FREETYPE ; free block?
je rel_s020 ; if free block, jump
test ES:[DI].sym_gc,GC_BIT ; is this a relocated object?
jnz rel_s020 ; if a forwarding pointer, jump
mov BL,ES:[DI].sym_page ; load pointer operand from the
mov SI,ES:[DI].sym_disp ; port or symbol object
call rel_ptr ; relocate the pointer, if needed
%LoadPage ES,page_sav ; Re-load source page
mov ES:[DI].sym_page,BL ; store relocated pointer back in
mov ES:[DI].sym_disp,SI ; the port or symbol
rel_s020: add DI,ES:[DI].sym_len ; increment the page index
cmp DI,DX ; end of page?
jbe rel_s010 ; if not end of page, jump
jmp rel_ret ; return
rel_code: ; [10] Code
rel_c010: cmp ES:[DI].cod_type,FREETYPE ; is this a free block?
je rel_c030 ; if unused block, jump
test ES:[DI].cod_gc,GC_BIT ; is this a relocated code block?
jnz rel_c030 ; if a forwarding pointer, jump
mov AX,DI ; save starting offset of object
mov CX,ES:[DI].cod_entr ; load the entry point
add CX,DI ; and compute ending offset
sub CX,BLK_OVHD+PTRSIZE
jmp short rel_c025 ; test for code block with no constants
rel_c020: mov BL,ES:[DI].cod_cpag ; load next pointer from the
mov SI,ES:[DI].cod_cdis ; object
call rel_ptr ; relocate pointer, if needed
%LoadPage ES,page_sav ; Re-load source page
mov ES:[DI].cod_cpag,BL ; store the relocated pointer
mov ES:[DI].cod_cdis,SI ; back into the object
add DI,PTRSIZE ; increment the page index
rel_c025: cmp DI,CX ; all pointers updated?
jb rel_c020 ; if more pointers, jump
mov DI,AX ; restore starting offset of object
rel_c030: add DI,ES:[DI].cod_len ; adjust index for free area
cmp DI,DX ; end of page?
jbe rel_c010 ; if not end of page, jump
jmp rel_ret ; return
rel_ary: ; [6] Arrays
rel_cont: ; [7] Continuations
rel_clos: ; [8] Closures
rel_env: ; [14] Environments
rel_v010: cmp ES:[DI].vec_type,FREETYPE ; is this a free block?
je rel_v030 ; if unused block, jump
test ES:[DI].vec_gc,GC_BIT ; has object been relocated?
jnz rel_v030 ; if a forwarding pointer, jump
mov AX,DI ; save starting offset of object
mov CX,ES:[DI].vec_len ; load the object's length
add CX,DI ; and compute ending offset
sub CX,BLK_OVHD ; adjust ending offset for block header
jmp short rel_v025 ; test for zero length object
rel_v020: mov BL,ES:[DI].vec_page ; load next pointer from the
mov SI,ES:[DI].vec_disp ; object
call rel_ptr ; relocate pointer, if needed
%LoadPage ES,page_sav ; Re-load source page
mov ES:[DI].vec_page,BL ; store the relocated pointer
mov ES:[DI].vec_disp,SI ; back into the object
add DI,PTRSIZE ; increment the page index
rel_v025: cmp DI,CX ; all pointers updated?
jb rel_v020 ; if more pointers, jump
mov DI,AX ; restore starting offset of object
rel_v030: add DI,ES:[DI].vec_len ; adjust index for free area
cmp DI,DX ; end of page?
jbe rel_v010 ; if not end of page, jump
jmp rel_ret ; return
rel_fix: ; [1] Fixnums
rel_flo: ; [2] Flonums
rel_big: ; [3] Bignums
rel_str: ; [5] Strings
rel_free: ; [9] Free space (unallocated)
rel_ref: ; [11] Reference cells (hope not...)
rel_char: ; [13] Characters
rel_ret: ret ; return to caller
rel_page endp
;************************************************************************
;* Local Support-- Relocate a pointer contained in a register *
;* *
;* Parameters: DI - address of register *
;************************************************************************
rel_reg proc near
xor BX,BX ; clear BX
mov BL,byte ptr [DI].C_page ; fetch the register's
mov SI,[DI].C_disp ; contents
call rel_ptr ; relocate the pointer
mov byte ptr [DI].C_page,BL ; store the relocated pointer
mov [DI].C_disp,SI ; back into the register
ret ; return
rel_reg endp
;************************************************************************
;* Local Support-- Relocate a single pointer *
;* *
;* Parameters: BX - page number index (page*2) *
;* SI - displacement *
;************************************************************************
rel_ptr proc near
cmp BX,DEDPAGES*WORDINCR ; is this a special non-GCed page?
jl rep_ret1 ; if special page, no relocation done
push ES ; save caller's ES
push DI ; and save caller's DI
%LoadPage ES,BX ; load the paragraph address for ptr's page
;;; mov ES,pagetabl+[BX] ; load paragraph address for pointer's page
mov DI,ptype+[BX]
cmp DI,NUMTYPES*2
jae rel_oops
jmp ctable+[DI] ; jump according to pointer type
; ***error-- invalid type/length code***
rel_oops: pushm <AX,CX,DX,SI,BX> ; save registers; push page:disp
mov AX,offset msg_relp ; move address of "format"
push AX ; and push as argument to printf
mov AX,DS ; make ES point to the data segment
mov ES,AX
call %printf ; print the error message
call %forcede ; invoke the VM debugger with next instr.
popm <AX,BX,SI,DX,CX,AX> ; restore registers
jmp short rep_ret ; return
rep_list: ; [0] List Cells
test byte ptr ES:[SI].list_gc,GC_BIT ; has cell been relocated?
jz rep_ret ; if not moved, return (jump)
mov BL,ES:[SI].car_page ; replace original pointer with
mov SI,ES:[SI].car ; the updated pointer
and SI,07FFFh ; clear the GC bit
jmp short rep_ret ; return
rep_flo: ; [2] Flonums
test byte ptr ES:[SI].flo_gc,GC_bit ; has flonum been relocated?
jz rep_ret ; if not moved, return (jump)
mov BL,ES:[SI].flo_data ; replace original pointer with
mov SI,word ptr ES:[SI].flo_data+1 ; the updated pointer
jmp short rep_ret ; return
rep_big: ; [3] Bignums
rep_sym: ; [4] Symbols
rep_str: ; [5] Strings
rep_ary: ; [6] Arrays
rep_cont: ; [7] Continuations
rep_clos: ; [8] Closures
rep_code: ; [10] Code
rep_port: ; [12] Port data objects
rep_env: ; [14] Environments
test byte ptr ES:[SI].vec_gc,GC_bit ; has object been relocated?
jz rep_ret ; if not moved, return (jump)
mov BL,ES:[SI].vec_page ; replace original pointer with
mov SI,ES:[SI].vec_disp ; the updated pointer
jmp rep_ret ; return
rep_fix: ; [1] Fixnums
rep_free: ; [9] Free space (unallocated)
rep_ref: ; [11] Reference cells (hope not...)
rep_char: ; [13] Characters
rep_ret: pop DI ; restore caller's DI
pop ES ; restore caller's ES
rep_ret1: ret ; return to caller
rel_ptr endp
;************************************************************************
;* Complement GC (forwarding) Bits *
;************************************************************************
public toggleGC
toggleGC proc near
push ES ; save caller's ES register
push BP ; and BP register
mov BP,SP ; and establish addressability
mov BX,DEDPAGES*WORDINCR ; initialize page counter
togl_lop: test attrib+[BX],NOMEMORY
jnz togl_nxt
mov DI,SS:ptype+[BX] ; get data type for page
cmp DI,FREETYPE*2 ; Free Page?
je togl_nxt ; Yes...continue
push BX ; save the page counter
call togl_pag ; complement GC bits in current page
pop BX ; restore page counter
togl_nxt: add BX,WORDINCR ; increment page counter
cmp BX,NUMPAGES*WORDINCR ; all pages processed?
jb togl_lop ; if more pages, jump
mov SP,BP
pop BP
pop ES
ret
toggleGC endp
togl_pag proc near
%LoadPage ES,BX ; load the page's paragraph address
;;; mov ES,pagetabl+[BX] ; load the page's paragraph address
mov DX,psize+[BX] ; load the current page size
sub DX,PTRSIZE ; and adjust for end of page boundary
mov SI,ptype+[BX]
xor DI,DI ; zero the page index
xor BX,BX ; zero BX
jmp dtable+[SI]
fwd_list: ; [0] List cells
sub DX,LISTSIZE-PTRSIZE
fwd_l010: cmp ES:[DI].car_page,0FFh ; unused list cell?
je fwd_l020 ; if unused, jump
xor byte ptr ES:[DI].list_gc,GC_BIT ; toggle the GC (forward) bit
fwd_l020: add DI,LISTSIZE ; increment the page index
cmp DI,DX ; end of page?
jbe fwd_l010 ; if more list cells to process, jump
jmp togl_ret ; return
fwd_flo: ; [2] Flonums
sub DX,FLOSIZE-PTRSIZE
fwd_f010: cmp byte ptr ES:[DI].flo_type,0FFh ; unused flonum?
je fwd_f020 ; if unused, jump
xor byte ptr ES:[DI].flo_gc,GC_BIT ; toggle the GC (forward) bit
fwd_f020: add DI,FLOSIZE ; increment the page index
cmp DI,DX ; end of page?
jbe fwd_f010 ; if more flonums to process, jump
jmp togl_ret ; return
fwd_str: ; [5] Strings
fwd_big: ; [3] Bignums
fwd_sym: ; [4] Symbols
fwd_ary: ; [6] Arrays
fwd_cont: ; [7] Continuations
fwd_clos: ; [8] Closures
fwd_code: ; [10] Code
fwd_port: ; [12] Port data objects
fwd_env: ; [14] Environments
fwd_v010: cmp ES:[DI].vec_type,FREETYPE ; is this a free block?
je fwd_v030 ; if unused block, jump
xor ES:[DI].vec_gc,GC_BIT ; toggle GC (forward) bit
fwd_v030: mov CX,ES:[DI].vec_len ; adjust index for free area
cmp CX,0 ;;; check for small string
jge fwd_v040
mov CX,BLK_OVHD+PTRSIZE
fwd_v040: add DI,CX
cmp DI,DX ; end of page?
jbe fwd_v010 ; if not end of page, jump
jmp togl_ret ; return
fwd_fix: ; [1] Fixnums
fwd_free: ; [9] Free space (unallocated)
fwd_ref: ; [11] Reference cells
fwd_char: ; [13] Characters
togl_ret: ret ; return to caller
togl_pag endp
PROGX ends
end


1807
sstack.asm Normal file
View File

File diff suppressed because it is too large Load Diff

518
sstring.asm Normal file
View File

@ -0,0 +1,518 @@
; =====> SSTRING.ASM
;************************************************************************
;* TIPC Scheme Runtime Support *
;* Interpreter -- String Operations *
;* *
;* (C) Copyright 1985 by Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 18 January 1985 *
;* Last Modification: *
;* 4/27/88 (tc) - removed case conversion from characters in the range *
;* of 128 through 167 (see locases, hicases, collate). *
;* Our previous assumptions did not work for some inter-*
;* national character sets. *
;************************************************************************
include scheme.equ
include sinterp.mac
include sinterp.arg
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
; Local data definitions
m_ch_eq db "CHAR=?",0
m_ceq_ci db "CHAR-CI=?",0
m_ch_lt db "CHAR<?",0
m_chl_ci db "CHAR-CI<?",0
m_ch_up db "CHAR-UPCASE",0
m_ch_dwn db "CHAR-DOWNCASE",0
m_mk_str db "MAKE-STRING",0
m_st_fl db "FILL-STRING!",0
m_st_ref db "STRING-REF",0
m_st_set db "STRING-SET!",0
m_one dw 1 ; a constant "one" (1)
m_two dw 2 ; a constant "two" (2)
m_soff dw STRING_OFFSET_ERROR ; error code
; Case tables (for characters between 40h and 0bfh)
public locases,hicases,collate
locases db 000,001,002,003,004,005,006,007
db 008,009,010,011,012,013,014,015
db 016,017,018,019,020,021,022,023
db 024,025,026,027,028,029,030,031
db " ","!",'"',"#","$","%","&","'"
db "(",")","*","+",",","-",".","/"
db "0","1","2","3","4","5","6","7"
db "8","9",":",";","<","=",">","?"
db "@","a","b","c","d","e","f","g"
db "h","i","j","k","l","m","n","o"
db "p","q","r","s","t","u","v","w"
db "x","y","z","[","\","]","^","_"
db "`","a","b","c","d","e","f","g"
db "h","i","j","k","l","m","n","o"
db "p","q","r","s","t","u","v","w"
db "x","y","z","{","|","}","~",127
; C .. ' ^ .. ` o c
; ' u e a a a a '
db 128,129,130,131,132,133,134,135 ;135,129,130,131,132,133,134,135
; ^ .. ` .. ^ ` .. o
; e e e i i i A A
db 136,137,138,139,140,141,142,143 ;136,137,138,139,140,141,132,134
; ' ^ .. ` ^ `
; E ae AE o o o u u
db 144,145,146,147,148,149,150,151 ;130,145,145,147,148,149,150,151
; .. .. ..
; y O U (currency symbols)
db 152,153,154,155,156,157,158,159 ;152,148,129,155,156,157,158,159
; ' ' ' ' ~ ~
; a i o u n N
db 160,161,162,163,164,165,166,167 ;160,161,162,163,164,164,166,167
db 168,169,170,171,172,173,174,175
db 176,177,178,179,180,181,182,183
db 184,185,186,187,188,189,190,191
db 192,193,194,195,196,197,198,199
db 200,201,202,203,204,205,206,207
db 208,209,210,211,212,213,214,215
db 216,217,218,219,220,221,222,223
; beta
db 224,225,226,227,228,229,230,231
db 232,233,234,235,236,237,238,239
db 240,241,242,243,244,245,246,247
db 248,249,250,251,252,253,254,255
hicases db 000,001,002,003,004,005,006,007
db 008,009,010,011,012,013,014,015
db 016,017,018,019,020,021,022,023
db 024,025,026,027,028,029,030,031
db " ","!",'"',"#","$","%","&","'"
db "(",")","*","+",",","-",".","/"
db "0","1","2","3","4","5","6","7"
db "8","9",":",";","<","=",">","?"
db "@","A","B","C","D","E","F","G"
db "H","I","J","K","L","M","N","O"
db "P","Q","R","S","T","U","V","W"
db "X","Y","Z","[","\","]","^","_"
db "`","A","B","C","D","E","F","G"
db "H","I","J","K","L","M","N","O"
db "P","Q","R","S","T","U","V","W"
db "X","Y","Z","{","|","}","~",127
; C .. ' ^ .. ` o c
; ' u e a a a a '
db 128,129,130,131,132,133,134,135 ;128,154,144,"A",142,"A",143,128
; ^ .. ` .. ^ ` .. o
; e e e i i i A A
db 136,137,138,139,140,141,142,143 ;"E","E","E","I","I","I",142,143
; ' ^ .. ` ^ `
; E ae AE o o o u u
db 144,145,146,147,148,149,150,151 ;144,146,146,"O",153,"O","U","U"
;.. .. ..
; y O U (currency symbols)
db 152,153,154,155,156,157,158,159 ;"Y",153,154,155,156,157,158,159
; ' ' ' ' ~ ~
; a i o u n N
db 160,161,162,163,164,165,166,167 ;"A","I","O","U",165,165,166,167
db 168,169,170,171,172,173,174,175
db 176,177,178,179,180,181,182,183
db 184,185,186,187,188,189,190,191
db 192,193,194,195,196,197,198,199
db 200,201,202,203,204,205,206,207
db 208,209,210,211,212,213,214,215
db 216,217,218,219,220,221,222,223
; beta
db 224,225,226,227,228,229,230,231
db 232,233,234,235,236,237,238,239
db 240,241,242,243,244,245,246,247
db 248,249,250,251,252,253,254,255
collate db 000,001,002,003,004,005,006,007
db 008,009,010,011,012,013,014,015
db 016,017,018,019,020,021,022,023
db 024,025,026,027,028,029,030,031
db " ","!",'"',"#","$","%","&","'"
db "(",")","*","+",",","-",".","/"
db "0","1","2","3","4","5","6","7"
db "8","9",":",";","<","=",">","?"
db "@","A","B","C","D","E","F","G"
db "H","I","J","K","L","M","N","O"
db "P","Q","R","S","T","U","V","W"
db "X","Y","Z","[","\","]","^","_"
db "`","a","b","c","d","e","f","g"
db "h","i","j","k","l","m","n","o"
db "p","q","r","s","t","u","v","w"
db "x","y","z","{","|","}","~",127
; C .. ' ^ .. ` o c
; ' u e a a a a '
db 128,129,130,131,132,133,134,135 ;"C","u","e","a","a","a","a","c"
; ^ .. ` .. ^ ` .. o
; e e e i i i A A
db 136,137,138,139,140,141,142,143 ;"e","e","e","i","i","i","A","A"
; ' ^ .. ` ^ `
; E ae AE o o o u u
db 144,145,146,147,148,149,150,151 ;"E","a","A","o","o","o","u","u"
; .. .. ..
;y O U (currency symbols)
db 152,153,154,155,156,157,158,159 ;"y","O","U","$","$","$","$","$"
; ' ' ' ' ~ ~
; a i o u n N
db 160,161,162,163,164,165,166,177 ;"a","i","o","u","n","N",166,167
db 168,169,170,171,172,173,174,175 ;"?",169,170,171,172,"!",'"','"'
db 176,177,178,179,180,181,182,183
db 184,185,186,187,188,189,190,191
db 192,193,194,195,196,197,198,199
db 200,201,202,203,204,205,206,207
db 208,209,210,211,212,213,214,215
db 216,217,218,219,220,221,222,223
; beta
db 224,"s",226,227,228,229,230,231
db 232,233,234,235,236,237,238,239
db 240,241,242,243,244,245,246,247
db 248,249,250,251,252,253,254,255
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
str_int proc near
; Entry points defined in "sinterp.asm"
extrn next:near ; Top of interpreter
extrn next_PC:near ; Reload ES,SI at top of interpreter
extrn next_SP:near ; mov SP,BP before next_PC
extrn src_err:near ; Source (operand) error print routine
extrn sch_err:near ; link to Scheme debugger
char_cmp macro comparison,case,operation
local w,x,y,z
lods word ptr ES:[SI] ; load operands
xor BX,BX
mov BL,AL ; copy the destination=source1 register
mov DI,BX ; number, copy into DI, and compute
add DI,offset reg0 ; the register's address
mov BL,AH ; copy the source2 register number
mov AL,byte ptr reg0_pag+[BX] ; load tag of src2 operand
cmp AL,SPECCHAR*2 ; is source2 a character?
jne z ; if not, error (jump)
cmp AL,byte ptr [DI].C_page ; is source1 a character?
jne z ; if not, error (jump)
IFIDN <case>,<CI>
mov AL,byte ptr reg0_dis+[BX] ; move character value of source2
mov BX,offset locases ; Fetch lower-case equivalents
xlat
mov AH,AL ; Save equivalent in AH
mov AL,byte ptr[DI].C_disp ; move char value of source1
xlat ; Fetch lower-case eqivalent
ELSE
mov AL,byte ptr [DI].C_disp ; Fetch characters
mov AH,byte ptr reg0_dis+[BX]
ENDIF
mov BX,offset collate ; Get collation values of chars
xlat
xchg AL,AH
xlat
cmp AH,AL ; Compare
j&comparison y ; jump, if test is satisfied
xor AX,AX ; place 'nil in destination
mov byte ptr [DI].C_page,AL ; register
mov [DI].C_disp,AX
jmp next ; return to interpreter
y: mov byte ptr [DI].C_page,T_PAGE*2 ; place 't in
mov [DI].C_disp,T_DISP ; destination register
jmp next ; return to interpreter
; ***error-- one (or both) operands aren't characters***
z: mov AX,offset operation
IFIDN <operation>,<m_ch_eq>
error_2: add BX,offset reg0 ; compute address of source 2
pushm <BX,DI,m_two,AX> ; push source 2, source 1, operation name
C_call set_src_,<SI>,Load_ES ; call: set_source_error
jmp sch_err ; link to Scheme debugger
ELSE
jmp error_2
ENDIF
endm
;************************************************************************
;* AL AH *
;* (char-= char1 char2) char-= dest,src *
;* *
;* Purpose: Scheme interpreter support for comparing the equality of *
;* character data objects. *
;* *
;* Description: The tags (page numbers) or the objects are compared *
;* for equality. If they are not equal, at least one of *
;* the operands is not a character, and an error is *
;* signaled. If they are equal, a second check to make *
;* sure both are characters is performed. *
;* *
;* After validating the tag fields, the displacement fields*
;* are compared for equality. If they are identical, the *
;* characters are equal and 't is returned in the destina- *
;* tion register. If not equal, 'nil is returned in the *
;* destination register. *
;************************************************************************
public ch_eq_p
ch_eq_p: char_cmp e,CS,m_ch_eq
;************************************************************************
;* AL AH *
;* (char-equal? char1 char2) char-eq? dest,src *
;* *
;* Purpose: Scheme interpreter support for comparing the equality of *
;* character data objects ignoring case. *
;* *
;* Description: The tags (page numbers) or the objects are compared *
;* for equality. If they are not equal, at least one of *
;* the operands is not a character, and an error is *
;* signaled. If they are equal, a second check to make *
;* sure both are characters is performed. *
;* *
;* The displacements of both operands are loaded and *
;* mapped to uppercase. They are then compared for *
;* equality. If equal, 't is returned in the destination *
;* registers. Otherwise, 'nil is returned. *
;************************************************************************
public ch_eq_ci
ch_eq_ci: char_cmp e,CI,m_ceq_ci
;************************************************************************
;* AL AH *
;* (char-<char1 char2) char-< dest,src *
;************************************************************************
public ch_lt_p
ch_lt_p: char_cmp b,CS,m_ch_lt
;************************************************************************
;* AL AH *
;* (char-less? char1 char2) char-less? dest,src *
;************************************************************************
public ch_lt_ci
ch_lt_ci: char_cmp b,CI,m_chl_ci
purge char_cmp
ch_case macro direction,name
local y
lods byte ptr ES:[SI]
mov DI,AX
add DI,offset reg0
cmp byte ptr [DI].C_page,SPECCHAR*2 ; is input char?
jne y ; if not a character, error (jump)
mov AL,byte ptr [DI].C_disp ; Put char in AL
IFIDN <direction>,<UP>
mov BX,offset hicases
ELSE
IFIDN <direction>,<DOWN>
mov BX,offset locases
ELSE
***error*** Invalid: direction
ENDIF
ENDIF
xlat ; Fetch alternate case
mov byte ptr [DI].C_disp,AL ; and store into dest register
jmp next
; ***error-- invalid source operand***
y: mov AX,offset name ; load the instruction's name text
IFIDN <direction>,<UP>
error_1: pushm <DI,m_one,AX> ; push operand, operand count, instr. name
C_call set_src_,<SI>,Load_ES ; call set_source_error
jmp sch_err ; link to Scheme debugger
ELSE
jmp error_1 ; jump to error routine
ENDIF
endm
;************************************************************************
;* AL *
;* (char-upcase char) char-upcase dest *
;* *
;* Purpose: Scheme interpreter support for conversion of characters *
;* to uppercase *
;************************************************************************
public ch_up
ch_up: ch_case UP,m_ch_up
;************************************************************************
;* AL *
;* (char-downcase char) char-downcase dest *
;* *
;* Purpose: Scheme interpreter support for conversion of characters *
;* to lowercase *
;************************************************************************
public ch_down
ch_down: ch_case DOWN,m_ch_dwn
purge ch_case
;************************************************************************
;* AL AH *
;* (make-string len init) make-string len,init*
;************************************************************************
public make_str
make_str: lods word ptr ES:[SI] ; load the operands of the instruction
save <AX,SI> ; save the operands and location pointer
xor BX,BX
mov BL,AL ; copy the destination register number
add BX,offset reg0 ; into BX and compute its address
cmp byte ptr [BX].C_page,SPECFIX*2 ; is length a fixnum?
jne mk_st_er ; if not, error (jump)
mov AX,[BX].C_disp ; load the immediate value for the size
shl AX,1 ; and sign extend it
sar AX,1
jl mk_st_er ; if size is negative, error
mov CX,STRTYPE ; load the tag value for the string object
pushm <AX,CX,BX> ; push arguments to "alloc_block"
C_call alloc_bl,,Load_ES ; call: alloc_block(reg, STRTYPE, len)
pop BX ; restore destination register address
mov DI,[BX].C_disp ; load a pointer to the newly allocated
mov BX,[BX].C_page ; string object
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
restore <AX> ; reload operands to instruction
mov BL,AH ; copy initial value register number
mov AL,byte ptr reg0_pag+[BX] ; load page number of init value
cmp AL,SPECCHAR*2 ; init value a character?
je st_fl_3 ; if a character, jump
cmp AL,NIL_PAGE*2 ; use default value? (nil?)
jne mk_st_er ; if not nil, error (jump)
mov AL," " ; load default string fill character
jmp short st_fl_4
mk_st_er: lea BX,m_mk_str ; load address of "make-string" text
jmp src_err ; display "source operand error" message
;************************************************************************
;* AL AH *
;* (string-fill! string char) string-fill! str,char *
;************************************************************************
public str_fill
str_fill: lods word ptr ES:[SI] ; load string-fill operands
save <SI> ; save current location pointer
xor BX,BX
mov BL,AL ; copy string register number
mov DI,BX
mov BL,byte ptr reg0_pag+[DI]
cmp byte ptr ptype+[BX],STRTYPE*2 ; is 1st operand a string?
jne st_fl_er ; if not, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load a pointer to the string object
mov DI,reg0_dis+[DI]
mov BL,AH ; copy initialization value register number
cmp reg0_pag+[BX],SPECCHAR*2 ; is it a char?
jne st_fl_er ; if not, error
st_fl_3: mov AL,byte ptr reg0_dis+[BX] ; load initialization character
st_fl_4: mov CX,ES:[DI].str_len ; load length of string object
cmp CX,0 ;;; check for small string
jge st_010
add CX,BLK_OVHD+PTRSIZE ;;; adjust for small string
st_010: sub CX,offset str_data ; compute number of characters
add DI,offset str_data ; advance index to 1st character position
rep stosb ; fill string object with init character
jmp next_SP ; return to interpreter
st_fl_er: lea BX,m_st_fl ; load address of "fill-string" text
jmp src_err ; display "source operand error" message
str_int endp
;************************************************************************
;* Macro Support for String ref/set *
;************************************************************************
st_thing macro ref_or_set,message
local w,x,y,z
lods word ptr ES:[SI] ; load string pointer and index regs
xor BX,BX
mov BL,AL ; copy string/dest reg number into DI
mov DI,BX
IFIDN <ref_or_set>,<SET>
lods byte ptr ES:[SI] ; load source operand register number
mov DL,AL ; and save it in TIPC register DL
ENDIF
save <SI> ; save the location pointer
mov BL,byte ptr reg0_pag+[DI] ; load string page number
cmp byte ptr ptype+[BX],STRTYPE*2 ; is it a string?
jne y ; if not a string, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,AH ; copy index register number
cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; is index a fixnum?
jne y ; if not a fixnum, error (jump)
mov AX,reg0_dis+[BX] ; load immediate value and
shl AX,1 ; sign extend to 16 bits
sar AX,1
jl z ; if index negative, error (jump)
add AX,offset str_data ; advance pointer past string header
mov SI,reg0_dis+[DI] ; load pointer to string object
mov CX,ES:[SI].str_len ; compare index with string length
cmp CX,0 ;;; check for small string
jge w
add CX,BLK_OVHD+PTRSIZE ;;; adjust for small string
w: cmp AX,CX
jge z ; if index too large, error (jump)
add SI,AX ; add index to string pointer
IFIDN <ref_or_set>,<REF>
mov byte ptr reg0_pag+[DI],SPECCHAR*2 ; set tag=character
mov BL,ES:[SI] ; fetch desired character
mov reg0_dis+[DI],BX ; and store into destination register
ELSE
IFIDN <ref_or_set>,<SET>
mov BL,DL ; copy source value register number
cmp byte ptr reg0_pag+[BX],SPECCHAR*2 ; is source a character?
jne y ; if not a character, error (jump)
mov AL,byte ptr reg0_dis+[BX] ; store source character into
mov ES:[SI],AL ; string at desired offset
ELSE
***error*** Invalid: ref_or_set
ENDIF
ENDIF
jmp next_PC ; return to interpreter
; ***error-- invalid source operand***
y: lea BX,message ; load address of operation name text
jmp src_err ; display "source operand error" message
; ***error-- invalid string offset***
z: mov BX,offset message ; load address of instruction name
IFIDN <ref_or_set>,<REF>
mov DX,3 ; STRING-REF is 3 bytes long
s_out_bn: restore <SI> ; load location pointer and
sub SI,DX ; back up to start of instruction in error
pushm <SI,BX> ; push instruction's offset, name
C_call disassem,,Load_ES ; disassemble instruction for *irritant*
pushm <tmp_adr,m_soff,m_one> ; push args to "set_numeric_error"
C_call set_nume ; set_numeric_error(1,ST_OFF_ERR,tmp_reg);
restore <SI> ; load offset of next instruction
jmp sch_err ; Link to Scheme debugger
ELSE
mov DX,4 ; STRING-SET! is 4 bytes long
jmp s_out_bn ; continue error processing
ENDIF
endm
;************************************************************************
;* AL AH *
;* (string-ref string index) string-ref str,index *
;************************************************************************
public st_ref
st_ref: st_thing REF,m_st_ref
;************************************************************************
;* AL AH AL *
;* (string-set! string index char) string-set! str,index,char *
;************************************************************************
public st_set
st_set: st_thing SET,m_st_set
purge st_thing
prog ends
end


55
stackf.equ Normal file
View File

@ -0,0 +1,55 @@
; =====> STACKF.EQU
; Copyright 1984,1985 by Texas Instruments Incorporated.
; All Rights Reserved.
;
; Last Modification: 4 August 1985
; Stack Frame
;
; +------------------+
; Stack base -> | stack for prev |
; : dynamic levels :
; |------------------|
; Frame pointer ->| code base -> | \
; |------------------| | return address
; | return addr disp | /
; |------------------|
; | dynamic link | caller's FP
; |------------------|
; | environment | current environment
; |------------------|
; | static link | lexical parent's FP
; |------------------|
; | closure ptr | pointer to routine's closure object
; |------------------| (or nil, if an open call)
; | local |
; : variable :
; top of stack -> | allocation |
; +------------------+
sf_def struc
sf_cb_pag db ? ; code base pointer page number
sf_cb_dis dw ? ; code base pointer displacement
sf_rtag db SPECFIX*2 ; return address tag=fixnum
sf_ret dw ? ; return address displacement
sf_dtag db SPECFIX*2 ; dynamic link tag=fixnum
sf_ddisp dw ? ; dynamic link displacement
sf_hpage db ? ; heap environment page number
sf_hdisp dw ? ; heap environment displacement
sf_stag db SPECFIX*2 ; lex parent's static link tag=fixnum
sf_sdisp dw ? ; lex parent's static link displacement
sf_cl_pg db ? ; closure pointer page number
sf_cl_ds dw ? ; closure pointer page number
; start of local variable allocation area
sf_dat_p db ? ; local variable's page number
sf_dat_d dw ? ; local variable's displacement
sf_def ends
SF_OVHD equ sf_dat_p-sf_cb_pag ; size of stack frame header


173
stdio.h Normal file
View File

@ -0,0 +1,173 @@
/**
*
* This header file defines the information used by the standard I/O
* package.
*
**/
#define _BUFSIZ 512 /* standard buffer size */
#define BUFSIZ 512 /* standard buffer size */
#define _NFILE 20 /* maximum number of files */
struct _iobuf
{
unsigned char *_ptr; /* current buffer pointer */
int _rcnt; /* current byte count for reading */
int _wcnt; /* current byte count for writing */
unsigned char *_base; /* base address of I/O buffer */
int _size; /* size of buffer */
int _flag; /* control flags */
unsigned char _file; /* file number */
unsigned char _cbuff; /* single char buffer */
};
extern struct _iobuf _iob[_NFILE];
/**
*
* Definitions associated with _iobuf._flag
*
*/
#define _IOFBF 0 /* fully buffered (for setvbuf) */
#define _IOREAD 1 /* read flag */
#define _IOWRT 2 /* write flag */
#define _IONBF 4 /* non-buffered flag */
#define _IOMYBUF 8 /* private buffer flag */
#define _IOEOF 16 /* end-of-file flag */
#define _IOERR 32 /* error flag */
#define _IOLBF 64 /* line-buffered flag */
#define _IORW 128 /* read-write (update) flag */
#define _IOAPP 0x4000 /* append flag */
#define _IOXLAT 0x8000 /* translation flag */
#ifndef NULL
#if SPTR
#define NULL 0 /* null pointer value */
#else
#define NULL 0L
#endif
#endif
#define FILE struct _iobuf /* shorthand */
#define EOF (-1) /* end-of-file code */
#define stdin (&_iob[0]) /* standard input file pointer */
#define stdout (&_iob[1]) /* standard output file pointer */
#define stderr (&_iob[2]) /* standard error file pointer */
#define stdaux (&_iob[3]) /* standard auxiliary file pointer */
#define stdprt (&_iob[4]) /* standard printer file pointer */
#define getc(p) (--(p)->_rcnt>=0? *(p)->_ptr++:_filbf(p))
#define getchar() getc(stdin)
#define putc(c,p) (--(p)->_wcnt>=0? ((int)(*(p)->_ptr++=(c))):_flsbf((c),p))
#define putchar(c) putc(c,stdout)
#define feof(p) (((p)->_flag&_IOEOF)!=0)
#define ferror(p) (((p)->_flag&_IOERR)!=0)
#define fileno(p) (p)->_file
#define rewind(fp) fseek(fp,0L,0)
#define fflush(fp) _flsbf(-1,fp)
#define clearerr(fp) clrerr(fp)
#ifndef NARGS
extern void clrerr(FILE *);
extern int cprintf(char *, );
extern int cscanf(char *, );
extern int fclose(FILE *);
extern int fcloseall(void);
extern FILE *fdopen(int, char *);
extern int fgetc(FILE *);
extern int fgetchar(void);
extern char *fgets(char *, int, FILE *);
extern int flushall(void);
extern int fmode(FILE *, int);
extern FILE *fopen(char *, char *);
extern FILE *fopene(char *, char *, char *);
extern int fprintf(FILE *, char *, );
extern int fputc(int, FILE *);
extern int fputchar(int);
extern int fputs(char *, FILE *);
extern int fread(char *, int, int, FILE *);
extern FILE *freopen(char *, char *, FILE *);
extern int fscanf(FILE*, char *, );
extern int fseek(FILE *, long, int);
extern long ftell(FILE *);
extern int fwrite(char *, int, int, FILE *);
extern char *gets(char *);
extern int printf(char *, );
extern int puts(char *);
extern scanf(char *, );
extern int setbuf(FILE *, char *);
extern int setnbf(FILE *);
extern int setvbuf(FILE*, char *, int, int);
extern int sprintf(char *, char *, );
extern sscanf(char *, char *, );
extern int ungetc(int, FILE *);
extern int _filbf(FILE *);
extern int _flsbf(int, FILE *);
#else
extern void clrerr();
extern int cprintf();
extern int cscanf();
extern int fclose();
extern int fcloseall();
extern FILE *fdopen();
extern int fgetc();
extern int fgetchar();
extern char *fgets();
extern int flushall();
extern int fmode();
extern FILE *fopen();
extern FILE *fopene();
extern int fprintf();
extern int fputc();
extern int fputchar();
extern int fputs();
extern int fread();
extern FILE *freopen();
extern int fscanf();
extern int fseek();
extern long ftell();
extern int fwrite();
extern char *gets();
extern int printf();
extern int puts();
extern scanf();
extern int setbuf();
extern int setnbf();
extern int setvbuf();
extern int sprintf();
extern sscanf();
extern int ungetc();
extern int _filbf();
extern int _flsbf();
#endif
/**
*
* Miscellaneous I/O services
*
*/
#ifndef NARGS
extern int access(char *, int);
extern int chdir(char *);
extern int chmod(char *, int);
extern char *getcwd(char *, int);
extern int mkdir(char *);
extern int perror(char *);
extern int rename(char *, char *);
extern int rmdir(char *);
extern char *tmpnam(char *);
#else
extern int access();
extern int chdir();
extern int chmod();
extern char *getcwd();
extern int mkdir();
extern int perror();
extern int rename();
extern int rmdir();
extern char *tmpnam();
#endif

118
stimer.asm Normal file
View File

@ -0,0 +1,118 @@
; =====> STIMER.ASM
;***************************************
;* TIPC Scheme '84 Engine Timer *
;* Utilities *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: June 1985 *
;* Last Modification: 30 July 1985 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
timer_int db 58h ;40 Hz timer interrupt number
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
dos_func equ 21h ;DOS function call interrupt number
get_vec equ 35h ;DOS call to retrieve interrupt vector
set_vec equ 25h ;Call to set vector
public tickstat
tickstat db -1 ;0=timeout, 1=engine running,
; -1=no engine running (normal)
clk_ptr dw 0,0 ;Former timer vector
lo_time dw 0 ;Timer ticks
hi_time dw 0
; Start timer running
; Calling sequence: set_timer(hi,lo)
; Where ---- hi,lo: upper,lower words of initial timer value
; Returns nonzero iff the set was during normal VM running mode
set_args struc
dw ? ;Caller's BP
dw ? ;Return address
hi dw ? ;High word
lo dw ? ;Low word
set_args ends
public settimer
settimer proc near
cmp PC_MAKE,252 ;Is computer an IBM variant?
jb nochange ;Jump if not
mov timer_int,1ch ;Otherwise, set to IBM's vector
nochange: xor AX,AX ;Clear AX
cmp CS:tickstat,-1 ;Check for normal run mode
jne no_set ;Abort if timeout or engine running
push BP
mov BP,SP
push ES ;Save ES
mov AH,get_vec ;Put present timer interrupt vector
mov AL,timer_int ; into ES:BX
int dos_func
mov CS:clk_ptr,BX ;Save vector
mov CS:clk_ptr+2,ES
pop ES ;Restore ES
mov AX,[BP].hi ;Set timer
mov CS:hi_time,AX
mov AX,[BP].lo
mov CS:lo_time,AX
push DS ;Save DS
mov AH,set_vec ;Set new interrupt vector
mov AL,timer_int
push CS ;Put vector segment number in DS
pop DS
mov DX,offset tick ;Vector offset in DX
int dos_func
pop DS ;Restore DS
mov AL,1 ;Denote engine running
mov CS:tickstat,AL
pop BP ;Restore BP
no_set: ret
settimer endp
; Stop the timer
; Calling sequence: rst_timer();
; Returns the number in the counter at the time of reset
public rsttimer
rsttimer proc near
cmp CS:tickstat,1 ;Only if timeout or engine running
ja no_reset ;Otherwise forget it
mov AH,set_vec ;Prepare to reset timer interrupt
mov AL,timer_int
push DS ;Save DS
lds DX,dword ptr CS:clk_ptr ;Put original vector into DS:DX
int dos_func
pop DS ;Restore DS
mov CS:tickstat,-1 ;Denote normal mode
no_reset: mov AX,CS:hi_time ;Return 32-bit clock value
mov BX,CS:lo_time
ret
rsttimer endp
;The new timer code
tick proc near
sti ;Re-enable interrupts
cmp CS:tickstat,0 ;If timeout, do nothing special
je norm_vec
sub CS:lo_time,1 ;Otherwise decrement counter
sbb CS:hi_time,0
jnz norm_vec ;If not zero, jump ahead
cmp CS:lo_time,0
jnz norm_vec
mov CS:tickstat,0 ;Otherwise, record timeout event
C_call force_ti ;Force a timeout condition
norm_vec: jmp dword ptr CS:clk_ptr ;Jump to original timer code
tick endp
prog ends
end


679
strmlnrs.asm Normal file
View File

@ -0,0 +1,679 @@
; =====> STIMER.ASM
;***************************************
;* TIPC Scheme '84 Things That Could *
;* Have Been Done in C but Why Waste *
;* Execution Time and Codespace? *
;* *
;* (C) Copyright 1984,1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: July 1985 *
;* Last Modification: 8 October 1985 *
;***************************************
include scheme.equ
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
;Table of strange characters
stranges db " ,'"
db ';":()`'
db 13,12,11,10,9,0
;Random number registers
krala dw 22425
kralb dw 30029 ;RANDOMIZE puts seed value here
;Random number table
kraltbl dw 4053,32361,7773,17385,11177,20413,27513,16501
dw 5953,17673,20725,12247,28429,30861,16849,22375
;Copy of random number registers and table.
krala1 dw 22425
kralb2 dw 30029
kraltbl1 dw 4053,32361,7773,17385,11177,20413,27513,16501
dw 5953,17673,20725,12247,28429,30861,16849,22375
kral_len equ krala1-krala
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;For space and performance reasons, some procedures have been written in the
; following style: the arguments are popped off the stack, and the
; procedure may end in an indirect JMP instead of a RET. In this source file,
; the following are such procedures:
; toblock, gvchars, blk2pbuf, putlong, thefix, ldlong, msubstr,
; mcmpstr, ldreg, pt_flds4, pt_flds6, str2str, adj4bord
; Convert flonum to bignum
; Calling sequence: flotobig(flo,bigbuf)
; Where ---- flo: double-length flonum such that abs(flo)>=1
; bigbuf: pointer to buffer for bignum formation
fbargs struc
dw ? ;Return address
flo dw ?,?,?,? ;Flonum
bigbuf dw ? ;Pointer to bignum buffer
fbargs ends
public flotobig
flotobig proc near
mov BX,SP
lea SI,[BX].flo ;Fetch pointer to flonum
mov DI,[BX].bigbuf ;Fetch buffer pointer
inc DI ;Point DI to sign byte
inc DI
cld ;Direction forward
mov AX,[BX+6].flo ;Fetch exponent word to CX
mov CX,AX
and AX,0fh ;Save mantissa part back
or AL,10h
mov [BX+6].flo,AX
mov AL,AH ;Zero AL
test CH,80h ;Negative flonum?
jz ftb1 ;Jump if not
inc AL ;Otherwise, set AL to 1
ftb1: stosb ;Store sign byte
mov BX,DI ;Save address of first word in BX
mov AL,AH ;Zero AL again
and CX,7ff0h ;Discard sign byte and mantissa
sub CX,3ff0h ;Remove exponent bias
shl CX,1
;At this stage, CH+1==number of bytes for bignum, CL shows how much to
; shift mantissa left (once per 20h)
mov DX,CX ;Use DX to count the shifts
xor DH,DH ;Set up shift count
add DX,80h ;Account for placing leading 1 in high byte
ftb2: shl word ptr[SI],1 ;Shift mantissa left
rcl word ptr[SI+2],1
rcl word ptr[SI+4],1
rcl word ptr[SI+6],1
sub DX,20h ;Repeat until done
jnz ftb2
mov CL,CH ;Set CX to number of bignum bytes
xor CH,CH
inc CX
sub CX,8 ;Check for leading zeros
js ftb3 ;Jump if not all the mantissa will be done
jz ftb3 ;Jump if no trailing zeros exist
rep stosb ;Else store as many zeros as necessary
ftb3: sub SI,CX ;Point SI to eligible part of mantissa
add CX,8 ;Set mantissa byte count
rep movsb ;Copy flonum mantissa to bignum
mov CX,DI ;Find number of bytes in bignum proper
sub CX,BX
shr CX,1 ;Find number of words
jnc ftb4 ;If a whole number of words, do nothing
mov byte ptr[DI],0 ;Otherwise, pad with a 0
inc CX ;Adjust word count
ftb4: mov [BX-3],CX ;Save size of bignum
ret
flotobig endp
; Find the size of a flonum
; Calling sequence: flosiz(flo);
; Where ---- flo: double-length flonum
; Returns the number of bytes needed for a working flonum formed from
; trunc(flonum)
fsargs struc
dw ? ;Return address
fl dw ?,?,?,? ;Double-length flonum
fsargs ends
public flosiz
flosiz proc near
mov SI,SP
mov AX,[SI+6].fl ;Fetch word containing exponent
and AX,7ff0h ;Drop sign and mantissa
sub AX,3ff0h ;Is abs(flo) < 1?
jc small ;Jump if small
mov AL,AH ;Otherwise, return number of bytes
xor AH,AH
shl AL,1
add AL,5
ret
small: xor AX,AX ;Return 0 for smallness
ret
flosiz endp
; Move bytes from buffer to allocated Scheme block
; Calling sequence: toblock(reg,offs,buf,q)
; Where ---- reg: Scheme register pointing to block
; offs: Offset into block to begin transfer
; buf: Buffer pointer
; q: Number of bytes to move
;Stack elements in order of popping:
; Return address, register, offset, buffer address, number of bytes
public toblock
toblock proc near
pop DX ;Save return address in DX
pop BX ;Get register address
mov DI,[BX].C_disp ;Put 8088 address in ES:DI
mov BX,[BX].C_page
mov AX,ES
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
pop CX ;Get offset
add DI,CX ;Add to DI
pop SI ;Get source address (buffer ptr)
pop CX ;Get number of bytes
jcxz tbskip ;If no bytes, don't move
cld ;Direction forward
rep movsb ;Move bytes
tbskip: mov ES,AX ;Restore ES
jmp DX ;Return
toblock endp
IFNDEF PROMEM
; Give characters from a C string
; Calling sequence: gvchars(str,len)
; Where ---- str: C string address
; len: Number of characters to give
;Stack elements in order of popping:
; Return address, string address, number of chars
extrn givechar:near
public gvchars
gvchars proc near
pop DI ;Get return address
pop SI ;Get string address
pop CX ;Get number of chars
push DI ;Put return address back
jcxz given ;If no chars, stop
cld ;Direction forward
gvlp: push CX ;Save count
lodsb ;Fetch string character
push SI ;Save pointer to next char
push AX
call givechar ;Give it
inc SP ;Restore stack
inc SP
pop SI ;Restore address and count
pop CX
loop gvlp ;Give 'til done
given: ret ;Return
gvchars endp
; Move characters from block (symbol or string) to print buffer
; Calling sequence: blk2pbuf(pg,ds,buf,len,ch,display)
; Where ---- pg: logical page of the block
; ds: block displacement
; buf: address of print buffer
; len: number of chars in the block
; ch: character to escape (| for syms, " for strs)
; display: whether to use escape characters
; Returns the number 2n+s, where n is the number of characters in the
; print buffer, and s=1 if strange chars were encountered, 0 otherwise.
; Popping order: return address, pg, ds, buf, len, ch, display
public blk2pbuf
extrn hicases:byte
blk2pbuf proc near
pop DX ;Pop return address
pop BX ;Pop page
shl BX,1 ;Put segment of block in DS
LoadPage DS,BX
;;; mov DS,pagetabl+[BX]
pop SI ;Pop block displacement
pop DI ;Pop print buffer
pop CX ;Pop character count
pop BX ;Pop must-be-escaped character
pop AX ;Pop whether to use escapes
mov BH,AL ;Save escape boolean in BX
and BH,7fh ;Save bit in BH for strangeness
push DX ;Push return address
push ES ; Save caller's ES register
mov DX,DI ;Save start address of print buffer in DX
jcxz zstrng ;If len=0, mark strangeness
cmp BL,'"' ;Are we looking at a string?
jne b2plp ;Skip if not
zstrng: or BH,80h ;Otherwise, mark as strange
jcxz done ;If len=0, forget everything else
b2plp: lodsb ;Fetch char from block
test BH,7fh ;Are we displaying escape chars?
jz storit ;Jump if not
cmp AL,BL ;Does the char need escaping?
je escit ;If needed, do so
cmp AL,'\'
jne storit ;If not, just store it
escit: mov AH,AL ;Save char in AH
mov AL,'\' ;Store escape character
stosb
mov AL,AH ;Restore char
storit: stosb ;Store it
test BH,80h ;Do we already know that atom's strange?
jnz skptest ;If so, don't bother testing
push SI ;Else save SI
mov SI,offset DGROUP:hicases ;Point SI to table of upper cases
xchg BX,SI
mov AH,AL ;Save char in AH
xlat ES:hicases ;Fetch upper-case equivalent
xchg BX,SI ;Restore BX
cmp AH,AL
jne mrkstrng ;If chars different, mark as strange
mov SI,offset stranges ;Point SI to strange-character string
strnglp: lods byte ptr ES:[SI] ;Fetch strange char
or AL,AL ;End of string?
jz notstrng ;Jump if so
cmp AH,AL ;Is AH strange?
jne strnglp ;If not, try again
mrkstrng: or BH,80h ;Mark strange bit
notstrng: pop SI ;Restore SI
skptest: loop b2plp ;Repeat until done
done: push ES ;Restore DS
pop DS
pop ES ; Restore caller's ES register
mov byte ptr[DI],0 ;Put null at end of string
mov AX,DI ;Return 2*(# of chars in string)+strangeness
sub AX,DX
shl BH,1
rcl AX,1
ret ;Return
blk2pbuf endp
ENDIF
; Load bignum block with long integer
; Calling sequence: putlong(reg,longi)
; Where ----- reg: register pointing to a bignum block
; longi: 32-bit integer to store
; Popping order: return address, register address, low & high integer words
public putlong
putlong proc near
pop DX ;Fetch return address
pop DI ;Fetch register address
mov BX,[DI].C_page ;Point ES:DI to bignum block
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov DI,[DI].C_disp
add DI,3 ;Point ES:DI to block data area
pop BX ;Put long integer in CX:BX
pop CX
xor AL,AL ;Sign byte - default positive
test CH,80h ;Integer negative?
jz poslong ;Jump if not
inc AL ;Otherwise, set sign negative
xor BX,-1 ;Negate long integer
xor CX,-1
add BX,1
adc CX,0
poslong: cld ;Direction forward
stosb ;Store sign byte
mov AX,BX ;Store least significant word
stosw
jcxz notlong ;If most signif. word=0, don't store it
mov AX,CX
stosw
notlong: push DS ;Restore ES
pop ES
jmp DX ;Return
putlong endp
; Add word of zeros, if necessary, to bignum buffer
; Calling sequence: thefix(buf)
; Where ----- buf: address of bignum buffer
; THEFIX is intended to alleviate a problem in the bignum division package.
; Popping order: return address, buf
public thefix
thefix proc near
pop DI ;Return address in DX
pop SI ;Fetch bignum buffer address
mov BX,[SI] ;Get bignum size in words
inc BX ;Point BX+SI to last bignum byte
shl BX,1
test byte ptr[BX+SI],80h ;Is most signif. bit set?
jz fixed ;If not, nothing to fix
inc word ptr[SI] ;Otherwise, increase bignum size
inc BX ;Add word of 0 to most significant end
mov word ptr[BX+SI],0
fixed: jmp DI ;Return
thefix endp
; Load a long integer value with a bignum
; Calling sequence: ldlong(v, reg)
; Where ----- v: pointer to a long integer
; reg: register pointing to a bignum
; Returns 0 if the load was successful, 1 otherwise
; Popping order: return address, v, reg
public ldlong
ldlong proc near
pop DX ;Pop return address
pop DI ;Pop longint destination
pop BX ;Pop register address
push DS ;Save DS
mov SI,[BX].C_disp ;Point DS:SI to bignum object
mov BX,[BX].C_page
LoadPage DS,BX
;;; mov DS,pagetabl+[BX]
cld ;Direction forward
inc SI ;Put bignum length in CX
lodsw
mov CX,AX
lodsb ;Put bignum sign in BL
mov BL,AL
cmp CX,6 ;Check size
je big6
cmp CX,8
je big8
mov AX,1 ;If here, bignum wrong size: error
pop DS ;Restore DS
jmp DX ;Return
big6: lodsw ;Put bignum in CX:AX
xor CX,CX
jmp short havenum
big8: lodsw ;Put bignum in CX:AX
mov CX,AX
lodsw
xchg CX,AX
havenum: test BL,1 ;Was bignum negative?
jz storenum ;No, skip
xor CX,-1 ;Otherwise, negate
xor AX,-1
add AX,1
adc CX,0
storenum: stosw ;Store to long integer
mov AX,CX
stosw
xor AX,AX ;All's well
pop DS ;Restore DS
jmp DX ;Return
ldlong endp
; Move string bytes from one part of PCS memory to another
; Calling sequence: msubstr(to_reg, from_reg, start, end)
; Where ----- to_reg: register pointing to destination string
; from_reg: register pointing to source string
; start: offset at which to start copying
; end: byte after the last to be copied
; Popping order: return address, from_reg, to_reg, start, end
public msubstr
msubstr proc near
pop DX ;Pop return address (temporarily)
pop DI ;Pop destination register address
pop SI ;Pop source register address
pop AX ;Pop start index
pop CX ;Pop end index
push DS ;Save caller's DS & ES
push ES
mov BX,[DI].C_page ;Point ES:DI to destination object
mov DI,[DI].C_disp
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
add DI,BLK_OVHD ;Adjust DI past string overhead
mov BX,[SI].C_page ;Point DS:SI to source object
mov SI,[SI].C_disp
LoadPage DS,BX
;;; mov DS,pagetabl+[BX]
add SI,BLK_OVHD ;Adjust SI past string overhead
add SI,AX ;Point SI to start of substring
sub CX,AX ;Set number of bytes to move
cld ;Direction forward
rep movsb
pop ES ;Restore caller's DS & ES
pop DS
jmp DX ;Return
msubstr endp
; Compare two Scheme bignums or strings for equal?-ness
; Calling sequence: mcmpstr(reg1,reg2)
; Where ----- reg1,reg2: registers pointing to objects to be compared
; Returns 1 if the objects are equal?, 0 otherwise
public mcmpstr
mcmpstr proc near
pop DX ;Pop return address
pop SI ;Pop register addresses
pop DI
push DS ;Save caller's DS and ES
push ES
mov BX,[DI].C_page ;Point ES:DI to second object
mov DI,[DI].C_disp
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BX,[SI].C_page ;Point DS:SI to the first object
mov SI,[SI].C_disp
LoadPage DS,BX
;;; mov DS,pagetabl+[BX]
mov CX,[SI].str_len ;Fetch byte count from source's length
cmp CX,0 ;;; check for small string
jge mcm_010
add CX,BLK_OVHD+PTRSIZE
mcm_010: xor AX,AX ;Default AX to FALSE
cld ;Direction forward
repe cmpsb ;Compare
jne cmpskp ;If not equal, return FALSE
inc AX ;Otherwise return TRUE
cmpskp: pop ES ;Restore caller's ES and DS
pop DS
jmp DX ;Return
mcmpstr endp
; Load a register with a pointer from Scheme memory
; Calling sequence: ldreg(reg,pg,ds)
; Where ----- reg: register to be loaded
; pg,ds: page and displacement of Scheme pointer
; Popping order: return address, reg, pg, ds
public ldreg
ldreg proc near
pop DX ;Pop return address
pop DI ;Pop destination register
pop BX ;Pop page and displacement
pop SI
mov CX,DS ;Save caller's DS
shl BX,1 ;Point DS:SI to Scheme pointer
LoadPage DS,BX
;;; mov DS,pagetabl+[BX]
cld ;Direction forward
lodsb ;Load register's page field
xor AH,AH
mov ES:[DI].C_page,AX
lodsw ;Load displacement field
mov ES:[DI].C_disp,AX
mov DS,CX ;Restore caller's DS
jmp DX ;Return
ldreg endp
; Generate pseudorandom numbers in the range 0-16,383
;
; Author: John C. Jensen (converted to assembly lang. by Mark Meyer)
; Date Written: 9 January 1985
; Last Modification: 9 July 1985
;
; Calling Sequence: krandom()
;
; Note: the following random number generator is due to Jaroslav
; Kral. It was adapted to 16 bit words and proven both efficient
; and statistically satisfactory by Overstreet and Nance of SMU.
; See Karl's paper for initialization values for other word
; lengths.
;
; -- Kral, Jaroslav. "A New Additive Pseudorandom Number
; Generator for Extremely Short Word-Lengths," Information
; Processing Letters, 1 (1972), 164-167 (erratum noted in 1
; (1972), 216).
;
; -- Overstreet, C. and Nance, R.E., "A Random Number Generator
; for Small Word-Length Computers," Proceedings of the ACM '73
; Conference, p. 219-223.
;
public krandom
krandom proc near
mov AX,krala ;Put old KRALA in AX, old KRALB in BX
mov BX,kralb
mov CX,BX ;KRALC = KRALB
add BX,AX ;KRALB = (KRALA+KRALB) mod 2^n
and BH,3fh ; (Currently, n=14)
mov kralb,BX
mov BL,BH ;J = KRALB / 2^(n-4)
shr BL,1
and BX,01eh
mov AX,[BX]+offset kraltbl ;KRALA = KRALTBL[J]
mov krala,AX
add AX,CX ;KRALTBL[J] = (KRALA+KRALC) mod 2^n
and AH,3fh
mov [BX]+offset kraltbl,AX
ret ;Return KRALTBL[J]
krandom endp
; RANDOMIZE - Reset the random number registers and table back to their
; original values, then put the seed value into "kralb".
; Calling sequence: randomize(seed) ;seed = normal C int
public randomiz
randz_args struc
dw ? ;caller's ES
dw ? ;caller's BP
dw ? ;return address
rseed dw ? ;argument 1 (seed)
randz_args ends
randomiz proc near
push BP ;save caller's BP
push ES ;save ES
mov BP,SP ;establish local addressability
mov AX,DS ;copy DS to ES
mov ES,AX
mov CX,kral_len/2 ;restore random state to its original state
lea SI,krala1
lea DI,krala
rep movsw
mov BX,[BP].rseed ;get seed
cmp BX,0 ;is it zero?
jnz randz_1 ;no, jump; use the seed directly
mov AX,2C00h ;get the time from DOS
int 21h
push DX ;tempsave DX (seconds, hundredths)
xor AX,AX
mov AL,CH ;determine #sec-in-hours
mov DX,3600
mul DX
mov BX,AX
xor AX,AX
mov AL,CL ;determine #sec-in-minutes
mov DX,60
mul DX
add BX,AX ;#sec-in-hours + #sec-in-minutes
pop DX ;restore seconds (and hundredths, but ignore it)
xchg DH,DL
mov DH,0
add BX,DX ;add in seconds
randz_1: mov kralb,BX ;set seed
pop ES ;wrap up
pop BP
ret
randomiz endp
; Set the cdr field of a list cell
; Calling sequence: asetcdr(creg, preg)
; Where ---- creg: register pointing to cell
; preg: register holding new pointer
; Popping order: Return address, destination register, pointer register
public asetcdr
asetcdr proc near
pop DX ;Pop return address
pop DI ;Pop address of register
mov CX,ES ;Save caller's ES
mov BX,[DI].C_page ;Point ES:DI to list cell
mov DI,[DI].C_disp
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
add DI,PTRSIZE ;Adjust for cdr field
pop SI ;Pop address of pointer
cld ;Direction forward
mov AX,[SI].C_page ;Store into cdr field
stosb
mov AX,[SI].C_disp
stosw
mov ES,CX ;Restore ES
jmp DX ;Return
asetcdr endp
; Get field values from a port object
; Calling sequence: pt_flds4(reg, &ull, &ulc, &nl, &nc)
; pt_flds6(reg, &cl, &cc, &ull, &ulc, &nl, &nc)
; Where ----- reg: register pointing to port
; cl: variable to receive CUR_LINE value
; cc: ... CUR_COL value
; ull: ... UL_LINE value
; ulc: ... UL_COL value
; nl: ... N_LINES value
; nc: ... N_COLS value
; Warning: This routine expects these six fields to be contiguous
; Popping order: return address, reg, (&cl, &cc,) &ull, &ulc, &nl, &nc
public pt_flds4,pt_flds6
pt_flds proc near
pt_flds6: mov CX,pt_cline ;Set CX to offset of first field
jmp fldsmrg
pt_flds4: mov CX,pt_ullin ;Set CX to offset of first field
fldsmrg: pop DX ;Pop return address
mov AX,DS ;Save caller's DS
pop BX ;Pop register address
mov SI,[BX].C_disp ;Point DS:SI to first field
mov BX,[BX].C_page
LoadPage DS,BX
;;; mov DS,pagetabl+[BX]
add SI,CX
cld ;Direction forward
sub CX,pt_cline ;Set CX to number of fields to do
shr CX,1 ; (6 - (1/2)(CX - pt_cline))
neg CX
add CX,6
fldslp: pop DI ;Pop destination variable address
movsw ;Transfer value
loop fldslp ;Repeat until done
mov DS,AX ;Restore DS
jmp DX ;Return
pt_flds endp
; Copy bytes from one C location to another
; Calling sequence: str2str(dest_adr, src_adr, n)
; Where ----- dest_adr: destination address
; src_adr: source address
; n: number of bytes to copy
; Popping order: return address, dest_adr, src_adr, n
public str2str
str2str proc near
pop DX ;Pop return address
pop DI
pop SI
pop CX
cld ;Direction forward
rep movsb ;Copy bytes
jmp DX ;Return
str2str endp
; Adjust window region variables for presence of a border
; Calling sequence: adj4bord(&ull, &nl, &ulc, &nc)
; Where ----- ull: Upper-left-line variable
; nl: Number-of-lines variable
; ulc: Upper-left-column variable
; nc: Number-of-columns variable
; Popping order: return address, &ull, &nl, &ulc, &nc
public adj4bord
max_lines equ 25
max_cols equ 80
adj4bord proc near
pop DX ;Pop return address
mov BX,max_lines ;Expand HEIGHT of window region
expand: pop SI ;Pop upper-left parameter
pop DI ;Pop extent parameter
mov AX,[SI] ;Get value of upper-left parm
or AX,AX ;If zero,
jz expand1 ; skip next two instructions
dec word ptr[SI] ;Else, expand backward
inc word ptr[DI]
dec AX ;Adjust AX to match upper-left parm
expand1: add AX,[DI] ;Find opposite edge
cmp AX,BX ;If edge too far,
jae expand2 ; skip next instruction
inc word ptr[DI] ;Else, expand forward
expand2: cmp BX,max_cols ;If we're finished,
je adjex ; jump out
mov BX,max_cols ;Else, expand WIDTH of window region
jmp expand
adjex: jmp DX ;Return
adj4bord endp
prog ends
end


802
sutil.asm Normal file
View File

@ -0,0 +1,802 @@
; =====> SUTIL.ASM
;***************************************
;* PC Scheme Runtime Support *
;* Misc Utilities *
;* *
;* (C) Copyright 1984.1985,1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: April 1984 *
;* Last Modification: 26 February 1986*
;***************************************
include scheme.equ
include pcmake.equ
;* Modification History:
;* 27 Jan 86 - Changed the code which looks for the TI Copyright notice
;* (JCJ) (when determining machine type) to search two areas instead
;* of just one. Now, checks are made at segment (paragraph)
;* offsets FC00 and FE00.
;*
;* 25 Feb 86 - Added the routine "put_ptr" to combine the "put_byte/put_word"
;* (JCJ) operations when a pointer is being stored into memory.
;*
;* 17 Feb 88 - Conditionally assemble XPCTYPE and PC_TYPE for Protected Memory
;* (TC) Scheme. These routines can be found in PRO2REAL.ASM and
;* REALIO.ASM for PROMEM
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
extrn _base:word
data ends
IFNDEF PROMEM
; See PRO2REAL.ASM for protected mode scheme
XGROUP group PROGX
PROGX segment para public 'PROGX'
assume CS:XGROUP,DS:DGROUP
;************************************************************************
;* Determine PC's Manufacturer *
;* *
;* Purpose: To determine whether or not we're running on a TIPC or *
;* another brand and set the "PC_MAKE" variable accordingly. *
;* Returns: PC_MAKE will contain 1 for TIPC or Business Pro in TI mode*
;* FF for IBM-PC *
;* FE for IBM-PC/XT *
;* FD for IBM-PC/jr *
;* FC for IBM-PC/AT or B-P in IBM mode *
;* 0 for undeterminable *
;************************************************************************
public pc_type
XPCTYPE proc far
push ES ; save caller's ES register
push DI
mov AX,0FC00h ; move paragraph address of copyright
pc_002: mov ES,AX ; notice into ES
xor DI,DI ; Clear DI; 0 is lowest address in ROM @ES:
xor BX,BX ; Flag for "PC_MAKE" variable
mov CX,40h ; This'll be as far as I go...
mov AL,'T' ; look for beginning of "Texas Instruments"
cli ; Stop interrupts - bug in old 8088's
again:
repne scas byte ptr es:[di] ; SEARCH
or CX,CX ; Reach my limit?
jz short pc_005 ; quit if we've exhausted search
cmp byte ptr ES:[di],'e' ; make sure this is it
jne again ; use defaults if not found
cmp byte ptr ES:[di]+1,'x' ; really make sure this is it
jne again
push DS
mov DS,BX ; 0->DS for addressing low mem.
inc BX ; BX==1 => TIPC
mov AX,DS:word ptr [01A2h] ; If TIPC then what kind?
pop DS ; get DS back
add AL,AH ; checkout vector 68 bytes 2 & 3
cmp AL,0F0h ; if AL==F0 then TIPC=Business Pro
jne pc_010 ; jump if not a B-P
in AL,068h ; Read from port
push AX ; Save for later
and AL,0FBh ; Enable CMOS
out 068h,AL ; Write back out
mov DX,8296h ; I/O address for B-P's mode byte
in AL,DX ; TI or IBM Mode on the B-P?
cmp AL,0 ; if not zero then B-P emulates a TIPC
pop AX ; Restore original port value
out 068h,AL ; and write back out
jne pc_010 ; jump if TIPC else IBM machine code is
; where it should be.
jmp short pc_007
pc_005:
mov AX,ES
cmp AH,0FEh ; test for segment offset FE00
jae pc_007 ; two checks made? if so, jump
add AH,2 ; go back and check segment offset
jmp pc_002 ; FE00
pc_007: mov AX,0F000h
mov ES,AX
mov al,byte ptr ES:0FFFEh ; IBM's machine code is @F000:FFFE
cmp AL,IBMTYPE ; Is this suckah an IBM?
jb pc_010 ; Jump if AL is below F0 (BX will be 0)
mov BL,AL
pc_010: sti ; Turn interrups back on
mov PC_MAKE,BX ; set variable PC_MAKE
pop DI
pop ES ; restore caller's ES register
ret ; return to caller
XPCTYPE endp
PROGX ends
; See PRO2REAL.ASM for above definition
ENDIF
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;For space and performance reasons, some procedures have been written in the
; following style: the arguments are popped off the stack, and the
; procedure ends in an indirect JMP instead of a RET. In this source file,
; the following are such procedures:
; zero_pag, zero_blk, get_byte, get_word, put_byte, put_word,
; get_flo, put_flo, get_str, put_str, get_sym, put_sym,
; make_ptr, alloc_fi, take_car, take_cdr
; Return Value of Stack Segment Register (SS:)
;;; public _SS
;;;_SS proc near
;;; mov AX,SS
;;; ret
;;;_SS endp
;;;; Return Value of Extra Segment Register (ES:)
;;; public _ES
;;;_ES proc near
;;; mov AX,ES
;;; ret
;;;_ES endp
;;;; Return Value of Code Segment Register (CS:)
;;; public _CS
;;;_CS proc near
;;; mov AX,CS
;;; ret
;;;_CS endp
; Return Value of Data Segment Register (DS:)
public _DS
_DS proc near
mov AX,DS
ret
_DS endp
; Zero a page in memory - Calling sequence: zero_page(page_no)
public zero_pag
zero_arg struc
dw ? ; Return address
zero_pg dw ? ; Page number
zero_arg ends
zero_pag proc near
pop DX ;Pop return address
pop BX ;Pop page number
push ES ;Save ES
sal BX,1
LoadPage ES,BX
;;; mov ES,DGROUP:pagetabl+[BX]
xor AX,AX
xor DI,DI
mov CX,psize+[BX]
shr CX,1
cld
rep stosw
pop ES ;Restore ES
jmp DX
zero_pag endp
;************************************************************************
;* Zero a block of memory *
;* *
;* Purpose: To initialize a variable length block of memory to zero. *
;* *
;* Description: The block is zeroed using the 8088's "store string" *
;* instruction using a repeat count. For *
;* efficiency reasons, the zeroing is done by *
;* words, with a fixup to account for blocks with *
;* an odd number of bytes. *
;* *
;* Calling sequence: zero_blk(page_no, disp) *
;* where page_no = page number (C's unshifted *
;* page number) *
;* disp = displacement of block within *
;* the page *
;************************************************************************
public zero_blk
zb_args struc
dw ? ; Return address
zb_page dw ? ; Page number
zb_disp dw ? ; Displacement
zb_args ends
zero_blk proc near
pop SI ;Pop return address
pop BX ; Pop the page number for the block
shl BX,1 ; and adjust for use as index
pop DI ; Pop the displacement of the block
push ES ; save the caller's ES register
LoadPage ES,BX
;;; mov ES,DGROUP:pagetabl+[BX] ; load page's paragraph address
mov CX,ES:[DI].vec_len ; and the block's length
add DI,BLK_OVHD ; and advance pointer past block header
cmp CX,0 ;;; check for small string
jge zero_010
add CX,PTRSIZE
jmp zero_020
zero_010: sub CX,BLK_OVHD ; subtract block overhead from the length
zero_020: mov DX,CX ; copy the length in bytes, and
and DX,1 ; isolate the least significant bit
shr CX,1 ; convert number of bytes to number of words
xor AX,AX ; load a value of zero into AX
cld ; set forward direction
rep stosw ; zero the block
mov CX,DX ; copy the fixup byte count
rep stosb ; zero the last byte, if odd number of bytes
pop ES ; restore ES register
jmp SI ; return to caller
zero_blk endp
; Fetch/Store byte/word
get_args struc ; Arguments Template
dw ? ; return address
get_page dw ? ; page number
get_disp dw ? ; displacement into page
get_val dw ? ; value (if a store operation)
get_args ends
; Get a byte of data
; Calling sequence: data = get_byte(page, disp)
; where: page ----- page number
; disp ----- (byte) displacement within page
public get_byte
get_byte proc near
mov CX,ES ; save caller's ES in CX
pop SI ; get return address
pop BX ; get page argument
shl BX,1 ; adjust it for segment lookup
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; get page segment
pop BX ; get displacement
mov AL,ES:[BX] ; get byte
xor AH,AH ; and only a byte
mov ES,CX ; restore ES
jmp SI ; return
get_byte endp
; Get a word of data
; Calling sequence: data = get_word(page, disp)
; where: page ----- page number
; disp ----- (byte) displacement within page
public get_word
get_word proc near
mov CX,ES ; save caller's ES in CX
pop SI ; get return address
pop BX ; get page argument
shl BX,1 ; adjust it for segment lookup
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; get page segment
pop BX ; get displacement
mov AX,ES:[BX] ; get word
mov ES,CX ; restore ES
jmp SI ; return
get_word endp
; Put a byte of data
; Calling sequence: put_byte(page, disp, value)
; where: page ----- page number
; disp ----- (byte) displacement within page
; value ---- value to be stored (low order 8 bits)
public put_byte
put_byte proc near
mov CX,ES ; save caller's ES in CX
pop SI ; get return address
pop BX ; get page
sal BX,1 ; double page number for use as index
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load page's paragraph address
pop BX ; get displacement
pop AX ; load byte to store
mov byte ptr ES:[BX],AL ; store new data
mov ES,CX ; restore segment register ES
jmp SI ; return
put_byte endp
; Put a word of data
; Calling sequence: put_word(page, disp, value)
; where: page ----- page number
; disp ----- (byte) displacement within page
; value ---- value to be stored (16 bits)
public put_word
put_word proc near
mov CX,ES ; save caller's ES in CX
pop SI ; get return address
pop BX ; load the page number
sal BX,1 ; double page number for use as index
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load page's paragraph address
pop BX ; load displacement
pop AX ; load word to store
mov word ptr ES:[BX],AX ; store new data
mov ES,CX ; restore segment register ES
jmp SI ; return
put_word endp
; Exchange a byte of data
; Calling sequence: old_data = xch_byte(page, disp, value)
; where: old_data - original data (overwritten)
; page ----- page number
; disp ----- (byte) displacement within page
; value ---- value to be stored (low order 8 bits)
; public xch_byte
;xch_byte proc near
; mov CX,ES ; save caller's ES in CX
; pop SI ; get return address
; pop BX ; get page
; sal BX,1 ; double page number for use as index
; mov ES,pagetabl+[BX] ; load page's paragraph address
; pop BX ; get displacement
; pop AX ; load byte to store
; xchg AL,byte ptr ES:[BX] ; swap old and new data
; xor AH,AH ; clear high order byte of AX
; mov ES,CX ; restore segment register ES
; jmp SI ; return
;xch_byte endp
; Exchange a word of data
; Calling sequence: old_data = xch_word(page, disp, value)
; where: old_data - original data (overwritten)
; page ----- page number
; disp ----- (byte) displacement within page
; value ---- value to be stored (16 bits)
; public xch_word
;xch_word proc near
; mov CX,ES ; save caller's ES in CX
; pop SI ; get return address
; pop BX ; load the page number
; sal BX,1 ; double page number for use as index
; mov ES,pagetabl+[BX] ; load page's paragraph address
; pop BX ; load displacement
; pop AX ; load word to store
; xchg AX,word ptr ES:[BX] ; swap old and new data
; mov ES,CX ; restore segment register ES
; jmp SI ; return
;xch_word endp
; Put a pointer
; Calling sequence: put_word(page, disp, pg_value, ds_value)
; where: old_data - original data (overwritten)
; page ----- page number
; disp ----- (byte) displacement within page
; pg_value ---- value of page number to store (16 bits)
; ds_value ---- value of displacement to store (16 bits)
public put_ptr
put_ptr proc near
mov CX,ES ; save caller's ES in CX
pop SI ; get return address
pop BX ; load the page number
sal BX,1 ; double page number for use as index
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load page's paragraph address
pop BX ; load displacement
pop AX ; load page number value to store
mov byte ptr ES:[BX],AL ; store page number
pop AX ; load displacement value to store
mov word ptr ES:[BX]+1,AX ; store page number
mov ES,CX ; restore segment register ES
jmp SI ; return
put_ptr endp
; Fetch/Store Flonum
getf_arg struc ; Arguments Template
dw ? ; caller's BP
dw ? ; return address
getf_pag dw ? ; page number
getf_dis dw ? ; displacement into page
getf_val dw ? ; value (if a store operation)
getf_arg ends
; Get a floating point value
; Calling sequence: fdata = get_flo(page, disp)
; where: page ----- page number
; disp ----- (byte) displacement within page
public get_flo
get_flo proc near
pop DI ;Pop return address
pop BX ; load the page number
sal BX,1 ; double page number for use as index
pop SI ; load displacement
inc SI ; and advance page flonum's tag
push DS ; save the caller's DS segment register
LoadPage DS,BX
;;; mov DS,pagetabl+[BX] ; load page's paragraph address
cld ;Direction forward
lodsw ;Put the flonum in AX:BX:CX:DX
mov DX,AX
lodsw
mov CX,AX
lodsw
mov BX,AX
lodsw
pop DS ; restore caller's DS segment register
jmp DI ; return
get_flo endp
; Put a flonum value into Scheme's memory
; Calling sequence: put_flo(page, disp, value)
; where: page ----- page number
; disp ----- (byte) displacement within page
; value ---- flonum value to be stored (4 words)
public put_flo
put_flo proc near
pop DX ;Pop return address
pop BX ; load the page number
sal BX,1 ; double page number for use as index
pop DI ; load displacement
inc DI ; and advance offset past flonum's tag
mov SI,SP ;SP points to flonum - point SI to it too
push ES ; save the caller's ES segment register
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load page's paragraph address
mov CX,FLOSIZE/WORDINCR ; load number of words to store
cld ; clear direction flag
rep movsw ; move the words of the flonum
pop ES ; restore the ES segment register
jmp DX ; return to caller
put_flo endp
; Transfer string to/from Scheme's memory
s_args struc
dw ? ; Caller's BP
dw ? ; Return address
sptr dw ? ; Pointer to string in C's memory
spage dw ? ; page number
sdisp dw ? ; displacement in page
lpage dw ? ; link field page number (for symbols)
ldisp dw ? ; link field displacement (for symbols)
hash_key dw ? ; hash value (for symbols)
s_args ends
public get_str,get_sym
get_str proc near
pop DX ;Pop return address
pop DI ; Fetch destination string's displacement
pop BX ; Fetch source page number
shl BX,1 ; Adjust page number for use as index
pop SI ; Fetch source string's displacement
push DS ;Save caller's DS
LoadPage DS,BX
;;; mov DS,pagetabl+[BX] ; Get source page's paragraph address
mov CX,[SI].vec_len ; Fetch length of string/symbol
add SI,offset vec_data ; Adjust for string header
cmp CX,0 ;;; check for small string
jge get_010
add CX,PTRSIZE
jmp get_mrg
get_010: sub CX,offset vec_data ; Adjust length for string header
get_mrg: cld ; clear string direction
rep movsb ; move 'em out
pop DS ; Restore DS segment register
jmp DX ;Return
get_str endp
get_sym proc near
pop DX ;Pop return address
pop DI ; Fetch destination string's displacement
pop BX ; Fetch source page number
shl BX,1 ; Adjust page number for use as index
pop SI ; Fetch source string's displacement
push DS ;Save caller's DS
LoadPage DS,BX
;;; mov DS,pagetabl+[BX] ; Get source page's paragraph address
mov CX,[SI].sym_len ; Fetch length of string/symbol
add SI,offset sym_data ; Adjust offset for symbol header
sub CX,offset sym_data ; Adjust length for symbol header
jmp get_mrg ;Get pname bytes
get_sym endp
public put_str,put_sym
put_str proc near
pop DX ;Pop return address
pop SI ; Load source string offset
pop BX ; Load destination page number,
pop DI ; and displacement
shl BX,1 ; Adjust page number for use as index
push ES ; Save caller's ES segment register
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; Load destination page paragraph address
mov CX,ES:[DI].vec_len ; Load string length
add DI,offset vec_data ; Adjust pointer for string header
cmp CX,0 ;;; check for small string
jge put_010
add CX,PTRSIZE ;;; get the right string length
jmp putmrg
put_010: sub CX,offset vec_data ; Adjust length for string header
putmrg: cld ; Clear direction flag
rep movsb ; Move 'em in
pop ES ; Restore caller's ES
jmp DX ; Return
put_str endp
put_sym proc near
pop DX ;Pop return address
pop SI ; Load source string offset
pop BX ; Load destination page number,
pop DI ; and displacement
shl BX,1 ; Adjust page number for use as index
mov CX,ES ;Save caller's ES in CX
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; Load destination page paragraph address
pop AX ; Load link field page number and
mov ES:[DI].sym_page,AL ; and move into symbol structure
pop ES:[DI].sym_disp ; Store link field displacement
pop AX ; move hash value into symbol data object
mov ES:[DI].sym_hkey,AL
push CX ;Now move caller's ES to stack
mov CX,ES:[DI].sym_len ; Load string length
add DI,offset sym_data ; Adjust displacement for symbol header
sub CX,offset sym_data ; Adjust length for symbol header
jmp putmrg ; Move 'em in
put_sym endp
; Convert page, displacement values to a long integer
public make_ptr
make_args struc
dw ? ; return address
mak_page dw ? ; page number
mak_disp dw ? ; pointer displacement
make_args ends
make_ptr proc near
pop DI
pop AX
adjpage AX
pop BX
jmp DI
make_ptr endp
; Allocate a cell for a fixnum (actually, return an immediate value)
; Calling sequence: alloc_fixnum(&reg, value)
a_fix_arg struc
dw ? ; Return address
a_reg dw ? ; Address of register to hold pointer
a_val dw ? ; Fixnum value
a_fix_arg ends
public alloc_fi
alloc_fi proc near
pop DI ;Pop return address
pop SI ; Pop address of return register
pop DX ; Pop fixnum value
sal DX,1 ; Shift out high order bit
jo a_fix_ov
a_fix_ov: ; Ignore overflow for now (create a bignum later)
shr DX,1 ; Position 15 bit quantity
mov [SI].C_disp,DX ; Store immediate value into register
mov [SI].C_page,SPECFIX*2 ; Store immediate tag
jmp DI ;Return
alloc_fi endp
;************************************************************************
;* Copy Variable Length Data Object *
;* *
;* Purpose: To create a copy of a variable length Scheme data object. *
;* *
;* Calling Sequence: copy_blk(&dest, &src) *
;* where &dest - address of VM register into which *
;* pointer to new copy is to be *
;* placed *
;* &src - address of VM register containing *
;* block to be copied *
;************************************************************************
cpy_args struc
dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; return address
cpy_dest dw ? ; address of destination register
cpy_src dw ? ; address of source register
cpy_args ends
public copy_blk
copy_blk proc near
push ES ; save caller's ES
push BP ; save caller's BP
mov BP,SP
; allocate new block
mov SI,[BP].cpy_src ; load address of source register
mov BX,[SI].C_page ; load pointer to object to be copied
mov DI,[SI].C_disp
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov AX,ES:[DI].vec_len ; load length of object
cmp AX,0 ;;; check for small string
jge copy_010
add AX,PTRSIZE ;;; adjust for small string
jmp copy_011
copy_010: sub AX,BLK_OVHD ; adjust size for block header
copy_011: push AX ; push length of "data" in block
xor AX,AX ; load type field from source block
mov AL,ES:[DI].vec_type
push AX
push [BP].cpy_dest ; push address of destination register
mov AX,DS ; make ES point to the current data
mov ES,AX ; segment
C_call alloc_bl ; allocate new block
mov SP,BP ; drop arguments off stack
; copy contents of source block into newly created block
mov BX,[BP].cpy_dest ; make ES:[DI] point to newly created
mov DI,[BX].C_disp ; block
mov BX,[BX].C_page
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BX,[BP].cpy_src ; make DS:[SI] point to source block
mov SI,[BX].C_disp
mov BX,[BX].C_page
push DS
LoadPage DS,BX
;;; mov DS,pagetabl+[BX]
mov CX,[SI].vec_len ; load length of source block
cmp CX,0 ;;; check for small string
jge copy_020
add CX,PTRSIZE
jmp copy_021
copy_020: sub CX,BLK_OVHD ; and subtract off size of block header
copy_021: mov DX,CX ; copy length (in bytes) into DX
and DX,1 ; and isolate the lsb
shr CX,1 ; convert size from bytes to words
add SI,BLK_OVHD ; advance source/destination pointers
add DI,BLK_OVHD ; past block header
rep movsw ; move contents of source to destination
mov CX,DX ; copy fixup (in case odd number of bytes)
rep movsb ; copy odd byte, if necessary
pop DS ; restore DS
; return to calling procedure
pop BP ; restore caller's BP
pop ES ; restore caller's ES
ret ; return
copy_blk endp
;;;; Make sure we haven't overflowed C's runtime stack
;;; public chk_stk
;;;chk_stk proc near
;;; mov AX,SP
;;; cmp AX,_base
;;; ja chk_ret
;;; C_call gc_on
;;; C_call exit
;;;chk_ret: ret
;;;chk_stk endp
;************************************************************************
;* C callable Routine to Take car/cdr of a List *
;************************************************************************
take_arg struc
dw ? ; caller's BP
dw ? ; return address
take_reg dw ? ; argument register address
take_arg ends
public take_car
take_car proc near
pop DX ;Pop return address
pop SI ; load argument register address
mov BX,[SI].C_page ; load list's page number
cmp byte ptr ptype+[BX],LISTTYPE*2 ; it is a list, isn't it?
jne take_err ; if not a list, error (jump)
mov CX,ES ; save caller's ES
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list's page's paragraph address
mov BX,[SI].C_disp ; load list's offset
mov AL,ES:[BX].car_page ; copy car field of list cell
mov BX,ES:[BX].car
jmp short tkmrg
; ***error-- argument register doesn't contain list-- return nil***
take_err: mov [SI].C_page,NIL_PAGE*2
mov [SI].C_disp,NIL_DISP
jmp DX ; return
take_car endp
public take_cdr
take_cdr proc near
pop DX ;Pop return address
pop SI ; load argument register address
mov BX,[SI].C_page ; load list's page number
cmp byte ptr ptype+[BX],LISTTYPE*2 ; it is a list, isn't it?
jne take_err ; if not a list, error (jump)
mov CX,ES ; save caller's ES
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list's page's paragraph address
mov BX,[SI].C_disp ; load list's offset
mov AL,ES:[BX].cdr_page ; Get cdr field of list cell
mov BX,ES:[BX].cdr
tkmrg: mov byte ptr [SI].C_page,AL ; Copy into argument register
mov [SI].C_disp,BX
mov ES,CX ; restore caller's ES
jmp DX ; return to caller
take_cdr endp
IFNDEF PROMEM
; See PRO2REAL.ASM for protected mode scheme
public pc_type
pc_type proc near
push BP
call XPCTYPE ; XPCTYPE is located at beginning of this
; program in XPROG, it determines PC type
pop BP
ret
pc_type endp
public pcinit
extrn XPCINIT:FAR
pcinit proc near
push BP
call XGROUP:XPCINIT ; XPCINIT is in GRAPHCMD.ASM - in XPROG
; it does special initialization per PC type
; also, it is called from main()
pop BP
ret
pcinit endp
; See PRO2REAL.ASM for above definitions
ENDIF
;************************************************************************
;* Symbol Hashing Routine *
;* *
;* Calling Seguence: hash_value = hash(symbol, len); *
;************************************************************************
public hash
hash proc near
pop DI ; unload return address
pop SI ; fetch symbol "string" pointer
pop CX ; fetch length
xor BX,BX ; zero accumulator
xor AH,AH
hash_1: lodsb ; fetch next character in symbol name
add BX,AX ; sum them up
loop hash_1 ; iterate 'til symbol used up
mov AX,BX ; copy sum of chars to AX
xor DX,DX
mov BX,HT_SIZE ; load divisor with hash table size
div BX ; divide sum
mov AX,DX
jmp DI ; return to caller
hash endp
;************************************************************************
;* Symbol Equality Routine *
;* *
;* Calling Sequence: equal? = sym_eq(page, disp, symbol, len); *
;************************************************************************
public sym_eq
sym_eq proc near
pop DX ; unload return address
pop BX ; fetch page number
shl BX,1 ; and adjust for word indexing
pop DI ; fetch displacement
pop SI ; fetch pointer to symbol name
pop CX ; fetch length
mov AX,ES ; save value of ES
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; laod symbol page's paragraph address
mov BX,ES:[DI].sym_len ; fetch length of symbol
sub BX,offset sym_data ; and compute character count
cmp CX,BX ; length of symbol match?
jne not_eq ; if not same length, jump
add DI,offset sym_data ; advance symbol pointer to print name
repe cmpsb ; compare symbol to name
jne not_eq ; symbols the same? if not, jump
mov ES,AX ; restore caller's ES register
jmp DX ; return (non-zero value in AX => true)
not_eq: mov ES,AX ; restore caller's ES register
xor AX,AX ; zero AX (return false value)
jmp DX ; return
sym_eq endp
prog ends
end


958
svars.asm Normal file
View File

@ -0,0 +1,958 @@
; =====> SVARS.ASM
;****************************************
;* TIPC Scheme '84 Runtime Support *
;* Interpreter -- Variable Operations *
;* *
;* (C) Copyright 1984, 1985, 1988 *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 July 1984 *
;* Modification History: *
;* ?? 10/22/85 - ?? *
;* rb 2/ 5/88 - MEMV, ASSV use EQV's *
;* definition of number equality *
;* (which is "=", *not* "equal"). *
;* *
;****************************************
include scheme.equ
include sinterp.mac
include sinterp.arg
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
m_fluid db "LD-FLUID",0
m_setfl db "SET-FLUID!",0
m_set_gl db "SET!-GLOBAL",0
m_fl_p db "FLUID-BOUND?",0
m_ve_al db "MAKE-VECTOR",0
m_vec_s db "VECTOR-SIZE",0
m_vecf db "VECTOR-FILL!",0
m_mkvt_a dw m_ve_al ; address of "MAKE-VECTOR"
m_one dw 1 ; a constant "one" (1)
m_three dw 3 ; a constant "three" (3)
m_toobig dw VECTOR_SIZE_LIMIT_ERROR ; numeric error code
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
var_int proc near
; Entry points defined in "sinterp.asm"
extrn next:near ; Top of interpreter
extrn next_PC:near ; Reload ES,SI at top of interpreter
extrn next_SP:near ; mov SP,BP before next_PC
extrn src_err:near ; "source operand error" message display
extrn sch_err:near ; Link to Scheme debugger
;************************************************************************
;* Macro support for global/fluid variable lookup *
;************************************************************************
load macro environ,err_msg,reg_p
local x,y
lods word ptr ES:[SI] ; load dest reg, constant number
save <SI> ; save current location pointer
mov BL,AL ; copy destination register number
mov DI,BX ; into TIPC register DI
mov BL,AH ; isolate constant number
IFIDN <reg_p>,<REG>
mov SI,reg0_pag+[BX] ; load page number from symbol operand reg
mov AX,reg0_dis+[BX] ; likewise for the displacement
ELSE
mov AX,BX ; BX <- constant number * 3
shl AX,1
add BX,AX
add BX,CB_dis ; add offset for start of code block
xor AX,AX
mov AL,ES:[BX].cod_cpag ; load symbol's page number
mov SI,AX
mov AX,ES:[BX].cod_cdis ; load symbol's displacement
ENDIF
cmp byte ptr ptype+[SI],SYMTYPE*2 ; reg hold a symbol pointer?
jne y ; if not, jump to error handler
push DI ; save register number
mov DX,SI ; copy symbol's page number into DX
mov DI,environ&_pag ; load fluid environment pointer
mov SI,environ&_dis
;;; LoadPage ES,DI
;;; mov ES,pagetabl+[DI] ; load paragraph address for env. header
mov BX,DI ; BX <= page number
call lookup ; search the environment for symbol
cmp BX,0 ; symbol found?
pop BX ; restore register number
je x ; if symbol not found, jump
mov AX,ES:[DI].cdr ; load symbol's value pointer
mov reg0_dis+[BX],AX ; and store into register
mov AL,ES:[DI].cdr_page
mov byte ptr reg0_pag+[BX],AL
jmp next_PC
; symbol not found-- return '***unbound***
x: mov CX,offset environ&_reg ; load address of environment reg
corrpage DX ; adjust page number for call to C routine
add BX,offset reg0 ; compute address of destintatin register
pushm <BX,CX,AX,DX> ; push page, displacement, env, dest reg
C_call sym_unde,,Load_ES ; call: symbol_undefined(pg,ds,env,dest)
;***x: mov reg0_dis+[BX],UN_DISP
;*** mov byte ptr reg0_pag+[BX],UN_PAGE*2
restore <SI> ; load next instruction's offset and
sub SI,3 ; back up PC to retry fluid load
jmp sch_err ; Link to Scheme debugger
; error-- register doesn't contain a symbol
y: lea BX,err_msg
jmp src_err ; display error message
endm
;************************************************************************
;* AL AH *
;* Fluid lookup FLUID dest,const *
;* *
;* Purpose: Interpreter support for fluid variable lookup *
;************************************************************************
public ld_fluid
ld_fluid: load FNV,m_fluid,CONST
;************************************************************************
;* AL AH *
;* Fluid lookup-register operand FLUID-R dest,sym *
;* *
;* Purpose: Interpreter support for fluid variable lookup *
;************************************************************************
public ld_fl_r
ld_fl_r: load FNV,m_fluid,REG
purge load
;************************************************************************
;* AL AH *
;* set-fluid! ST-FLUID src,const *
;* *
;* Purpose: Interpreter support for fluid assignment. *
;************************************************************************
public st_fluid
st_fluid: lods word ptr ES:[SI] ; load source reg and constant number
save <SI> ; save current value of location pointer
push AX ; save symbol/value register numbers
mov BL,AH
mov AX,BX ; BX <- constant number * 3
shl AX,1
add BX,AX
add BX,CB_dis ; add in starting offset of code block
xor AX,AX
mov AL,ES:[BX].cod_cpag ; load pointer to search symbol
mov DI,AX
cmp byte ptr ptype+[DI],SYMTYPE*2 ; really a symbol?
jne setfl_er ; if not, jump
mov DX,DI ; copy symbol's page number
mov AX,ES:[BX].cod_cdis ; load symbol's displacement
mov DI,FNV_pag ; load pointer to fluid environment
mov SI,FNV_dis
;;; LoadPage ES,DI
;;; mov ES,pagetabl+[DI]
mov BX,DI ; Page number
call lookup ; search fluid environment for symbol
cmp BX,0 ; symbol found in fluid environment?
je setfl_nf ; if not, error (jump)
pop AX ; restore operands
mov BL,AL ; copy source register number
mov AL,byte ptr reg0_pag+[BX] ; set cdr of fluid var entry
mov ES:[DI].cdr_page,AL ; to value in register
mov AX,reg0_dis+[BX]
mov ES:[DI].cdr,AX
jmp next_PC ; return to interpreter
; error-- symbol register doesn't contain a symbol pointer
setfl_er: mov BX,offset m_setfl ; load error message text
jmp src_err ; jump to "source error" routine
; error-- symbol not fluidly bound
setfl_nf: pop CX ; restore instruction's operands
xor CH,CH ; clear high order byte (constant number)
add CX,offset reg0 ; compute address of source register
corrpage DX ; convert page number to C's notation
pushm <CX,AX,DX> ; push arguments for error call
C_call not_flui,,Load_ES ; call error routine
restore <SI> ; back up location pointer to retry
sub SI,3 ; the set-fluid! operation
jmp sch_err ; link to Scheme debugger
; fluid-bound? FLUID? reg
public fluid_p
fluid_p: lods byte ptr ES:[SI] ; load the register number for test
save <SI> ; save the current location pointer
mov BX,AX ; copy register number of symbol
mov AX,reg0_dis+[BX]
mov DX,reg0_pag+[BX]
mov DI,DX
cmp byte ptr ptype+[DI],SYMTYPE*2 ; symbol pointer?
jne fl_p_er ; if not, error (jump)
mov DI,FNV_pag
mov SI,FNV_dis
;;; LoadPage ES,DI
;;; mov ES,pagetabl+[DI]
push BX
mov BX,DI ; Page number
call lookup
cmp BX,0
pop BX
je fl_p_nf
; symbol is fluidly bound-- return 't
mov AL,T_PAGE*2
mov byte ptr reg0_pag+[BX],AL
mov AX,T_DISP
mov reg0_dis+[BX],AX
jmp next_PC
; symbol not in fluid environment-- return 'nil
fl_p_nf: xor AX,AX
mov byte ptr reg0_pag+[BX],AL
mov reg0_dis+[BX],AX
jmp next_PC
; error-- operand of (fluid-bound? obj) is not a symbol
fl_p_er: lea BX,m_fl_p
jmp src_err ; display error message
;************************************************************************
;* AL AH *
;* Bind fluid variable BIND-FL const,src *
;* *
;* Purpose: Interpreter support for binding (creating and defining) *
;* fluid variables *
;* *
;* Note: At entry to this routine, ES is set to point to the beginning *
;* of the page containing the current code block. *
;************************************************************************
public bind_fl
bind_fl: lods word ptr ES:[SI] ; load src register, constant number
mov BL,AH ; copy the source register number
lea DI,reg0+[BX] ; and compute its address
; tmp_reg <- symbol
mov BL,AL ; BX <- constant number * 3
mov AX,BX
shl AX,1
add BX,AX
add BX,CB_dis ; add displacement of current code block
xor AX,AX
mov AL,ES:[BX].cod_cpag ; copy the symbol pointer into the
mov tmp_page,AX ; temporary register
mov AX,ES:[BX].cod_cdis
mov tmp_disp,AX
; cons(tmp_reg, tmp_reg, value)
mov AX,offset tmp_reg ; load address of temporary register
pushm <DI,AX,AX> ; push arguments to "cons"
C_call cons,<SI>,Load_ES ; create (cons symbol value)
; cons(FNV, tmp_reg, FNV)
mov AX,offset tmp_reg ; load address of temporary register
mov BX,offset FNV_reg ; load addr of fluid environment register
pushm <BX,AX,BX> ; push arguments to "cons"
C_call cons ; create (cons (cons symbol value) FNV)
jmp next_SP ; return to interpreter
;************************************************************************
;* Unbind fluid variable UNBIND-FL const *
;* *
;* Purpose: Interpreter support for unbinding (deleting) fluid *
;* variables *
;* *
;* Description: The fluid environment is maintained as an a-list, so *
;* dropping fluids consists of cdr-ing down the list for *
;* the required number of elements. *
;************************************************************************
public unbind_f
unbind_f: lods byte ptr ES:[SI] ; load the count of fluids to drop
mov DX,ES ; save code block's paragraph address
mov CX,AX ; copy the drop count into CX
mov BL,byte ptr FNV_pag ; load the fluid environment pointer
mov DI,FNV_dis
unb_fl: LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load entry's paragraph address
mov BL,ES:[DI].cdr_page ; load cdr field of entry
mov DI,ES:[DI].cdr
loop unb_fl ; continue cdr'ing for desired count
mov byte ptr FNV_pag,BL ; re-define the fluid environment
mov FNV_dis,DI ; register
mov ES,DX ; restore code block paragraph address
jmp next ; return to interpreter
;************************************************************************
;* Allocate vector VEC-ALLOCATE dest *
;* *
;* Purpose: Interpreter support for the allocation of vector data *
;* objects. *
;* *
;* Note: Vectors are set to zero after they are allocated to insure *
;* that all entries are valid Scheme pointers. Zeroing a *
;* vector effectively sets all the entries to nil. *
;* If an array were not initialized, the garbage collector *
;* would interpret any leftover data as pointers, and *
;* might cause the Scheme Virtual Machine to go off the *
;* deep end. *
;************************************************************************
public vec_allo
vec_allo: lods byte ptr ES:[SI] ; load destination register number
save <SI> ; save the location pointer
mov BX,AX ; and copy it to TIPC register BX
add BX,offset reg0
cmp byte ptr [BX].C_page,SPECFIX*2 ; is size a fixnum?
jne ve_al_er ; if not, error (jump)
mov AX,[BX].C_disp ; load immediate value from register
shl AX,1 ; and sign extend it
sar AX,1
cmp AX,0 ; value positive?
jl ve_al_er ; if not, error (jump)
cmp AX,10921 ; check against maximum vector size
ja v_toobig ; if too many elements, error (jump)
mov CX,AX ; AX <- AX * 3 (multiply number of
shl AX,1 ; elements by size of pointer)
add AX,CX
mov CX,VECTTYPE ; load type of block to allocate
pushm <AX,CX,BX> ; push arguments
C_call alloc_bl,,Load_ES ; call: alloc_block(&reg, type, size)
pop BX ; recover address of reg holding vector ptr
mov AX,[BX].C_page ; fetch page number from destination reg
corrpage AX ; correct for C callable routine
pushm <[BX].C_disp,AX> ; push page and displacement
C_call zero_blk ; call: zero_blk(page, disp)
jmp next_SP ; return to interpreter
; ***Error-- invalid source operand for vec-alloc***
ve_al_er: mov SI,[BX].C_page ; load operand's page number
cmp byte ptr ptype+[SI],BIGTYPE*2 ; is it a bignum?
je v_toobig ; if so, print "vector too big" message
lea BX,m_ve_al ; otherwise, print "source operand"
jmp src_err ; error message
; ***Error-- vector too large***
v_toobig: restore <SI>
sub SI,2
pushm <SI,m_mkvt_a>
C_call disassem,,Load_ES
pushm <tmp_adr,m_toobig,m_one>
C_call set_nume
jmp sch_err
;************************************************************************
;* Vector size VECTOR-SIZE dest *
;* *
;* Purpose: Interpreter support for the vector-size function to return *
;* the number of elements in a vector data object. *
;* *
;* Description: The number of elements in a vector data object is *
;* determined by dividing the number of bytes (obtained *
;* from the block header of the vector data object) by the *
;* number of bytes in a pointer (3), and subtracting the *
;* overhead of the block header (3 bytes). *
;************************************************************************
public vec_size
vec_size: lods byte ptr ES:[SI] ; load destination register number
mov BX,AX ; and copy into TIPC register BX
save <SI> ; save the location pointer
mov SI,reg0_pag+[BX] ; load page number field of register
cmp ptype+[SI],VECTTYPE*2 ; is object a vector?
jne vec_s_er ; if not, error (jump)
mov DI,reg0_dis+[BX] ; load displacement of vector
LoadPage ES,SI
;;; mov ES,pagetabl+[SI] ; load vector's page paragraph address
mov AX,ES:[DI].vec_len ; load size of object (in bytes),
xor DX,DX ; extend to double word,
mov CX,3 ; load divisor of three,
idiv CX ; divide no. bytes by pointer size
dec AX ; subtract off block overhead
mov reg0_dis+[BX],AX ; store number of elements
mov byte ptr reg0_pag+[BX],SPECFIX*2 ; set tag=fixnum
jmp next_PC ; return to interpreter
; ***error-- operand doesn't point to a vector data object***
vec_s_er: lea BX,m_vec_s
jmp src_err ; display error message
;************************************************************************
;* AL AH *
;* vector fill vec-fill vect,val*
;* *
;* Purpose: Scheme intepreter support for the vector-fill operation *
;************************************************************************
public vec_fill
vec_fill: lods word ptr ES:[SI] ; load operands
save <SI> ; save location pointer
xor BX,BX
mov BL,AL ; copy number of register containing vector
mov DI,reg0_dis+[BX] ; load vector pointer
mov BL,byte ptr reg0_pag+[BX]
cmp byte ptr ptype+[BX],VECTTYPE*2 ; is it really a vector?
jne vecf_err ; if not, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load page address of vector's page
mov BL,AH ; copy pointer to fill value
mov AX,reg0_dis+[BX] ; load value to fill array
mov DL,byte ptr reg0_pag+[BX]
mov CX,ES:[DI].vec_len ; load vector length (in bytes) and
sub CX,BLK_OVHD ; subtract off overhead for block header
jle vecf_fin ; if zero length vector, we're done
vecf_lp: mov ES:[DI].vec_page,DL ; store value into current element
mov ES:[DI].vec_disp,AX ; of vector
add DI,PTRSIZE ; increment pointer into vector
sub CX,PTRSIZE ; decrement array size
jg vecf_lp ; if more elements to define, loop (jump)
vecf_fin: jmp next_PC ; return to Scheme interpreter
vecf_err: lea BX,m_vecf
jmp src_err
;************************************************************************
;* AL AH *
;* (memq obj,list) MEMQ dest,src*
;* *
;* Purpose: Scheme interpreter support for the memq primitive *
;************************************************************************
; Support for SHIFT-BREAK-- restart operation
memq_sb: push m_three ; indicate instruction length = 3
C_call restart ; link to Scheme debugger
public memq
memq: lods word ptr ES:[SI] ; load operands
save <SI> ; save the current location pointer
mov BL,AL ; compute the destination register
memq_x: lea DI,reg0+[BX] ; address in TIPC register DI
mov AL,byte ptr [DI].C_page ; copy search object pointer
mov DX,[DI].C_disp ; into AL,DX (page, disp, respectively)
mov BL,AH ; copy pointer to search list
mov SI,reg0_dis+[BX] ; load contents of "list" register
mov BL,byte ptr reg0_pag+[BX]
jmp memq_go
memq_nxt: cmp byte ptr s_break,0 ; has shift-break been depressed?
jne memq_sb ; if interrupt, jump
mov BL,ES:[SI].cdr_page ; load cdr field and continue
mov SI,ES:[SI].cdr ; search
memq_go: cmp BL,0 ; nil pointer?
je memq_f ; if so, return nil (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2 ; "list" object a list cell?
jne memq_f ; if not, return nil (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load paragraph address of list cell
cmp DX,ES:[SI].car ; does displacement field of car match obj?
jne memq_nxt ; if not, test next element in list (jump)
cmp AL,ES:[SI].car_page ; does page field of car match obj?
jne memq_nxt ; if not, test next element in list (jump)
; match found-- return pointer to current list cell
mov byte ptr [DI].C_page,BL ; set destination register to point
mov [DI].C_disp,SI ; to current list cell
jmp next_PC ; return to interpreter
; no match-- return 'nil
memq_f: xor AX,AX ; put null value into destination register
mov byte ptr [DI].C_page,AL
mov [DI].C_disp,AX
jmp next_PC ; return to interpreter
;************************************************************************
;* AL AH *
;* (memv key,list) MEMV dest,src *
;* key, list *
;* *
;* Purpose: Scheme interpreter support for the memv primitive *
;************************************************************************
memv_sb: jmp memq_sb ; shift-break support-- link to debugger
public memv
memv: lods word ptr ES:[SI] ; load operands
save <SI> ; save the current location pointer
mov BL,AL ; compute the destination register
mov DI,reg0_pag+[BX] ; load page number of search object
; The following 3 lines are sufficient for MEMV if EQV doesn't require
; an = test for numbers and only checks types instead. All the remaining
; code for MEMV is to handle =.
; test attrib+[DI],FLONUMS+BIGNUMS+STRINGS
; jz memv_x ; unless one of above types, use "memq"
; jmp short memv_y ; otherwise, use full "member" test
test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS+STRINGS
jz memv_x ; unless one of above types, use "memq"
test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS
jz memv_y ; for strings do "member" test
; key is a number
lea DI,reg0[BX] ; DI=address of VM reg containing key
mov BL,AH
lea SI,reg0[BX] ; SI=address of VM reg containing list
push [SI].C_page ; tempsave "list" VM reg
push [SI].C_disp
jmp short memv_nxt
memv_x: jmp memq_x ; these damn short relative jumps!!
memv_y: jmp member_x
; this list element didn't match, go to the next element
memv_more: cmp s_break,0 ; shift-break (IBM: control-break) pressed?
jne memv_sb ; yes, do break
mov BX,[SI].C_disp ; cdr our way down list
mov AL,ES:[BX].cdr_page
mov AH,0
mov [SI].C_page,AX
mov AX,ES:[BX].cdr
mov [SI].C_disp,AX
; loop over each element in the list
memv_nxt: mov BX,[SI].C_page
cmp BX,NIL_PAGE ; at end of list?
je memv_f ; yes, jump
cmp byte ptr ptype[BX],LISTTYPE*2 ; looking at a cons?
jne memv_f ; no, jump
LoadPage ES,BX ; get cons into memory
mov BX,[SI].C_disp ; ES:BX=address of cons cell
mov BL,ES:[BX].car_page
mov BH,0
test attrib[BX],FIXNUMS+FLONUMS+BIGNUMS ; is list elt numeric?
jz memv_more ; no, jump
; key and list element are both numeric
mov tmp_reg.C_page,BX
mov BX,[SI].C_disp
mov BX,ES:[BX].car
mov tmp_reg.C_disp,BX
lea BX,tmp_reg
; begin comparison of key and list element
cmp byte ptr [DI].C_page,SPECFIX*2 ; is key a fixnum?
jne memv_float ; no, jump
cmp byte ptr [BX].C_page,SPECFIX*2 ; is list elt a fixnum?
jne memv_float ; no, jump
; both key and list element are fixnums
mov AX,[BX] ; AX=list elt
mov DX,[DI] ; DX=key
shl AX,1
shl DX,1
cmp AX,DX ; same number?
jne memv_more ; no, jump
; we have a match, copy list object-pointer to VM register containing key
memv_t: mov AX,[SI].C_disp
mov [DI].C_disp,AX
mov AX,[SI].C_page
mov [DI].C_page,AX
jmp short memv_f1
; we have no match, copy '() to VM register containing key
memv_f: xor AX,AX
mov [DI].C_page,AX
mov [DI].C_disp,AX
memv_f1: pop [SI].C_disp ; restore original contents "list" VM reg
pop [SI].C_page
jmp next_PC ; return to interpreter
; key and list element are not both fixnums, do = operation
memv_float: mov AX,EQ_OP
pushm <ES,DI,SI> ; save our state around C call
pushm <BX,DI,AX> ; list elt, key, operation
C_call arith2,,Load_ES ; do =
popm <SI,SI,SI> ; get C args off stack
popm <SI,DI,ES> ; restore our state
cmp AX,0 ; AX negative means "error"
jge memv_flo2 ; nope
jmp sch_err ; yes, go to error handler
memv_flo2: jg memv_t ; AX positive means "true"
jmp memv_more ; no match, go to next list element
;************************************************************************
;* AL AH *
;* (member key,list) MEMBER dest,src *
;* key, list *
;* *
;* Purpose: Scheme interpreter support for the member primitive *
;************************************************************************
memb_sb: jmp memq_sb ; shift-break support-- link to debugger
public member
member: lods word ptr ES:[SI] ; load operands
save <SI> ; save the current location pointer
mov BL,AL
mov DI,reg0_pag+[BX] ; load search object's page number
test attrib+[DI],FIXNUMS+SYMBOLS+CONTINU+CLOSURE+PORTS+CODE+CHARS
jz member_x ; if not one of these, use "equal?" compare
jmp memq_x ; otherwise, use "memq" test
member_x: lea DI,reg0+[BX] ; address in TIPC register DI
mov CL,byte ptr [DI].C_page ; load pointer to object in CL:DX
mov DX,[DI].C_disp
mov BL,CL
mov CH,byte ptr ptype+[BX] ; load type code of search object
mov BL,AH ; copy pointer to search list
mov SI,reg0_dis+[BX] ; load contents of "list" register
mov BL,byte ptr reg0_pag+[BX]
jmp memb_go
memb_mor: mov AX,BX
mov BL,ES:[SI].car_page
cmp CH,byte ptr ptype+[BX]
jne memb_nxt
pushm <AX,CX,DX,SI> ; save registers across call
xor AX,AX
mov AL,ES:[SI].car_page
mov [BP].temp_reg.C_page,AX ; temp_reg <- (car list)
mov AX,ES:[SI].car
mov [BP].temp_reg.C_disp,AX
lea BX,[BP].temp_reg ; load address of temporary register
pushm <BX,DI> ; push arguments
C_call sequal_p,,Load_ES ; call: sequal_p(&dest,&src)
pop DI ; retrieve destination register address
add SP,WORDINCR ; dump other arguments from stack
popm <SI,DX,CX,BX> ; restore registers
LoadPage ES,BX ; restore page paragraph address
cmp AX,0 ; were values equal?
jne memb_fnd ; if so, jump
memb_nxt: cmp s_break,0 ; has shift-break key been depressed?
jne memb_sb ; if interrupt, jump
mov BL,ES:[SI].cdr_page ; load cdr field and continue
mov SI,ES:[SI].cdr ; search
memb_go: cmp BL,0 ; nil pointer?
je memb_f ; if so, return nil (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2 ; "list" object a list cell?
jne memb_f ; if not, return nil (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load paragraph address of list cell
cmp DX,ES:[SI].car ; does displacement field of car match obj?
jne memb_mor ; if not, test next element in list (jump)
cmp CL,ES:[SI].car_page ; does page field of car match obj?
jne memb_mor ; if not, test next element in list (jump)
; "eq" match found-- return pointer to current list cell
memb_fnd: mov byte ptr [DI].C_page,BL ; set destination register to point
mov [DI].C_disp,SI ; to current list cell
jmp next_PC ; return to interpreter
; no match-- return 'nil
memb_f: xor AX,AX ; put null value into destination register
mov byte ptr [DI].C_page,AL
mov [DI].C_disp,AX
jmp next_PC ; return to interpreter
;************************************************************************
;* AL AH *
;* (assq obj,list) ASSQ obj,list*
;* *
;* Purpose: Scheme interpreter support for the assq primitive *
;************************************************************************
public assq
assq: lods word ptr ES:[SI] ; load operands
save <SI> ; save the location pointer
assq_go: mov BL,AH ; copy the list register number
mov SI,reg0_pag+[BX]
cmp ptype+[SI],LISTTYPE*2 ; is second operand a list?
jne assq_err ; if not, error(?) (jump)
LoadPage ES,SI
mov DI,SI ; Save page number
;;; mov ES,pagetabl+[SI] ; load list page's paragraph address
mov SI,reg0_dis+[BX] ; load pointer to list operand
mov BL,AL ; load object register number
mov DX,reg0_pag+[BX] ; load pointer to search object
mov AX,reg0_dis+[BX]
push BX ; save destination register number
mov BX,DI ; Pass the page number
call lookup ; search list for eq? comparison of obj
pop SI ; restore destination register number
mov byte ptr reg0_pag+[SI],BL ; store result of search in
mov reg0_dis+[SI],DI ; the destination register
jmp next_PC ; return to interpreter
; ***second operand is not a list-- return nil***
assq_err: mov BL,AL ; copy destination register number
xor AX,AX
mov byte ptr reg0_pag+[BX],AL ; store nil into destination
mov reg0_dis+[BX],AX ; register
jmp next_PC ; return to interpreter
;************************************************************************
;* AL AH *
;* (assv key,alist) ASSV key,alist *
;* *
;* Purpose: Scheme interpreter support for the assv primitive *
;************************************************************************
assv_sb: jmp memq_sb ; shift-break support-- link to debugger
public assv
assv: lods word ptr ES:[SI] ; load operands
save <SI> ; save the location pointer
mov BL,AL ; get number of VM register containing key
mov DI,reg0_pag+[BX] ; load key's page number
; The following 3 lines are sufficient for ASSV if EQV doesn't require
; an = test for numbers and only checks types instead. All the remaining
; code for ASSV is to handle =.
; test attrib+[SI],FLONUMS+BIGNUMS+STRINGS ; one of these?
; jz assq_go ; if not one of above, use assq (jump)
; jmp short assoc_go ; if one of the above, use assoc
test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS+STRINGS
jz assv_x ; unless one of above types, use "assq"
test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS
jz assv_y ; for strings do "assoc" test
; key is a number
lea DI,reg0[BX] ; DI=address of VM reg containing key
mov BL,AH
lea SI,reg0[BX] ; SI=address of VM reg containing list
push [SI].C_page ; tempsave "alist" VM reg
push [SI].C_disp
jmp short assv_nxt
assv_x: jmp assq_go ; these damn short relative jumps!!
assv_y: jmp assoc_go
; this list element didn't match, go to the next element
assv_more: cmp s_break,0 ; shift-break (IBM: control-break) pressed?
jne assv_sb ; yes, do break
mov BX,[SI].C_page
LoadPage ES,BX ; get toplevel cons back into memory
mov BX,[SI].C_disp ; ES:BX=address of toplevel cons cell
mov AL,ES:[BX].cdr_page ; cdr down the alist
mov AH,0
mov [SI].C_page,AX
mov AX,ES:[BX].cdr
mov [SI].C_disp,AX
; loop over each element in the list
assv_nxt: mov BX,[SI].C_page
cmp BX,NIL_PAGE ; at end of list?
je assv_f ; yes, jump
cmp byte ptr ptype[BX],LISTTYPE*2 ; looking at a cons?
jne assv_f ; no, jump
LoadPage ES,BX ; get toplevel cons into memory
mov BX,[SI].C_disp ; ES:BX=address of toplevel cons cell
push BX ; tempsave it
mov BL,ES:[BX].car_page
mov BH,0
cmp byte ptr ptype[BX],LISTTYPE*2 ; is car of toplevel cons also a cons?
je assv_down ; yes, jump
assv_pop: pop BX ; normalize stack
assv_more1: jmp assv_more ; look at next toplevel cons
assv_down: mov DX,BX
pop BX ; (ES:BX=address of toplevel cons again)
mov BX,ES:[BX].car ; DX:BX=object ptr to 2nd level cons
LoadPage ES,DX ; ES:BX=address of 2nd level cons cell
push BX ; tempsave it
mov BL,ES:[BX].car_page
mov BH,0
test attrib[BX],FIXNUMS+FLONUMS+BIGNUMS ; is its car numeric?
jz assv_pop ; no, jump
mov tmp_reg.C_page,BX ; yes, move car ptr into tmp_reg
pop BX ; (ES:BX=address of 2nd level cons again)
mov BX,ES:[BX].car
mov tmp_reg.C_disp,BX
lea BX,tmp_reg ; BX=address of tmp_reg
; begin comparison of key and list element
cmp byte ptr [DI].C_page,SPECFIX*2 ; is key a fixnum?
jne assv_float ; no, jump
cmp byte ptr [BX].C_page,SPECFIX*2 ; is list elt a fixnum?
jne assv_float ; no, jump
; both key and list element are fixnums
mov AX,[BX] ; AX=list elt
mov DX,[DI] ; DX=key
shl AX,1
shl DX,1
cmp AX,DX ; same number?
jne assv_more1 ; no, jump
jmp short assv_t
; we have no match, copy '() to VM register containing key
assv_f: xor AX,AX
mov [DI].C_page,AX
mov [DI].C_disp,AX
assv_f1: pop [SI].C_disp ; restore original contents "alist" VM reg
pop [SI].C_page
jmp next_PC ; return to interpreter
; we have a match, copy list object-pointer to VM register containing key
assv_t: mov BX,[SI].C_page
LoadPage ES,BX
mov BX,[SI].C_disp ; ES:BX=address of toplevel cons
mov AX,ES:[BX].car ; move car of this cons to dest. register
mov [DI].C_disp,AX
mov AL,ES:[BX].car_page
mov AH,0
mov [DI].C_page,AX
jmp assv_f1 ; return to interpreter
; key and list element are not both fixnums, do = operation
assv_float: mov AX,EQ_OP
pushm <ES,DI,SI> ; save our state around C call
pushm <BX,DI,AX> ; list elt, key, operation
C_call arith2,,Load_ES ; do =
popm <SI,SI,SI> ; get C args off stack
popm <SI,DI,ES> ; restore our state
cmp AX,0 ; AX negative means "error"
jge assv_flo2 ; nope
jmp sch_err ; yes, go to error handler
assv_flo2: jg assv_t ; AX positive means "true"
jmp assv_more ; no match, go to next list element
;************************************************************************
;* AL AH *
;* (assoc obj,list) ASSOC obj,list*
;* *
;* Purpose: Scheme interpreter support for the assoc primitive *
;* *
;* Register Usage: DX - address of destination register *
;* ES:SI - pointer to current list cell *
;************************************************************************
public assoc
assoc: lods word ptr ES:[SI] ; load operands
save <SI> ; save the location pointer
mov BL,AL ; copy search object's register number
mov SI,reg0_pag+[BX] ; load search object's page number
test attrib+[SI],FIXNUMS+SYMBOLS+CONTINU+CLOSURE+PORTS+CODE+CHARS
jz assoc_go
jmp assq_go ; if one of the above, use assq (jump)
assoc_go: mov DX,BX ; copy obj's reg number into TIPC reg DX
add DX,offset reg0 ; compute address of search obj register
mov BL,AH ; copy list register number
mov SI,reg0_dis+[BX] ; load displacement pointer of "list"
mov BL,byte ptr reg0_pag+[BX] ; load page number of "list"
assoc_lp: cmp BL,0 ; end of list? (nil pointer?)
je assoc_nf ; if end of list, jump
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is list operand a list?
jne assoc_er ; if not, error(?) (jump)
LoadPage ES,BX
mov AX,BX ;****** SAVE PAGE *********
;;; mov ES,pagetabl+[BX] ; load list page's paragraph address
mov BL,ES:[SI].car_page ; load page number of car
cmp byte ptr ptype+[BX],LISTTYPE*2 ; does car point to list cell?
jne assoc_nl ; if not a list cell, jump
mov DI,ES:[SI].car ; load displacement pointer of car field
pushm <AX,SI> ;****** REALLY SAVE PAGE****
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
xor AX,AX
mov AL,ES:[DI].car_page ; copy car field into tmp_reg
mov tmp_page,AX
mov AX,ES:[DI].car
mov tmp_disp,AX
mov AX,offset tmp_reg
pushm <DX,AX> ; push arguments to call
C_call sequal_p,,Load_ES ; compare equality of the two pointers
add SP,WORDINCR ; dump tmp_reg address
pop DX ; restore obj/dest register address
popm <SI,BX> ; restore ES,SI registers
LoadPage ES,BX ;********** Restore Para Address *****
cmp AX,0 ; were pointers equal?
jne assoc_t ; if equal, jump
assoc_nl: xor BX,BX ; clear high order byte of BX
mov BL,ES:[SI].cdr_page ; follow cdr field
mov SI,ES:[SI].cdr
cmp byte ptr s_break,0 ; has the shift-break key been depressed?
je assoc_lp ; if no shift-break, loop
jmp memq_sb ; if interrupt, jump to debugger support
; pointers "equal"-- return pointer to car field of current list cell
assoc_t: mov DI,DX ; copy destination register address to DI
mov AL,ES:[SI].car_page ; return cdr field of list cell
mov byte ptr [DI].C_page,AL
mov AX,ES:[SI].car
mov [DI].C_disp,AX
jmp next_PC ; return to interpreter
; end of search, or error detected-- return nil
assoc_er:
assoc_nf: mov DI,DX ; copy destination register address to DI
mov byte ptr [DI].C_page,NIL_PAGE*2 ; store nil pointer into
mov [DI].C_disp,NIL_DISP ; destination register
jmp next_PC ; return to interpreter
var_int endp
;************************************************************************
;* Lookup Symbol is Assoc List *
;* *
;* Purpose: To search a linked list for a given pointer *
;* *
;* Description: The list to be searched has the following format: *
;* *
;* +--------+--------+ +--------+-------+ *
;* +-->|symbol->|value ->| +-->|symbol->|value->| *
;* | +--------+--------+ | +--------+-------+ *
;* | | *
;* +---+----+--------+ +---+----+--------+ *
;* | o | o----+----...----->| o | (nil) | *
;* +--------+--------+ +--------+--------+ *
;* *
;* The symbol portion of the list entries are compared against the *
;* search symbol for an identical match. When found, a pointer to *
;* the matched symbol's symbol-value entry is returned. If the *
;* symbol is not found, a value of nil is returned. *
;* *
;* Registers upon entry: AX - search symbol's displacement *
;* BX - page number of list to search *
;* DL - search symbol's page number *
;* SI - displacement within page number *
;* of list to search *
;* *
;* Registers on exit: BL - page number of cell whose car is the *
;* search symbol, or zero if not found *
;* DI - displacement of list cell found, or nil *
;* ES:[DI] - points to cell found *
;************************************************************************
public lookup
lookup proc near
lookloop:
mov CX,BX ; Save Page number
LoadPage ES,BX ; Load Paragraph address of page
mov BL,ES:[SI].car_page ; load car of next list cell in the list
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is car a list cell?
mov DI,ES:[SI].car
jne look_err ; if not a list cell, jump
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load paragraph address of its page
cmp AX,ES:[DI].car ; does car's disp match search symbol's?
jne look_nf ; if not, keep searching (jump)
cmp DL,ES:[DI].car_page ; does car's page match search symbol's?
je look_fnd ; if so, we've got a match (jump)
; no match-- continue through linked list
look_nf: mov BX,CX ; restore page number
LoadPage ES,BX
mov BL,ES:[SI].cdr_page ; load the cdr field
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is cdr another list cell?
jne look_err ; if not, error(?)
mov SI,ES:[SI].cdr
cmp BX,0 ; is cdr nil?
jne lookloop ; if not, branch
xor DI,DI ; make BX:DI nil
look_fnd: ret ; return pointer to caller
;
look_err: xor BX,BX ; create a nil pointer to return
xor SI,SI
ret
lookup endp
;************************************************************************
;* C-callable Fluid Variable Lookup *
;* *
;* Purpose: To retrieve the fluid binding for a variable. *
;* *
;* Calling Sequence: stat = fluid_lookup(&reg) *
;* where &reg - address of the register containing *
;* the symbol to be looked up. *
;* On exit, "reg" contains the *
;* current binding for the symbol, *
;* if found. *
;* stat - search status: TRUE=symbol found *
;* FALSE=symbol not found *
;* *
;* Note: If the call to "lookup" doesn't find the desired symbol, it *
;* will return a nil pointer. It is correct to always *
;* return the cdr of the pointer "lookup" returns, since *
;* the cdr of nil is itself nil-- a valid value. *
;************************************************************************
fl_lk_ar struc
dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; return address
fl_lk_rg dw ? ; register address
fl_lk_ar ends
public fluid_lo
fluid_lo proc near
push ES ; save caller's ES
push BP ; and BP
mov BP,SP
; load pointer to search symbol in DL:AX
mov BX,[BP].fl_lk_rg ; load register address
mov AX,[BX].C_disp
mov DL,byte ptr [BX].C_page
; load pointer to search list (fluid environment) in ES:[SI]
mov BX,FNV_pag
mov SI,FNV_dis
;;; LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
; search the fluid environment for the symbol
call lookup
; store "cdr" of returned cell into register
mov SI,[BP].fl_lk_rg
mov AL,ES:[DI].cdr_page
mov byte ptr [SI].C_page,AL
mov AX,ES:[DI].cdr
mov [SI].C_disp,AX
; set return code (BX=0 if symbol not found) and return
mov AX,BX
pop BP ; restore caller's BP
pop ES ; and ES
ret ; return to caller
fluid_lo endp
prog ends
end


46
sw_int.asm Normal file
View File

@ -0,0 +1,46 @@
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
public isw_int,fsw_int,tsw_int,ssw_int
SWI_ARGS struc
OLDBP DW ?
RET_ADDR DW ?
INT_NUM DW ?
AX_ARG DW ?
BX_ARG DW ?
CX_ARG DW ?
DX_ARG DW ?
SWI_ARGS ends
sw_int proc near
isw_int:
fsw_int:
tsw_int:
ssw_int:
push bp ; Save Base Pointer
mov bp,sp ; Update with Stack Pointer
mov ax,[bp].INT_NUM ; Get interrupt number
mov cs:int_no,al ; Move to location in code
mov ax,[bp].AX_ARG ; Load ax register with 1st arg
mov bx,[bp].BX_ARG ; Load bx register with 2nd arg
mov cx,[bp].CX_ARG ; Load cx register with 3rd arg
mov dx,[bp].DX_ARG ; Load dx register with 4th arg
db 0CDh ; Byte code for INT instruction
int_no db 070h ; Byte code for interrupt number
pop bp
ret ; and go back to the caller.
sw_int endp
prog ends
end


16
version.h Normal file
View File

@ -0,0 +1,16 @@
#ifdef REGMEM
#define VERSION "\n PC Scheme 3.03 07 June 88"
#endif
#ifdef EXPMEM
#define VERSION "\n PC Scheme 3.03 Expanded Memory Version 07 June 88"
#endif
#ifdef EXTMEM
#define VERSION "\n PC Scheme 3.03 Extended Memory Version 07 June 88"
#endif
#ifdef PROMEM
#define VERSION "\n PC Scheme 4.0 Protected Memory Version 24 June 88"
#endif


1371
xli.asm Normal file
View File

File diff suppressed because it is too large Load Diff

70
xli.equ Normal file
View File

@ -0,0 +1,70 @@
; XLI constants
; note: if N_EXE is ever made larger, examine macro "load_index" also
XLI_ID equ 4252h ;XLI version number
;(PCS 3.0, 3.02 XLI id = 4252)
N_EXE equ 10 ;no. of .EXE files allowed
N_ARGS equ 16 ;no. of xesc args allowed
N_RV equ 4 ;no. of return values
;same as for SW-INT: 0-3, with same meaning
SWI_TF equ 1 ;SW-INT true/false return value
SWI_STR equ 2 ;SW-INT string return value
RV_ERR equ 10 ;error return value code
PAD_SIZE equ 8 ;max size of 1 elementary data type,
;which is size of 1 elt in work_area
;(flonum/double)
; XLI errors
XLI_ERR_UNKNOWN_LENGTH equ 1 ;fatal error
XLI_ERR_NAME_BAD_TYPE equ 2
;XLI_ERR_MISMATCHED_LENGTH equ 3
XLI_ERR_ARGN_BAD_TYPE equ 4
XLI_ERR_VALUE_BAD_TYPE equ 5
XLI_ERR_NO_SUCH_NAME equ 6
XLI_ERR_BIG_TO_32_BITS equ 7
XLI_ERR_SYNC_ERR equ 8
XLI_ERR_RELMEM equ 9
XLI_ERR_NO_MEMORY equ 10
XLI_ERR_BAD_EXEC equ 11
XLI_ERR_NO_AVAILABLE_SLOTS equ 12
XLI_ERR_NO_SUCH_FILE equ 13
XLI_ERR_BIG_TO_16_BITS equ 14
XLI_ERR_BAD_VERSION equ 15
XLI_ERR_EXTERNAL_ERROR equ 16
; DOS function requests
FR_TSR equ 3100h ;TSR (keep process)
FR_OPEN equ 3D00h ;open file
FR_CLOSE equ 3E00h ;close file
FR_READ equ 3F00h ;read from file
FR_RELMEM equ 4900h ;release memory block
FR_EXEC equ 4B00h ;bid (exec) child process
FR_FIND1 equ 4E00h ;find match file
; .EXE states
EXE_NONE equ 0 ;this spot is open (haven't EXEC'ed child)
EXE_TSR equ 1 ;have EXEC'ed child but not yet TSR'ed it
EXE_NORM equ 2 ;child loaded and waiting
EXE_TERM equ 3 ;child terminating
; File block flags
FB_NEAR equ 01h ;1=copy to child's space (near data)
;0=no copy (far data)
FB_INT equ 02h ;1=convert PCS integers to 16-bit int's
;0=convert to 32-bit longint's
FB_KEEPENV equ 04h ;1=don't release child's env block
;0=we do it for child automatically
FB_PAD equ 08h ;1=space each arg in dest 8 bytes apart
;0=pack args contiguously
FB_SYSINT equ 10h ;1=system callable routine
;0=normal xli routine
; Special services
SS_SWAP equ 1 ;swap
; PSP offsets
env_ptr equ 02Ch ;env block offset
fb_ptr equ 05Ch ;file block offset


181
xli.mac Normal file
View File

@ -0,0 +1,181 @@
subttl Macro definitions
; In segment 'segzero' set $ to the next multiple of 'n'.
align macro n,segzero
org $ - (($-segzero) MOD n) + n
endm
; Issue a DOS function request (int 21h) after
; setting up registers ax,bx,cx,dx,ds,es.
; Registers not specified are not affected by the macro,
; code to move a reg to itself is skipped, and
; moves between DS and ES are handled.
dos_fr macro rax,rbx,rcx,rdx,rds,res
ifnb <rax> ;;ax
ifidn <rax>,<ax>
else
mov ax,rax
endif
endif
ifnb <rbx> ;;bx
ifidn <rbx>,<bx>
else
mov bx,rbx
endif
endif
ifnb <rcx> ;;cx
ifidn <rcx>,<cx>
else
mov cx,rcx
endif
endif
ifnb <rdx> ;;dx
ifidn <rdx>,<dx>
else
mov dx,rdx
endif
endif
ifnb <res> ;;es
ifidn <res>,<ds>
push ds
pop es
else
ifidn <res>,<es>
else
mov es,res
endif
endif
endif
ifnb <rds> ;;ds
ifidn <rds>,<es>
push es
pop ds
else
ifidn <rds>,<ds>
else
mov ds,rds
endif
endif
endif
int 21h
endm
; Given the value of "active_exe", put into BX the corresponding byte offset
; into various tables. If table="itself", just load BX.
;
; Note: The calculated byte offset must fit into BL because we use BH for
; scratch. We don't affect any other register this way. If the
; number of entries allowed in the tables is enlarged so that we
; could overflow into BH, this macro will need changing. Changing
; a table's format will obviously affect this macro too.
load_index macro table
mov bx,active_exe
ifdif <itself>,<table>
xor bh,bh
endif
ifidn <load_table>,<table>
shl bx,1 ;; 2 bytes/entry
endif
ifidn <fb_table>,<table>
shl bx,1 ;; 4
shl bx,1
endif
ifidn <pb_table>,<table>
shl bx,1 ;; 4
shl bx,1
endif
ifidn <state_table>,<table>
mov bh,bl
shl bx,1 ;;shift BH and BL simultaneously
shl bl,1
shl bl,1
add bl,bh ;; 10
xor bh,bh
endif
ifidn <status_table>,<table>
shl bx,1 ;; 2
endif
endm
; *** All registers on entry except CS,IP belong to the child. ***
; *** On exit, all registers except CS,IP,DS still belong to the child. ***
; This routine captures all the child's registers' values (except CS:IP,
; which is located on the stack at the saved SS:SP).
; DS is changed to PCS's data segment.
save_state macro
push ds ;pushes are in child's data segment
push ax
mov ax,data
mov ds,ax ;DS points to PCS's data segment
pop ax ;get back ax
mov save_ax,ax
mov save_bx,bx
mov save_cx,cx
mov save_dx,dx
mov save_si,si
mov save_di,di
pop ax ;get back ds (stack now same as on entry)
mov save_ds,ax
mov save_es,es
mov save_ss,ss
mov save_sp,sp
mov save_bp,bp
endm
; Save the parent's (i.e. PCS's) segment and pointer registers.
save_parent macro
mov pcs_state.st_es,es ;save our state
mov pcs_state.st_ss,ss
mov pcs_state.st_sp,sp
mov pcs_state.st_bp,bp
mov pcs_state.st_ds,ds
endm
; Restore the parent's segment and pointer registers.
restore_parent macro
mov bx,offset pcs_state ;restore parent's state
cli
mov es,[bx].st_es
mov ss,[bx].st_ss
mov sp,[bx].st_sp
mov bp,[bx].st_bp
;; mov ds,[bx].st_ds ;save_state made DS active already
sti
endm
; Save off our registers and restore child's, then resume child.
call_child macro x
save_parent
load_index state_table
lea bx,state_table[bx]
cli ; restore child's state
mov es,[bx].st_es
mov ss,[bx].st_ss
mov sp,[bx].st_sp
mov bp,[bx].st_bp
mov ds,[bx].st_ds
sti
xlidbg&x label byte
nop ;;this gets replaced with INT 3 for debug
nop
db 0CBh ;resume child via far return
endm
; Save off child's registers and restore ours, then continue.
resume_parent macro
save_state ;save child's registers in global area
restore_parent
load_index state_table
lea bx,state_table[bx]
mov ax,save_ds ;save child's regs in child-local area
mov [bx].st_ds,ax
mov ax,save_es
mov [bx].st_es,ax
mov ax,save_ss
mov [bx].st_ss,ax
mov ax,save_sp
mov [bx].st_sp,ax
mov ax,save_bp
mov [bx].st_bp,ax
endm


185
xli_pro.mac Normal file
View File

@ -0,0 +1,185 @@
IFNDEF BLOCK_XFER
BLOCK_XFER equ 0EC00h ; Block Transfer
ENDIF
IFNDEF DOS
DOS equ 021h ; Dos Function Request
ENDIF
;MOVE_ARGS_TO_BUF
; Move the specified arguments to a buffer. If the buffer is not
; specified, then ES:DI is assumed to contain the address of the
; buffer.
;
; The specified args are pushed onto the local stack, and the
; address noted in DS:SI. The args are then moved to the
; specifed buffer.
move_args_to_buf macro args,realaddr,autobump,save
numbytes = 0
irp x,<args>
numbytes = numbytes + 2
push x
endm
IFNB <realaddr>
les di,dword ptr ss:&realaddr
ENDIF
mov cx,numbytes
mov si,sp
move_to_real_buf autobump,save
add sp,numbytes
endm
;MOVE_TO_REAL_BUF
; Move CX number of bytes from DS:SI to buffer specifed in ES:DI.
; Since the destination may be in real mode, use the AIA Dos
; extended function Block_Xfer.
move_to_real_buf macro autobump,save_offset
mov ax,BLOCK_XFER
int DOS
IFNB <autobump>
IFE direction
add di,cx
ELSE
sub di,cx
ENDIF
ENDIF
IFNB <save_offset>
mov ss:&real_buf_offset,di
ENDIF
endm
;MOVE_BYTE_TO_BUF
; Move one byte from the buffer specified in DS:SI to the
; destination address in ES:DI.
MOVE_BYTE_TO_BUF macro byt,realaddr,autobump
IFNB <realaddr>
les di,dword ptr ss:&realaddr
ENDIF
sub sp,2
mov si,sp
mov byte ptr ss:[si],byt
mov cx,1
mov ax,BLOCK_XFER
int DOS
IFNB <autobump>
IFE direction
inc di
ELSE
dec di
ENDIF
ENDIF
add sp,2
endm
;MOVE_ARGS_FROM_BUF
; Get the specified arguments from a buffer. If the buffer is not
; specified, then ES:DI is assumed to contain the address of the
; buffer.
;
; The number of bytes specified by the args is allocated on
; the local stack, and the address noted in DS:SI. The args
; are then moved from the desired buffer onto the local stack,
; and popped into the desired args.
move_args_from_buf macro args,realaddr
numbytes = 0
irp x,<args>
numbytes = numbytes + 2
endm
IFNB <realaddr>
les di,dword ptr ss:&realaddr
ENDIF
mov cx,numbytes
sub sp,cx
mov si,sp
move_from_real_buf
irp x,<args>
pop x
endm
endm
;MOVE_FROM_REAL_BUF
; Move CX number of bytes from the buffer specified in ES:DI to
; the destination address in DS:SI. Swap the source and
; destination registers and perform the AIA Dos extended function
; Block_Xfer (in case the source buffer is in real memory).
move_from_real_buf macro
mov bx,es
mov dx,ds
mov ds,bx
mov es,dx
xchg di,si
mov ax,BLOCK_XFER
int DOS
mov ds,dx
mov es,bx
xchg di,si
endm
;REAL_BYTE_TO REG
; Move a byte from the buffer specified by DS:SI to a register.
;
; ES must equal SS
real_byte_to_reg macro reg,autobump
push cx
mov cx,1
sub sp,2
mov di,sp
mov ax,BLOCK_XFER
int DOS
mov al,byte ptr es:[di]
IFNB <autobump>
inc si
ENDIF
add sp,2
pop cx
endm
reset_real_buffer_offset macro
mov ss:real_buf_offset,0
endm
save_real_buffer_offset macro arg
IFNB <arg>
mov ss:&real_buf_offset,arg
ELSE
mov ss:&real_buf_offset,di
ENDIF
endm
direction = 0 ; direction flag for autoincr/autdecr
real_buffer_stack = 0 ; treat buffer as stack
buffer_is_stack macro
direction = 1
endm
get_real_buffer_stack macro
mov bx,ss:&real_buf_top
mov ss:&real_buf_offset,bx
direction = 1
endm
get_real_buffer macro
les di,dword ptr ss:&real_mode_buffer
endm
buffer_is_buffer macro
direction = 0
endm
get_real_buffer_top macro reg
mov reg,ss:real_buf_top
endm
get_buffer macro
buffer_is_buffer
reset_real_buffer_offset
get_real_buffer
endm
rls_buffer macro
reset_real_buffer_offset
endm

850
zio.asm Normal file
View File

@ -0,0 +1,850 @@
; =====> ZIO.ASM
;****************************************
;* TIPC Scheme Runtime Support *
;* File IO - MS-DOS Version 2.1 *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 21 January 1985 *
;* Last Modification: 26 September 1986 *
;****************************************
page 60,132
include scheme.equ
include pcmake.equ
MSDOS equ 021h
TI_CRT equ 049h
IBM_CRT equ 010h
TI_KEYBD equ 04Ah
IBM_KEYB equ 016h
MAX_COLS equ 80
MAX_ROWS equ 25
CURSMASK equ 10011111b ; The zeros are the bits that disable cursor
NOCURSOR equ 00100000b ; byte mask to disable cursor
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
public zapcurs,curs_sav, ega_col, ega_row
zapcurs dw 0 ; for disabling cursor altogether
curs_sav dw 400Ch ; For saving the cursor size when it's
; disabled. Default value just in case...
ega_col db ?
ega_row db ?
c_row dw ?
c_col dw ?
c_len dw ?
banka dw 0a000h
sav_di dw ?
extrn vid_mode:word
extrn cur_off:byte
extrn char_hgt:word
data ends
XGROUP group progx
progx segment word public 'progx'
assume CS:XGROUP
extrn z%border:far ; border drawer
extrn crt_dsr:far ; use machine appropriate VIDEO interrupt
extrn save%scr:far ; save screen
extrn rest%scr:far ; restore screen
extrn ega_curs:far ; display an ega cursor
extrn enable:far ; part of the ega cursor routine
;************************************************************************
;* Generate a Bell Character *
;* *
;* Purpose: To generate a "bell character" (i.e., make a noise) to *
;* simulate the effect of outputting a bell character *
;* (control-G) in the output stream. *
;* *
;* Calling Sequence: zbell(); *
;* *
;* Input Parameters: None. *
;* *
;* Output Parameters: None. *
;* *
;************************************************************************
public zbell
zbell proc far
cmp DGROUP:PC_MAKE,TIPC
jne zbmbell
zbwait: mov AH,1 ; Get speaker status
int 48h
jnz zbwait ; wait for bell to turn off
mov AH,2 ; Set speaker frequency
mov CX,1563 ; Value for 1.25MHz/800Hz (system beep)
int 48h
mov AX,000Ah ; Turn speaker on for AL*25-ms. 0Ah = .25-sec
int 48h
ret ; return to caller
;
zbmbell: mov BX,080h ; ****Copied from IBM-PC/XT BIOS listing****
in AL,61h
push AX ; Save
beep_cycle: and AL,0FCh ; Turn off timer gate and speaker data
out 61h,AL ; output to control
mov CX,48h ; Half cycle time for TONE
here: loop here ; speaker off
or AL,2 ; Turn speaker on
out 61h,AL
mov CX,48h
here2: loop here2
dec BX ; Decrease cycle count
jnz beep_cycle
pop AX
out 61h,AL
ret
zbell endp
public zch_rdy
zch_rdy proc far
; IFDEF extmem ; Kludge to fix hanging keyboard
; mov AL,0AEh ; Ensure keyboard enabled
; out 64h,AL ; Output to 8042 controller
; ENDIF
mov AH,01h ; load "check keyboard status" function code
cmp pc_make,TIPC ; TI or IBM flavored PC?
jne zch_IBM
int TI_KEYBD ; issue TI keyboard DSR service call
jz zch_no ; is character buffered? if not, jump
zch_yes: xor AH,AH ; clear high order byte of AX
cmp AL,0 ; test next character to be read
jne zch_ret ; binary zero? if not, jump
mov AX,256 ; if character is 0, make it non-zero
zch_ret: ret ; return (true)
zch_IBM: int IBM_KEYB ; issue IBM keyboard DSR service call
jnz zch_yes ; is character buffered? if so, jump
zch_no: xor AX,AX ; set result = false
ret ; return (false)
zch_rdy endp
zop_args struc
dd ? ; far CS and IP
dw ? ; caller's BP
dw ? ; return address
zhandle dw ? ; address of handle
zpathnam dw ? ; address of string containing file pathname
zmode dw ? ; mode: 0=read, 1=write, 2=read/write
zhigh dw ? ; address of high word of file size
zlow dw ? ; address of low word of file size
zop_args ends
public z%open
z%open proc far
push BP ; save caller's BP
mov BP,SP
mov AH,03Dh ; load function request id
mov AL,byte ptr [BP].zmode ; load access code (mode)
mov DX,[BP].zpathnam ; load pointer to pathname
int MSDOS ; issue open request
jc zop_ret ; if error, jump
mov BX,[BP].zhandle ; load address of handle
mov [BX],AX ; and store returned handle value
;
push AX ; save file handle
mov BX,AX ; set bx to file handle
xor CX,CX
xor DX,DX
mov AX,4202h ; poisition file pointer at eof
int MSDOS
;
mov BX,[BP].zhigh ; load address of hsize
mov [BX],DX ; and store returned hsize value
mov BX,[BP].zlow ; load address of lsize
mov [BX],AX ; and store returned lsize value
;
pop BX ; retrieve file handle
xor CX,CX
xor DX,DX
mov AX,4200h ; reset file pointer to begining of file
int MSDOS
;
xor AX,AX ; set return code for normal return
zop_ret: pop BP ; restore caller's BP
ret ; return
z%open endp
public z%create
z%create proc far
push BP ; save caller's BP
mov BP,SP
mov AH,03Ch ; load function request id
mov DX,[BP].zpathnam ; load pointer to pathname
mov CX,020h ; create with "archive" attribute
int MSDOS ; issue create request
jc zcr_ret ; if error, jump
mov BX,[BP].zhandle ; load address of handle
mov [BX],AX ; and store returned handle value
xor AX,AX ; set return code for normal return
zcr_ret: pop BP ; restore caller's BP
ret ; return
z%create endp
public z%close
z%close proc far
push BP ; save caller's BP
mov BP,SP
mov AH,03Eh ; load function request id
mov BX,[BP].zhandle ; load handle of file to close
int MSDOS ; issue close request
jc zcl_ret ; if error, jump
xor AX,AX ; set return code for normal return
zcl_ret: pop BP ; restore caller's BP
ret ; return
z%close endp
zrw_args struc
dd ? ; far cs and ip
dw ? ; caller's BP
dw ? ; return address
dw ? ; zhandle (use previous equate)
zbuffer dw ? ; input/output buffer
zlength dw ? ; address of length value
zrw_args ends
public z%read
z%read proc far
push BP ; save caller's BP
mov BP,SP
mov AH,03Fh ; load function request id
mov DX,[BP].zbuffer ; load address of input buffer
mov BX,[BP].zlength ; load address of length value
mov CX,[BX] ; then load length for read
mov BX,[BP].zhandle ; load file's handle
int MSDOS ; issue create request
jc zrd_ret ; if error, jump
mov BX,[BP].zlength ; load address of length parameter
mov [BX],AX ; and store number of characters read
xor AX,AX ; set return code for normal return
zrd_ret: pop BP ; restore caller's BP
ret ; return
z%read endp
public z%write
z%write proc far
push BP ; save caller's BP
mov BP,SP
mov AH,040h ; load function request id
mov DX,[BP].zbuffer ; load address of input buffer
mov BX,[BP].zlength ; load address of length value
mov CX,[BX] ; then load length for write
mov BX,[BP].zhandle ; load file's handle
int MSDOS ; issue write request
jc zwr_ret ; if error, jump
mov BX,[BP].zlength ; load address of length parameter
mov [BX],AX ; and store number of characters written
xor AX,AX ; set return code for normal return
zwr_ret: pop BP ; restore caller's BP
ret ; return
z%write endp
strd struc
dd ? ; far cs and ip
dw ?,? ;Caller's BP, Return address
strdpg dw ? ;Page, displacement of port
strdds dw ?
strdbuf dw ? ;Buffer address
strdlen dw ? ;Length address
strd ends
public string%rd
string%rd proc far
push BP
mov BP,SP
push DS ;Save caller's DS, ES
mov AX,ES ; (and make AX nonzero as well)
mov BX,[BP].strdlen ;Load CX with number of chars to transfer
mov CX,[BX]
mov DI,[BP].strdpg ;Get port page
mov DX,DI ; and save for later
%LoadPage DS,DI ;Get para address
mov DI,[BP].strdds ;DS:DI point to port
mov SI,word ptr[DI+car].pt_ptr ;Point DS:SI to string
mov BL,[DI+car_page].pt_ptr
xor BH,BH
%LoadPage DS,BX
;;; mov DS,ES:pagetabl+[BX]
cmp byte ptr[SI],STRTYPE ;Is this a string?
jne nostr ;Jump if not (error)
mov BX,[SI].str_len ;Else fetch string length
cmp BX,0 ;;; check for small string
jge strn_01
add BX,BLK_OVHD+PTRSIZE
strn_01: %LoadPage ES,DX ;Restore ptr to port
mov DX,ES:[DI].pt_ullin ;Fetch position within string
sub BX,DX ;Set BX to # of chars left
jns notpast ;If not negative, skip
xor BX,BX ;Set # of chars left to 0
notpast: cmp BX,CX ;Set CX to # of chars left or maximum
jae max ; called for, whichever is smaller
mov CX,BX
max: add SI,DX ;Adjust SI into string
add DX,CX ;Reset pointer into string
mov ES:[DI].pt_ullin,DX
mov ES,AX ;Restore C's ES
mov DI,[BP].strdbuf ;Point DI to buffer
xor AX,AX ;Prepare to return 0 (all's well)
jmp short storlen ;Store # of chars
nostr: xor CX,CX ;When not a string, move no chars
storlen: mov BX,[BP].strdlen ;Set LENGTH to # of chars read
mov ES:[BX],CX
rep movsb ;Transfer bytes
pop DS ;Restore caller's DS
pop BP
ret
string%rd endp
;************************************************************************
;* Buffered Keyboard Input *
;* *
;* Calling Sequence: ch = getch(); *
;* where ch - the character read from the keyboard *
;************************************************************************
public get%ch
get%ch proc far
; IFDEF extmem ; Kludge to fix hanging keyboard
; mov AL,0AEh ; Ensure keyboard enabled
; out 64h,AL ; Output to 8042 controller
; ENDIF
mov AH,07h ; function code = Direct Console Input
int MSDOS ; do it
xor AH,AH ; clear the high order byte
ret ; return to caller
get%ch endp
z%ega proc far
mov AX,banka
mov ES,AX ; set ES to the video plane
mov AX,c_row ; set AX to the row
mul char_hgt ; multiply by the character height
mov BX,80 ; multiply by 80 bytes per line
mul BX
add AX,c_col ; add in the starting column
mov sav_di,AX ; save the starting value
xor BX,BX ; use BX as a counter
mov DX,c_len ; number of columns to blank
zc_03: mov CX,DX ; restore counter
mov DI,sav_di ; restore index
mov AH,0fh
call enable ; enable all banks
xor AX,AX ; clear AX
cld
rep stosb
add sav_di,80 ; next line
inc BX ; increment counter
cmp BX,char_hgt ; done with this row?
jne zc_03
xor BX,BX ; clear counter
dec [BP].zc_nrows ; decrement row count
jg zc_03 ; if more rows, loop (jump)
ret
z%ega endp
progx ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;************************************************************************
;* Create a File *
;* *
;* Calling sequence: stat = zcreate(handle, pathname) *
;* where: int *handle - location to store handle *
;* returned by open request*
;* char *pathname - zero terminated string *
;* containing the file's *
;* pathname *
;* int stat - the completion code *
;* 0=no errors *
;* 3=path not found *
;* 4=too many open files *
;* 5=access denied *
;************************************************************************
public zcreate
zcreate proc near
call z%create
ret ; return
zcreate endp
;************************************************************************
;* Open a File *
;* *
;* Calling sequence: stat = zopen(handle, pathname, access_code) *
;* where: int *handle - location to store handle *
;* returned by open request*
;* char *pathname - zero terminated string *
;* containing the file's *
;* pathname *
;* int access_code - 0=read, 1=write, *
;* 2=read and write *
;* int stat - the completion code *
;* 0=no errors *
;* 2=file not found *
;* 4=too many open files *
;* 5=access denied *
;* 12=invalid access *
;************************************************************************
public zopen
zopen proc near
call z%open
ret ; return
zopen endp
;************************************************************************
;* Close a File *
;* *
;* Calling sequence: stat = zclose(handle) *
;* where: int handle - handle returned by open *
;* request *
;* int stat - the completion code *
;* 0=no errors *
;* 6=invalid handle *
;************************************************************************
public zclose
zclose proc near
call z%close
ret ; return
zclose endp
;************************************************************************
;* Read From a File *
;* *
;* Calling sequence: stat = zread(handle, buffer, length) *
;* where: int handle - handle returned by open *
;* request *
;* char *buffer - address of character *
;* buffer into which data *
;* is to be read *
;* int *length - on input, the maximum *
;* number of characters *
;* which the buffer will *
;* hold. On output, the *
;* number of characters *
;* actually read. Note: *
;* a return value of zero *
;* characters read *
;* indicates end of file. *
;* int stat - the completion code *
;* 0=no errors *
;* 5=access denied *
;* 6=invalid handle *
;************************************************************************
public zread
zread proc near
call z%read
ret ; return
zread endp
;************************************************************************
;* Write to a File *
;* *
;* Calling sequence: stat = zwrite(handle, buffer, length) *
;* where: int handle - handle returned by open *
;* char *buffer - address of character *
;* buffer from which data *
;* is to be written *
;* int *length - on input, the number of *
;* characters to write. *
;* The actual number of *
;* characters which were *
;* written is returned in *
;* "length" *
;* int stat - the completion code *
;* 0=no errors *
;* 5=access denied *
;* 6=invalid handle *
;************************************************************************
public zwrite
zwrite proc near
call z%write
ret ; return
zwrite endp
;************************************************************************
;* Clear a Window *
;************************************************************************
zc_args struc
dw ? ; caller's BP
dw ? ; return address
zc_row dw ? ; upper left hand corner row number
zc_col dw ? ; upper left hand corner column number
zc_nrows dw ? ; number of rows
zc_len dw ? ; line length (number of characters)
zc_attrib dw ? ; character attributes
zc_args ends
public zclear
zclear proc near
push BP ; save caller's BP
mov BP,SP
push ES
push DI
push AX
push BX
push CX
push DX
; Put cursor at beginning of next row
zc_loop: mov DL,byte ptr [BP].zc_row ; load current row number
mov DH,byte ptr [BP].zc_col ; load starting column number
xor BH,BH ; page number (0 if in graphics mode)
mov AH,02H ; load "put cursor" code
call crt_dsr ; position the cursor
; Write line of blanks at current cursor position
mov AX,0920h ; load write char/attr code + blank (= 20h)
xor BH,BH ; (for IBM-PC BH=display page #)
mov BL,byte ptr [BP].zc_attrib ; load attribute flag
cmp vid_mode,14 ; IBM EGA modes?
jl zc_01
cmp BL,87h ; attribute is rv white?
jne zc_22
mov AX,09dbh ; use the block character not the blank
and BL,7fh ; strip off the xor bit
zc_01: mov CX,[BP].zc_len ; load number of times to write the blank
call crt_dsr ; perform the write
; Increment row number, decrement row count, test, loop
inc [BP].zc_row ; increment row number
dec [BP].zc_nrows ; decrement row count
jg zc_loop ; if more rows, loop (jump)
; Return to caller
zc_end: pop DX
pop CX
pop BX
pop AX
pop DI
pop ES
pop BP ; restore caller's BP
ret ; return
; clear out the line by writing directly to the graphics planes
zc_22: mov AX,[BP].zc_row ; set AX to the row
mov c_row,AX
mov AX,[BP].zc_col ; add in the starting column
mov c_col,AX
mov AX,[BP].zc_len ; number of columns to blank
mov c_len,AX
call z%ega ; restore counter
jmp zc_end ; return
zclear endp
;************************************************************************
;* Draw Border *
;************************************************************************
zb_args struc
dw ? ; caller's BP
dw ? ; return address
zb_line dw ? ; upper left corner line number
zb_col dw ? ; upper left corner column number
zb_nlines dw ? ; number of lines
zb_ncols dw ? ; number of columns
zb_battr dw ? ; border attributes
zb_label dw ? ; pointer to label text
zb_args ends
public zborder
zborder proc near
call z%border
ret
zborder endp
;************************************************************************
;* Link to Save Screen Support *
;************************************************************************
public save_scr
save_scr proc near
call save%scr
ret
save_scr endp
;************************************************************************
;* Link to Restore Screen Support *
;************************************************************************
public rest_scr
rest_scr proc near
call rest%scr
ret
rest_scr endp
;************************************************************************
;* Cursor Off *
;************************************************************************
public zcuroff
zcuroff proc near
call ega_curs
mov AH,03
xor BH,BH ; IBM page number/must be 0 for graphics mode
call crt_dsr ; get the cursor position/mode
cmp zapcurs,0
jne zcoff_01
mov curs_sav,CX ; save it for restoration
zcoff_01:
and CH,CURSMASK ; mask off bits to select cursor type
or CH,NOCURSOR ; disables cursor (turns it off)
mov AH,01h ; load "set cursor type" code
call crt_dsr ; turn the cursor off
ret ; return to caller
zcuroff endp
;************************************************************************
;* Cursor On *
;************************************************************************
public zcuron
zcuron proc near
cmp zapcurs,0 ; if cursor disabled
jne zcon_ret ; then return
mov CX,curs_sav ; attributes for cursor on
mov AH,01h ; load "set cursor type" code
call crt_dsr ; turn the cursor on
zcon_ret:
ret ; return to caller
zcuron endp
;************************************************************************
;* Put Cursor *
;************************************************************************
public zputcur
zputcur proc near
push BP ; save caller's BP
mov BP,SP
; put cursor in desired location
mov DH,byte ptr [BP].zc_col ; load column number
mov ega_col,DH
mov DL,byte ptr [BP].zc_row ; load row number
mov ega_row,DL
xor BH,BH ; IBMism: page number (0 if in graphics mode)
mov AH,02H ; load "put cursor" code
call crt_dsr ; position the cursor (DSR swaps DH/DL)
call ega_curs ; display cursor for ega mode
; Return to caller
pop BP ; restore caller's BP
ret ; return
zputcur endp
;************************************************************************
;* Scroll a Window *
;************************************************************************
zs_args struc
dw ? ; caller's BP
dw ? ; return address
zs_line dw ? ; upper left hand corner line number
zs_col dw ? ; upper left hand corner column number
zs_nline dw ? ; number of lines
zs_ncols dw ? ; number of columns
zs_attr dw ? ; text attributes (used for blanking)
zs_args ends
public zscroll
zscroll proc near
push BP ; save caller's BP
mov BP,SP
push AX
push BX
push CX
push DX
; scroll window's text up one line
mov CL,byte ptr [BP].zs_nline ; load number of lines
dec CL ; decrease number of lines by one
jz blank1 ; Jump if scrolling 1-line and just blank it
mov CH,byte ptr [BP].zs_ncols ; load number of columns
mov DL,byte ptr [BP].zs_line ; load upper left line number
mov DH,byte ptr [BP].zs_col ; load upper left column number
mov AX,0601h ; load "scroll text" code with no blanking
cmp DGROUP:PC_MAKE,TIPC
je ti_scrl
;;;;;;;;; cmp vid_mode,14
;;;;;;;;; jge txt_mod ; treat ega modes as text
cmp vid_mode,4 ; Are we in graphics mode?
jl txt_mod ; If we are then fix blank fill attributes
cmp vid_mode,7 ; so that the bar characters don't show up
je txt_mod
xor BH,BH ; zero attribute for fill blanks
jmp short rite_atr
txt_mod: mov BH,byte ptr [BP].zs_attr ; Blanked lines' attribute txt mode
rite_atr: xchg CX,DX ; CX=Upper left corner
xchg CH,CL ; Row,column instead of TI's column,row
xchg DH,DL ; ditto
add DX,CX ; DX=Lower right corner
dec DL ; adjust column count (0 is first column)
int IBM_CRT
jmp short z_quit ; IFF IBM is in graphics mode weird char's
; are used for blanks when scrolling. Do
; as TIPC does and "manual" blank 'em.
;
ti_scrl: mov BX,DX ; copy destination coordinates
inc DL ; compute source by incrementing line number
int TI_CRT ; perform block move
; paint the last line of the window with blank of proper attributes
blank1: mov DH,byte ptr [BP].zs_col ; load starting column number
mov DL,byte ptr [BP].zs_line ; load upper line number
add DL,byte ptr [BP].zs_nline ; add the number of lines and
dec DL ; subtract offf one
mov AH,02h ; load "put cursor" code
xor BH,BH ; IBMism
call crt_dsr ; position cursor for write
mov AX,0920h ; load "write char/attr" code, write a blank
mov BL,byte ptr [BP].zs_attr ; load attribute bit setting
cmp vid_mode,14 ; ega mode?
jl z_scr01
mov BH,BL
and BH,80h
cmp BH,80h ; reverse video?
jne z_scr01
mov AX,09dbh ; change for block character
and BL,7fh ; strip off xor bit
z_scr01: xor BH,BH ; IBMism
mov CX,[BP].zs_ncols ; load line length
call crt_dsr ; write a line of blanks
; return to caller
z_quit: pop DX ; restore caller's BP
pop CX
pop BX
pop AX
pop BP
ret
zscroll endp
;************************************************************************
;* Output Character To Window *
;************************************************************************
zp_args struc
dw ? ; caller's BP
dw ? ; return address
zp_line dw ? ; cursor position - line number
zp_col dw ? ; cursor position - column number
zp_char dw ? ; character to write
zp_attr dw ? ; character's attributes
zp_args ends
public zputc
zputc proc near
push BP ; save caller's BP
mov BP,SP
push DX
push CX
push BX
push AX
; position cursor for write
mov DL,byte ptr [BP].zp_line ; load line number
mov DH,byte ptr [BP].zp_col ; load column number
xor BH,BH ; IBMism
mov AH,02h ; load "put cursor" code
call crt_dsr ; positio the cursor
mov BL,byte ptr [BP].zp_attr ; load its attributes
cmp vid_mode,14 ; only attribute for EGA modes is a
jl zchar_1 ; simulated reverse video
mov BH,BL ; save the attribute
and BH,80h ; reverse video?
jz zchar_1 ; zero indicates bit 8 not set
zchar_2: and BL,7fh ; strip off high bit
mov CX,1 ; character count
xor BH,BH ; video page number
mov AL,0dbh ; block character
mov AH,09h
call crt_dsr
or BL,80h ; set xor bit
; write the characters with attributes
zchar_1: mov AL,byte ptr [BP].zp_char ; load the character
xor BH,BH ; IBMism
mov CX,1 ; repeat count = 1
mov AH,09h ; load write char/attribute code
call crt_dsr
; return to caller
pop AX
pop BX
pop CX
pop DX
pop BP
ret
zputc endp
;************************************************************************
;* Buffered Keyboard Input *
;* *
;* Calling Sequence: ch = getch(); *
;* where ch - the character read from the keyboard *
;************************************************************************
public getch
getch proc near
call get%ch
ret ; return to caller
getch endp
;************************************************************************
;* Read characters from a string *
;* *
;* Calling Sequence: stringrd(page, disp, buffer, &length) *
;* where page,disp: location of string-fed port *
;* buffer and length are as in ZREAD (see above) *
;* *
;* Note: The passing parameter `page' is page # *
;************************************************************************
public stringrd
stringrd proc near
call string%rd
ret
stringrd endp
;***************************************************************************
;* Link for routines in PROGX *
;***************************************************************************
extrn shft_brk:near
extrn dos_err:near
public shft%brk
public dos%err
shft%brk proc far
call shft_brk ;link to SHF BREAK process
ret
shft%brk endp
dos%err proc far
call dos_err ;link to DOS fatal error process
ret
dos%err endp
;
public char_rdy
char_rdy proc near ;our equivalent of Lattice C's kbhit fn
call zch_rdy
ret
char_rdy endp
prog ends
end