diff --git a/conio.h b/conio.h new file mode 100644 index 0000000..f5ceaff --- /dev/null +++ b/conio.h @@ -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 + \ No newline at end of file diff --git a/ctype.h b/ctype.h new file mode 100644 index 0000000..edf71bd --- /dev/null +++ b/ctype.h @@ -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 + diff --git a/dos.h b/dos.h new file mode 100644 index 0000000..582562c --- /dev/null +++ b/dos.h @@ -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 + diff --git a/dos.mac b/dos.mac new file mode 100644 index 0000000..cd41b6c --- /dev/null +++ b/dos.mac @@ -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 + diff --git a/freesp.equ b/freesp.equ new file mode 100644 index 0000000..79829bd --- /dev/null +++ b/freesp.equ @@ -0,0 +1,2 @@ +dog equ 1 + \ No newline at end of file diff --git a/math.h b/math.h new file mode 100644 index 0000000..93f424e --- /dev/null +++ b/math.h @@ -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 + diff --git a/memtype.equ b/memtype.equ new file mode 100644 index 0000000..5156db3 --- /dev/null +++ b/memtype.equ @@ -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 + \ No newline at end of file diff --git a/memtype.h b/memtype.h new file mode 100644 index 0000000..dd31952 --- /dev/null +++ b/memtype.h @@ -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 + \ No newline at end of file diff --git a/pcmake.equ b/pcmake.equ new file mode 100644 index 0000000..dcefb2e --- /dev/null +++ b/pcmake.equ @@ -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 + \ No newline at end of file diff --git a/pcmake.h b/pcmake.h new file mode 100644 index 0000000..fa58b55 --- /dev/null +++ b/pcmake.h @@ -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 + \ No newline at end of file diff --git a/prosprin.asm b/prosprin.asm new file mode 100644 index 0000000..814d744 --- /dev/null +++ b/prosprin.asm @@ -0,0 +1,1403 @@ +; ======> PROSPRIN.ASM +;************************************************************************ +;* PC Scheme Runtime Support - Sexpression Print Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 24 March 1986 * +;* * +;* Modifications: * +;* * +;* 11/27/87 (tc) Rewritten for protected mode scheme. Also * +;* modified to buffer the output more effectively. * +;* * +;************************************************************************ + page 60,132 + title PC Scheme Print Handlers + include scheme.equ + include sinterp.arg + include xli_pro.mac + +NUMBER_SPECIAL_CHARS equ 8 ;special chars defined in cread.asm + +RETURN equ 0Dh +SPACE equ 20h +SYM_OVHD equ 7 +HEAPERR equ -3 + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public display, show, ccount +;from sread.asm + extrn test_ch:word + extrn t_array:word +;from xli_pro.asm + extrn rpc_handle:byte + extrn REAL_MODE_BUFFER:dword + extrn REAL_BUF_OFFSET:word,REAL_BUF_SELECTOR:word + extrn REAL_BUF_PARA:word,REAL_BUF_TOP:WORD +;from iosupport.asm + extrn port_seg:word,port_pg:word,port_ds:word +;from ??? + extrn hicases:byte + +;Table of strange characters used by printatm +stranges db " ,'" + db ';":()`' + db 13,12,11,10,9,0 + +; +; The following global data is used to tell the print handlers about +; the print characteristics, ie. to surround strings with double quotes, +; to display escape characters, etc. +; +; +display dw 0 ; whether to surround atoms/strings with | or " +show dw 1 ; whether actually printing chars or not +ccount dw 0 ; char count used to determine print length + +; +; Branch table of all Scheme object print handlers +; +branchtab dw sp_list ; [0] LISTTYPE + dw sp_fix ; [1] FIXTYPE + dw sp_flo ; [2] FLOTYPE + dw sp_big ; [3] BIGTYPE + dw sp_sym ; [4] SYMTYPE + dw sp_str ; [5] STRTYPE + dw sp_ary ; [6] ARYTYPE + dw sp_cont ; [7] CONTTYPE + dw sp_clos ; [8] CLOSTYPE + dw sp_free ; [9] FREETYPE + dw sp_code ; [10] CODETYPE + dw subp_ret ; [11] REFTYPE + dw sp_port ; [12] PORTTYPE + dw sp_char ; [13] CHARTYPE + dw sp_env ; [14] ENVTYPE + +; +; Following text will be output for those objects which have not +; printable representations. +; +port_str db "#",0 +parens db "()",0 +cont_str db "#",0 +ary_str db "#(" +free_str db "#",0 +code_str db "#",0 +env_str db "#",0 +clos_str db "#",0 +ab_write db "[WARNING: Output aborted by SHIFT-BREAK]",0 +bad_set db "[VM INTERNAL ERROR] setadr: bad port",CR,LF,0 + +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + extrn next_SP:near + extrn src_err:near + extrn get_port:near + extrn setabort:near,abort:near + extrn take_cdr:near,restart:near,stkspc:near + extrn copybig:near,fix2big:near,big2asc:near,get_flo:near + extrn isspace:near + extrn gvchars:near,ssetadr:near + extrn scannum:near + +comment | Commented out 2/10/88 by TC - moved to realio routine + +;****************************************************************************** +;WRAP - Local macro definition. If there are less than LEN spaces left on +; the local output line, make AX non-zero to denote wrap necessary. +; +; Note: es:di are destroyed +;****************************************************************************** +wrap macro len,result + local wrapend + push es + push di + xor result,result ;result = default no wrap + cmp show,0 ;are we actually printing? + jz wrapend ; no, just return with default + LoadPage es,port_pg + mov di,port_ds ;es:di => port object + cmp es:[di].pt_ncols,0 ;maintaining line length? + jz wrapend ; no, return default + cmp es:[di].pt_ccol,1 ;in the first column already? + jle wrapend ; yes, return default + mov result,es:[di].pt_ncols ;ax = number cols + sub result,es:[di].pt_ccol ;ax = remaining spaces + cmp result,len ;any room left? + mov result,0 ; + jge wrapend ; yes, return nowrap flag + inc result ; no, return wrap flag +wrapend: + pop di + pop es + endm + +| + +prn_proc proc near +;;;**************************************************************************** +;;; VM Opcode handler for "WRITE" +;;; +;;; Print an S-Expression with slashification +;;; +;;;**************************************************************************** + public spprin1 +spprin1: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 ; write indicator + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz sp1_010 + lea BX,sp1_er + jmp src_err ; link to error handler +sp1_010: + inc AX + mov display,AX + mov show,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; write + mov SP,BP +sp1_020: restore ; get the register pointer + mov [DI].C_page,NPR_PAGE*2 ; return as non-printable object + mov [DI].C_disp,NPR_DISP + mov display,0 ; default display = no + jmp next_SP ; return to interpreter +;;;**************************************************************************** +;;; VM Opcode handler for "DISPLAY" +;;; +;;; Print an S-Expression without slashification +;;; +;;;**************************************************************************** + public spprinc +spprinc: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz spc_010 + lea BX,spc_er + jmp src_err ; link to error handler +spc_010: mov display,AX + inc AX + mov show,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; display + mov SP,BP + jmp sp1_020 +;;;**************************************************************************** +;;; VM Opcode handler for "PRINT" +;;; +;;; Print an S-Expression with spacing control +;;; +;;;**************************************************************************** + public spprint +spprint: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz spt_010 + lea BX,spt_er + jmp src_err ; link to error handler +spt_010: mov display,AX + inc AX + mov show,AX + mov DX,SPECCHAR + mov BX,RETURN ; carriage return + pushm + call sprint ; print it + mov SP,BP + xor AX,AX + inc AX + mov show,AX + mov display,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; print the s-expression + mov SP,BP + mov BX,SPACE + mov DX,SPECCHAR ; space + xor AX,AX + mov display,AX + inc AX + mov show,AX + pushm + call sprint ; print it + mov SP,BP + jmp sp1_020 +;;;**************************************************************************** +;;; VM Opcode handler for "NEWLINE" +;;; +;;; Output a newline character +;;; +;;;**************************************************************************** + public spnewlin +spnewlin: lods byte ptr ES:[SI] ; load register operand + save + add AX,offset reg0 ; AX = port object + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz new_010 + lea BX,new_er + jmp src_err ; link to error handler +new_010: mov display,AX + inc AX + mov show,AX + mov BX,SPECCHAR + mov DX,RETURN ; carriage return + pushm + call sprint + mov SP,BP + mov display,0 ; default display = no + jmp next_SP ; return to interpreter +;;;**************************************************************************** +;;; VM Opcode handler for "LINE-LENGTH" +;;; +;;; Determine the print length of a scheme object +;;; +;;;**************************************************************************** + public prt_len +prt_len: lods byte ptr ES:[SI] ; load register operand + save + add AX,offset reg0 ; AX = port object + mov DI,AX + xor CX,CX + mov display,CX ; no display and show + mov show,CX + save + mov DX,OUT_PAGE*2 + mov CX,OUT_DISP + mov BX,[DI].C_page + shr BX,1 ; correct page number + pushm + call sprint + mov SP,BP ; AX = print length + restore + mov [DI].C_page,SPECFIX*2 + mov [DI].C_disp,AX ; get the print length + jmp next_SP ; return to interpreter +prn_proc endp + +;************************************************************************** +; SPRINT - Sexpression print routine +; +; Calling Sequence: sprint(pds,ppg,dis,pg) +; +; Where: ppg:pds = page:displacement of port to output to +; pg:dis = scheme object to output +; +; Upon Exit: AX = number of characters printed +; +;************************************************************************** + +spt_arg struc + dw ? ;caller's BP + dw ? ;caller's return address +pg dw ? ;page num of object to print +dis dw ? ;page disp of object to print +ppg dw ? ;page num of output port +pds dw ? ;page disp of output port +spt_arg ends + + public sprint +sprint proc near + push BP + mov BP,SP ;set up stack + call setabort ;set address when abort + pushm <[BP].pds, [BP].ppg> + call ssetadr ;set port address + mov SP,BP + +;fix for random i/o - note a write has taken place + mov AX,ES ;save extra segment + LoadPage ES,port_pg ;address port + mov SI,port_ds + or byte ptr ES:[SI].pt_pflgs,DIRTY ;note write has occurred + mov ES,AX ;restore extra segment + + mov ccount,0 ;clear character count + pushm <[BP].dis, [BP].pg> + call subsprin ;go print the object + mov SP,BP + mov AX,ccount ;return number of characters + pop BP + ret ;return to caller +sprint endp + +;************************************************************************** +; SUBSPRIN - Recursive print routine +; +; Calling Sequence: subsprin(dis,pg) +; +; Where: dis = displacement with pg of object to print +; pg = page of object to print +; +;************************************************************************** + public subsprin +subp_arg struc +tmp_reg1 dw ? +tmp_reg2 dw ? +tmp_reg3 dw ? +lst_pag dw ? +lst_dsp dw ? +subp_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +spg dw ? ; page number +sdis dw ? ; displacement +subp_arg ends + +subsprin proc near + push ES + push BP + sub SP,offset subp_BP ;allocate local storage + mov BP,SP + cmp s_break,0 ;check for SHIFT-BREAK + je subp_10 +kill_out: mov AX,RETURN ;carriage return + call printcha + mov AX,41 ;length of message + lea BX,ab_write + pushm + call printtxt ;display message + mov SP,BP + cmp show,0 + je kill_01 + xor AX,AX + jmp kill_02 +kill_01: mov AX,2 +kill_02: push AX ;instruction length + C_call restart ;link to scheme debugger + ;control does not return to here +subp_10: call stkspc ;check stack space + cmp AX,64 ;stack low? + jge subp_20 ;no, jump + mov AX,8 + lea BX,deep_str ;# + jmp subp_ret ;print message and return +; act on object type +subp_20: + shl [BP].spg,1 ;adjust page number + mov BX,[BP].spg + mov DI,ptype+[BX] ;get page type + jmp branchtab+[DI] ;envoke appropriate handler +; +; any problems with getmem should exit here +mem_err: + mov AX,HEAPERR ;memory not available + push AX + call abort + mov SP,BP +; +; return to caller +subp_ret: + add SP,offset subp_BP ;release local storage + pop BP + pop ES + ret + + + page 60,132 +;----------------------------------------------------------------------------- +; +; Following are the print handlers for each object type, they will be invoked +; via an indirect call through BRANCHTAB. +; +; Upon entry: BX = an adjusted page number +; DI = the page type +; +; Upon exit: Jump to SUBP_RET for cleanup +; +;----------------------------------------------------------------------------- + +;******************************************************************************* +; +; Print representation for code block object +; +;******************************************************************************* + public sp_code +sp_code: mov AX,7 + lea BX,code_str ; # + jmp subp_txt +;******************************************************************************* +; +; Print representation for continuation object +; +;******************************************************************************* + public sp_cont +sp_cont: mov AX,15 + lea BX,cont_str ; # + jmp subp_txt +;******************************************************************************* +; +; Print representation for environment object +; +;******************************************************************************* + public sp_env +sp_env: mov AX,14 + lea BX,env_str ; # + jmp subp_txt +;******************************************************************************* +; +; Print representation for free page +; +;******************************************************************************* + public sp_free +sp_free: mov AX,7 + lea BX,free_str ; # + jmp subp_txt +;******************************************************************************* +; +; Print representation for port object +; +;******************************************************************************* + public sp_port +sp_port: mov AX,7 + lea BX,port_str ; # +subp_txt: + pushm ;ax = length, bx = message address + call printtxt ;print the message + mov SP,BP ;clean up stack + jmp subp_ret ;and return to caller + +;******************************************************************************* +; +; Print floating point value +; +;******************************************************************************* + public sp_flo +sp_flo: mov SI,[BP].sdis ; displacement + shr BX,1 ; corrected page number + pushm + call get_flo ; get a floating point value + pushm ; in AX:BX:CX:DX + C_call printflo,,Load_ES + mov SP,BP + jmp subp_ret + +;******************************************************************************* +; +; Print list +; +;******************************************************************************* + public sp_list +sp_list: + test bx,bx ;null page? + jnz sp_l01 ; no, go chase list + mov ax,2 + lea bx,parens + pushm + call printtxt ;print "()" for null list + mov sp,bp + jmp subp_ret +sp_l01: + mov al,byte ptr parens + call printcha ;print open paren + mov bx,[bp].spg + LoadPage es,bx + mov si,[bp].sdis ;es:si => list cell +sp_l02: + mov [bp].lst_pag,bx + mov [bp].lst_dsp,si ;save list cell + xor dh,dh + mov dl,byte ptr es:[si] ;get car of list + shr dx,1 ; make number for subsprin + mov cx,word ptr es:[si+1] ;get car's displacement + pushm + call subsprin ;print car of list + mov sp,bp + mov bx,[bp].lst_pag ;restore list cell + LoadPage es,bx + mov si,[bp].lst_dsp + mov bl,byte ptr es:[si+3] ;get cdr of list + mov si,word ptr es:[si+4] + test bx,bx ;is it null? + jz sp_l04 ; yes, finished + pushm ;tempsave si,bx + mov al,' ' + call printcha ;print space as item seperator + popm ;restore stack + LoadPage es,bx ;reload page of cdr + cmp byte ptr ptype+[bx],LISTTYPE*2 ;is cdr a list cell? + je sp_l02 ; yes, chase the list +; cdr is not a list cell - improper list + mov dx," ." ;need " ." due to byte swapping + pushm ;tempsave si,bx - dx is text + mov si,sp + mov dx,2 + pushm ;push length, address of text + call printtxt ;print ". " + add sp,6 ;dump last 3 args + popm ;restore saved regs + + shr bx,1 ;make page a number for subsprin + pushm + call subsprin ;go chase last cdr + mov sp,bp ;dump args off stack +sp_l04: + mov al,byte ptr parens+1 + call printcha ;and print it + mov sp,bp + jmp subp_ret ;return to caller + +;******************************************************************************* +; +; Print array +; +;******************************************************************************* + public sp_ary +sp_ary: mov AX,2 + LoadPage ES,BX ; page segment + lea BX,ary_str ; print "#(" + pushm + call printtxt + mov SP,BP + + LoadPage ES,[BP].spg ; Get page address of array +;;; mov ES,word ptr pagetabl+[BX] + mov SI,[BP].sdis ; and segment + mov CX,word ptr ES:[SI+1] + sub CX,BLK_OVHD ; length of array + mov BX,BLK_OVHD + mov [BP].tmp_reg1,CX +sp_a01: + cmp BX,[BP].tmp_reg1 + jle sp_a04 + jmp sp_l04 +sp_a04: mov AL,byte ptr ES:[SI+BX] ; AX <= page of array element + mov DX,word ptr ES:[SI+BX+1] ; DX <= disp. of array element + xor AH,AH + shr AX,1 ; Page number for subsprin + mov [BP].tmp_reg2,BX ; Save registers + mov [BP].lst_dsp,SI + pushm + call subsprin ; print element + mov SP,BP + mov BX,[BP].tmp_reg2 ; restore BX + cmp BX,[BP].tmp_reg1 ; last element? + jge sp_a02 + mov ax,SPACE ; print ' ' + call printcha + mov BX,[BP].tmp_reg2 ; restore registers +sp_a02: mov SI,[BP].lst_dsp + add BX,PTRSIZE + LoadPage ES,[BP].spg ; Reload page address of array + jmp sp_a01 +;******************************************************************************* +; +; Print representation for closure object +; +;******************************************************************************* + public sp_clos +sp_clos: mov ax,11 + lea bx,clos_str + pushm + call printtxt ;print "# closure object + lea bx,[bp].tmp_reg1 + xor ah,ah + mov al,byte ptr es:[si+3] ;pag # of information op + mov [bx].C_page,ax ; save in tmp_reg1 + mov ax,word ptr es:[si+4] ;displ of information op + mov [bx].C_disp,ax ; save in tmp_reg1 +; follow info operand list +sp_c001: + mov di,[bx].C_page + cmp di,0 ;if reached end of list + je sp_c04 ; then exit loop + cmp byte ptr ptype+[di],LISTTYPE*2 ;if cdr not list cell + jne sp_c01 ; then exit loop + push bx + call take_cdr ;follow cdr of list + lea bx,[bp].tmp_reg1 + jmp sp_c001 +; If final operand is a symbol, print it +sp_c01: + cmp byte ptr ptype+[DI],SYMTYPE*2 ;do we have a symbol? + jne sp_c04 ; no, jump + + push bx ;tempsave reg around call + mov ax,SPACE + call printcha ;print ' ' + pop bx ;restore reg + + push display ;save around call + mov display,0 ;don't print escape chars + shr [bx].C_page,1 ;make page # for subsprin + pushm <[bx].C_disp,[bx].C_page> ;push page:disp of symbol + call subsprin ;go print the symbol + add sp,4 ;dump args off stack + pop display ;restore display indicator +sp_c04: + mov al,'>' + call printcha ;print '>' + mov SP,BP + jmp subp_ret + +;******************************************************************************* +; +; Print symbol to output port +; +;******************************************************************************* + public printatm +printatm label near +sp_sym: +; +; Warning: local data segment is not used in code below +; + loadpage ds,bx + mov si,[bp].sdis ;ds:si => object + mov cx,[si]+1 ;get object length + sub cx,SYM_OVHD ;cx = length of atom + add SS:ccount,cx ;update character count + cmp SS:show,0 ;do we want to print the object? + jne pra_010 ; yes, continue + mov dx,ss ; no, restore data segment + mov ds,dx + jmp pra_exit ; and return +pra_010: + ;cx = length of symbol + add si,SYM_OVHD ;ds:si => symbol name + GET_BUFFER ;es:di => real buffer + call atm2pbuf ;move printname to print buffer +; +; Warning: local data segment is not used in code above +; + mov dx,ss + mov ds,dx ;restore local data segment + cmp cx,0 ;if negative print length + jl pra_err ; then error, jump +;;; wrap cx,dx ;cx = length, dx = result + mov dx,1 ;check wrap flag +;cx = length, dx = check wrap flag, es:di => print buffer + call gvchars ;go print the buffer +pra_exit: + RLS_BUFFER + jmp subp_ret +pra_err: + jmp mem_err + +;******************************************************************************* +; +; Print string to output port +; +;******************************************************************************* + public printstr +printstr label near +sp_str: +; +; Warning: local data segment is not used in code below +; + loadpage ds,bx + mov si,[bp].sdis ;ds:si => object + mov cx,[si]+1 ;cx = length indicator + add si,BLK_OVHD ;ds:si => actual string + or cx,cx ;small string? + jge prs_005 ; no, jump + add cx,BLK_OVHD+PTRSIZE +prs_005: + sub cx,BLK_OVHD ;cx = length of string + add SS:ccount,cx ;update character count + cmp SS:show,0 ;actually printing? + jne prs_010 ; yes, continue + mov dx,ss ; no, restore data segment + mov ds,dx + jmp pra_exit ; and return +prs_010: + + ;cx = string length + GET_BUFFER ;es:di => buffer for print string + call str2pbuf ;move string to print buffer +; +; Warning: local data segment is not used in code above +; + mov bx,ss ;restore local data segment + mov ds,bx + cmp cx,0 ;if negative print length + jl prs_err ; then error, jump +;;; wrap cx,dx ;cx=length, dx=result + mov dx,1 ;check wrap flag +;cx = length, dx = check wrap flag, es:di => print buffer + call gvchars ;go print the buffer +prs_exit: + RLS_BUFFER ;release the print buffer + jmp subp_ret + +prs_err: jmp mem_err ;must be a long jump + + +;******************************************************************************* +; +; Print character to output port +; +;******************************************************************************* + public sp_char +sp_char: + cmp display,0 ;display escape chars? + jne sp_ch10 ; yes, jump +;print character without escapes + mov ax,[BP].sdis ;get character + xor ah,ah + call printcha ;call print routine + jmp subp_ret ;get outa here +;print character with escapes +sp_ch10: + mov bx,14 ;max size of character buffer + push bx + C_call getmem ;allocate space + mov sp,bp ;dump arg off stack + cmp ax,0 + jne sp_ch00 + jmp mem_err ;error allocating heap - jump +sp_ch00: + mov si,ax ;si => buffer + mov dx,ax ;dx => buffer + mov ax,[BP].sdis ;get character + mov byte ptr [si],23h ; # + mov byte ptr [si+1],5Ch ; \ + mov byte ptr [si+2],AL ;character + mov byte ptr [si+3],0 ;end of string + mov bx,3 ;length +; +; see if character one of the multi-character constants in cread.asm +; + mov cx,ds + mov es,cx ;ensure ds=es + + mov cx,NUMBER_SPECIAL_CHARS ;cx = counter + lea di,test_ch + add di,NUMBER_SPECIAL_CHARS-1 ;di => last special char + std + repne scasb ;search for special char + cld + jnz sp_ch20 ;if none found, jump + shl cx,1 ;make index into t_array + + lea di,t_array + add di,cx + mov di,[di] + xchg si,di ;ds:si => character string + add di,2 ;es:di => character buffer + cld + xor al,al ;al = null terminator +sp_chlp: + movsb ;move byte into character buffer + cmp al,[si] ;reached terminator? + jne sp_chlp + sub di,dx ;calc length + mov bx,di +sp_ch20: + pushm ;bx=buffer length, dx=buffer address + call printtxt ;print the character constant + mov SP,BP + + mov bx,14 ;length of character buffer + pushm + C_call rlsmem ;release character buffer + mov sp,bp ;dump args off stack + jmp subp_ret + +;******************************************************************************* +; +; Print integer value +; +;******************************************************************************* + public sp_fix +sp_fix: mov AX,5 + mov [BP].tmp_reg2,AX + push AX + C_call getmem + mov SP,BP + or ax,ax + jnz sp_f10 + jmp mem_err +sp_f10: + mov [BP].tmp_reg1,AX ; address of divider + mov SI,[BP].sdis ; get the value + shl SI,1 + sar SI,1 + pushm + mov AX,DS + mov ES,AX ; get the right ES segment + call fix2big ; change to bignum + mov SP,BP + jmp printint +;******************************************************************************* +; +; Print bignum +; +;******************************************************************************* + public sp_big +sp_big: LoadPage ES,BX + mov SI,[BP].sdis + mov AX,word ptr ES:[SI+1] ; get object size + dec AX + mov [BP].tmp_reg2,AX + push AX + C_call getmem ; allocate memory for divider + mov SP,BP + cmp AX,0 ; memory available? + jne sp_big1 + jmp mem_err ; no, error +sp_big1: mov [BP].tmp_reg1,AX ; address of divider + mov BX,[BP].spg + shr BX,1 + pushm + mov AX,DS + mov ES,AX ; get the right ES segment + call copybig ; copy bignum to buffer +printint: + mov AX,[BP].tmp_reg2 + mov BX,3 + mul BX + sub AX,5 + mov [BP].lst_dsp,AX + push AX + C_call getmem ; allocate memory for char buffer + mov SP,BP + cmp AX,0 ; memory available? + jne sp_big2 + jmp mem_err ; no, error +sp_big2: mov [BP].tmp_reg3,AX ; address of bigchars + pushm + call big2asc ; convert bignum to char string + mov SP,BP ; AX = characters count + pushm + call printtxt ; print the bignum + mov SP,BP + pushm <[BP].tmp_reg2, [BP].tmp_reg1> + C_call rlsmem + pushm <[BP].lst_dsp, [BP].tmp_reg3> + C_call rlsmem + mov SP,BP + jmp subp_ret + +subsprin endp + + +; page 60,132 +; title Print Handler Support Routines +; +;****************************************************************************** +;PRINTTXT - C callable routine to print a string, first sending a newline +; character if necessary. The string is assumed to be in the +; local data segment. +; +; Calling Sequence: printtxt(string,len) +; +;****************************************************************************** +str_arg struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +str dw ? ; string pointer +len dw ? ; string length +str_arg ends + public printtxt +printtxt proc near + push es + push bp + mov bp,sp ;set up stack + + mov cx,[bp].len ;cx = length of string + add ccount,cx ;keep track of character count + cmp show,0 ;show? + je pstr_ret ; no, return + + push display + mov display,0 + mov si,[bp].str ;ds:si => string to write + GET_BUFFER ;es:di => buffer for print string + call str2pbuf ;move string to print buffer + pop display + +;;; wrap cx,dx ;cx=length, dx=result + mov dx,1 ;check wrap flag +;cx = length, dx = check wrap flag, es:di => print buffer + call gvchars ;go print the buffer + RLS_BUFFER ;release the print buffer +pstr_ret: + pop bp + pop es + ret +printtxt endp + + +;****************************************************************************** +;PRINTCHA - C callable routine to print a character, first sending a newline +; character if necessary. At least for now, this is performed by +; calling gvchars - in the future we may want output routines for +; outputting individual characters. +; +; Upon Entry: al contains character to print +; +;****************************************************************************** +pcha_arg struc + dw ? ;caller's BP + dw ? ;caller's ES + dw ? ;caller's return address +pcha_arg ends + + public printcha +printcha proc near + push es + push bp + mov bp,sp ;set up stack + + inc ccount ;bump character count + cmp show,0 ;if not actually printing + jz pcha_ret ; then return + +comment | +;see if enough space left on current output line + LoadPage es,port_pg + mov di,port_ds ;es:di => port object + xor dx,dx ;dx = wrap flag (0 = nowrap) + mov cx,es:[di].pt_ncols ;maintaining line length? + jcxz pcha_010 + sub cx,es:[di].pt_ccol ;cx = space remaining + cmp cx,1 ;any space left? + jge pcha_010 + mov dx,1 + | + mov dx,1 ;check wrap flag +pcha_010: + RESET_REAL_BUFFER_OFFSET + MOVE_BYTE_TO_BUF al,REAL_MODE_BUFFER + mov cx,1 ;cx = length + call gvchars +pcha_ret: + xor ax,ax + pop bp + pop es + ret +printcha endp + +COMMENT % + The two routines below are written such that they may run either on the + hummingboard or out of 286/386 pritected memory. The hummingboard cannot + directly address the host's physical memory, so when displaying escape + chars within a string, it is first buffered into space allocated in the + heap, then written via a block move to the print buffer. Although this is + somewhat clumsy, it significantly improves performance over writing + individual bytes to the print buffer with the BLOCK-MOVE dos function + provided by OSx86. + If in the future the hummingboard os traps instructions which are writing + to real memory, then the buffering may be discarded and simple memory + moves may be performed. +% + +;****************************************************************************** +;ATM2PBUF - Move symbol printname to printbuffer +; +; Description: +; The symbol name pointed to by ds:si is moved into a print buffer for output. +; +; If the display flag is set, the symbol is being output by the "write" lisp +; function and all backslashes and vertical bars (\,|) are written to the +; buffer preceeded by a backslash. In addition, the symbol must also be +; surrounded by vertical bars (|) if lowercase letters, commas, semi-colons, +; and other strange characters are encountered; or if the printname is a +; ".", a name starting with a # (other than special symbols), or is numeric. +; +; If the display flag is not set, then the printname is moved to the buffer +; without performing any translation. +; +; Upon Entry: +; cx = length of printname +; ds:si => printname +; es:di => print buffer +; +; Upon Exit: +; cx = # characters placed in print buffer +; es:di => print buffer +; +;****************************************************************************** +p_struc struc +dest_top dw ? +dest_start dw ? +heap_top dw ? +heap_str dd ? +src_start dw ? +src_str dd ? +dest_str dd ? +stlen dw ? +call_bp dw ? +p_struc ends + + public atm2pbuf +atm2pbuf proc near + BUFFER_IS_BUFFER ;real mode buffer treated as such + + cmp ss:display,0 ;displaying escape chars? + jnz a2p_xlat ; yes, jump +;move printname to print buffer + MOVE_TO_REAL_BUF ;move entire string over + ret ;return to caller +a2p_err: + mov [bp].stlen,-1 + jmp a2p_fin + +;move printname to print buffer, checking for backslashes and delimiters '|' +a2p_xlat: + push bp ;save callers bp + push cx ;save length + push es + push di ;save real buffer address + push ds + push si ;save string address + sub sp,src_str ;allocate local storage + mov bp,sp + + mov [bp].src_start,si ;save start location of source string + mov [bp].dest_start,di ;save print buffer start + GET_REAL_BUFFER_TOP dx + sub dx,pt_bfend+20 + mov [bp].dest_top,dx ;save print buffer end + + mov ax,ss + mov ds,ax + mov es,ax ;setup for c call + mov ax,512 + push ax + c_call getmem ;allocate 512 bytes of storage + add sp,2 ;dump arg from stack + cmp ax,0 ;allocation successful? + jne a2p_write ; no, go write the buffer + mov [bp].stlen,-1 ;indicate error + jmp a2p_fin2 ; and exit +a2p_write: + mov [bp].heap_top,510 ;note top of heap buffer + mov word ptr [bp].heap_str,ax ;save heap buffer address + mov word ptr [bp].heap_str+2,es + mov di,ax ;es:di = buffer + mov byte ptr es:[di],'|' ;start buffer with escape char + inc di ;di = address within buffer + mov dx,1 ;dx = # chars written + lds si,[bp].src_str ;ds:si addresses the string + mov cx,[bp].stlen ;cx = char count + xor bx,bx ;bh = strangeness + cmp cx,0 ;char count zero? + jne b2p_init ; no, jump + or bh,080h ; yes, mark as strange + jmp b2p_post ; and skip loop +b2p_init: +;dx = #chars written, di=heap buffer offset, si=string offset, cx=char count +b2plp: + cmp dx,[bp].dest_top ;room left in buffer? + jg a2p_err ; no, return error status + + lodsb ;fetch char from printname + cmp al,'\' ;is char escape char? + je escit ; yes, jump + cmp al,'|' ;is char delimiter? + jne storit ; no, just go store it +escit: + mov byte ptr es:[di],'\' ;write escape char to buffer + inc di ;bump print buffer ptr + inc dx ;bump # chars written +storit: + stosb ;write char to buffer + inc dx ;bump # chars written + + test bh,80h ;do we already know that atom's strange? + jnz skptest ; yes, skip following tests +;if lowercase letters or comma, semi-colon, etc. encountered, then it contains +;"strange" characters and must be delimited by '|' + push si ;tempsave pname offset + mov bl,al ;save copy of char in bl + lea si,hicases ;si => table of upper cases + xchg bx,si + mov ah,al ;save char + xlat ss:hicases ;fetch upper-case equivalent + xchg bx,si + cmp ah,al ;are chars different? + jne mrkstrng ; yes, indicate strangeness + mov si,offset stranges ;si => strange-character string +strnglp: lods byte ptr ss:[si] ;fetch strange char + or al,al ;finished searching for strange chars? + jz notstrng ; yes, exit loop + cmp ah,al ;Do we have a strange char? + jne strnglp ; no, try next +mrkstrng: or bh,80h ; yes, mark strange bit +notstrng: + pop si ;restore pname offset +skptest: + cmp di,[bp].heap_top ;heap buffer full? + jl a2p_cont ; no, continue + push cx ;save loop count + mov word ptr [bp].src_str,si ;update string pointer + sub di,word ptr [bp].heap_str ;calc number chars written + mov cx,di ; and save in cx + lds si,[bp].heap_str ;ds:si = heap buffer + les di,[bp].dest_str ;es:di = real mode buffer + MOVE_TO_REAL_BUF autoinc ;move string to print buffer + add word ptr [bp].dest_str,di ;update next location in real buffer + pop cx ;restore count + lds si,[bp].src_str ;ds:si = pointer into string + les di,[bp].heap_str ;es:di = heap allocated string ptr +a2p_cont: + loop b2plp ;look at next char in printname + +; bh= strangeness, dx= #chars printed, di= end of printname +; write delimeter to heap allocated string, then copy to print buffer +b2p_post: + mov al,'|' ;follow with escape char + stosb ;write to heap buffer + inc dx ;bump character count + + sub di,word ptr [bp].heap_str ;calc number chars written + mov cx,di ; and save in cx + lds si,[bp].heap_str ;ds:si = heap buffer + les di,[bp].dest_str ;es:di = real mode buffer + MOVE_TO_REAL_BUF autoinc ;move string to print buffer + mov [bp].stlen,dx ;save actual # chars written + mov ds,word ptr [bp].src_str+2 + mov si,[bp].src_start ;ds:si => start of source string + + test bh,80h ;do we already know atom's strange? + jnz a2p_fin ; yes, jump +; Check for ., #macro, or numeric confusion + cmp dx,3 ;a single char? (remember delimiters) + jne a2p_sharp ; no, jump + mov al,byte ptr ds:[si] ;get first byte of symbol + cmp al,'.' ;do we have a period - "." ? + je a2p_fin ; yes, delimits necessary +a2p_sharp: + cmp al,'#' ;macro designator? + jne a2p_num ; no, jump + cmp dx,3 ;a single sharp? (remember delimiters) + je a2p_fin ; yes, delimits necessary + cmp [bp].spg,SPECSYM*2 ;special symbol + je a2p_nodelim ; yes, no delimeters required + jne a2p_fin ; no, delimits necessary +a2p_num: + mov ax,10 ;check for number + push ax ;base 10 + push si ;ds:si => printname + call scannum ;check for number + add sp,4 ;dump args from stack + test ax,ax ;is it a number? + jnz a2p_fin ; yes, jump +a2p_nodelim: +;although symbol being witten via "write", there are no stranges chars, +;or anything, so it can be written without delimiters. + inc [bp].dest_start ;position past initial delimiter + sub [bp].stlen,2 ;exclude delimeters from length +a2p_fin: + mov ax,ss + mov ds,ax ;set up data segment + mov es,ax ; and extra segment + mov bx,512 ;length of heap buffer + pushm + C_call rlsmem, ;release character buffer + add sp,4 ;dump args off stack +a2p_fin2: + mov es,word ptr [bp].dest_str+2 + mov di,[bp].dest_start ;es:di => real buffer start + mov cx,[bp].stlen ;cx = number characters written + + lds si,[bp].src_str ;restore ds:si + add sp,call_bp ;dump args off stack + pop bp ;restore base pointer + ret + +atm2pbuf endp + +;****************************************************************************** +;STR2PBUF - Move string to printbuffer +; +; Description: +; The print buffer is in real mode, the string is moved into the print +; buffer (possibly surrounded by quotes '"' and containing escape +; characters. +; +; Upon Entry: +; cx = length of string +; ds:si => string +; es:di => print buffer +; +; Upon Exit: +; cx = number of bytes written to print buffer +; es:di => print buffer +; +;****************************************************************************** + + public str2pbuf +str2pbuf proc near + BUFFER_IS_BUFFER ;real mode buffer treated as such + + cmp ss:display,0 ;display escape chars? + jne s2p_xlat ; yes, jump +;move string to print buffer + MOVE_TO_REAL_BUF ;move string to print buffer + ret ;and return to caller + +;move string to print buffer, inserting double quotes and escape chars +s2p_xlat: + push bp ;save callers bp + push cx ;save length + push es + push di ;save real buffer address + push ds + push si ;save string address + sub sp,src_str ;allocate local storage + mov bp,sp + + mov [bp].dest_start,di ;save buffer start + GET_REAL_BUFFER_TOP dx + sub dx,pt_bfend+20 + mov [bp].dest_top,dx ;save buffer end + + mov ax,ss + mov ds,ax + mov es,ax ;setup for c call + mov ax,512 + push ax + c_call getmem ;allocate 512 bytes of storage + add sp,2 ;dump arg from stack + cmp ax,0 ;allocation successful? + jne s2p_write ; no, go write the buffer + mov cx,-1 ;indicate error + jmp s2p_fin2 ; and exit +s2p_write: + mov [bp].heap_top,510 ;note top of heap buffer + mov word ptr [bp].heap_str,ax ;save heap buffer address + mov word ptr [bp].heap_str+2,es + mov di,ax ;es:di = buffer + mov byte ptr es:[di],'"' ;start buffer with escape char + inc di ;di = address within buffer + mov dx,1 ;dx = number chars written + + mov cx,[bp].stlen + jcxz s2p_done ;jump if null string + + lds si,[bp].src_str ;ds:si addresses the string +;dx = #chars written, es:di=heap buffer offset, ds:si=string offset +s2p_loop: + cmp dx,[bp].dest_top ;room left in buffer? + jg s2p_err ; no, return error status + + lodsb ;fetch char from string + cmp al,'\' ;Is char escape char? + je s2p_esc ; yes, jump + cmp al,'"' ;Is char double quote? + jne s2p_stor ; no, just go store it +s2p_esc: + mov ah,al + mov al,'\' + stosb ;store escape character + inc dx ;bump # chars written + xchg al,ah +s2p_stor: + stosb ;store escape character + inc dx ;bump # chars written + cmp di,[bp].heap_top ;heap buffer full? + jl s2p_cont ; no, continue + push cx ;save loop count + mov word ptr [bp].src_str,si ;update string pointer + sub di,word ptr [bp].heap_str ;calc number chars written + mov cx,di ; and save in cx + lds si,[bp].heap_str ;ds:si = heap buffer + les di,[bp].dest_str ;es:di = real mode buffer + MOVE_TO_REAL_BUF autoinc ;move string to print buffer + add word ptr [bp].dest_str,di ;update next location in real buffer + pop cx ;restore count + lds si,[bp].src_str ;ds:si = pointer into string + les di,[bp].heap_str ;es:di = heap allocated string ptr +s2p_cont: + loop s2p_loop ;look at next char in printname +s2p_done: + mov al,'"' ;follow with escape char + stosb + inc dx + + sub di,word ptr [bp].heap_str ;calc number chars written + mov cx,di ; and save in cx + lds si,[bp].heap_str ;ds:si = heap buffer + les di,[bp].dest_str ;es:di = real mode buffer + MOVE_TO_REAL_BUF autoinc ;move string to print buffer + mov cx,dx ;cx = actual # chars written + jmp s2p_fin ;finished +s2p_err: + mov cx,-1 ;indicate error +s2p_fin: + push cx ;save length around call + mov bx,512 ;length of heap buffer + pushm + C_call rlsmem,,restore_es ;release character buffer + add sp,4 ;dump args off stack + pop cx +s2p_fin2: + lds si,[bp].src_str ;restore ds:si + mov es,word ptr [bp].dest_str+2 + mov di,[bp].dest_start ;es:di => real buffer start + add sp,call_bp ;dump args off stack + pop bp ;restore base pointer + ret ;return +str2pbuf endp + +prog ends + end + + \ No newline at end of file diff --git a/prosread.asm b/prosread.asm new file mode 100644 index 0000000..9954d4a --- /dev/null +++ b/prosread.asm @@ -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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 ; + 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 + 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 + 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 + C_call intern,,Load_ES ; intern the symbol + mov SP,BP + lea BX,nil_reg + mov DI,main_reg + pushm + call cons ; encase in a list + mov SP,BP + jmp read_bye +; +read_nor: pushm + C_call intern,,Load_ES ; intern the symbol + mov SP,BP + lea BX,nil_reg + mov DI,main_reg + pushm + 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 + 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 + 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 + 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 + + \ No newline at end of file diff --git a/prowin.asm b/prowin.asm new file mode 100644 index 0000000..f7a26bb --- /dev/null +++ b/prowin.asm @@ -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 + 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 + C_call alloc_bl,,Load_ES ; allocate block for window object + pop BX + mov DI,[BX].C_disp ; get displacement + save + mov BX,[BX].C_page ; get page numbe of window object + LoadPage ES,BX ; get page address + shr BX,1 + pushm + call zero_blk ; zero window object + restore + 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 ; 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 ; save registers + save + mov CX,1 + pushm + 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 + 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 + 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 + 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 + add AX,offset reg0 ; compute address of register + xor BX,BX + pushm + save + 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 + 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 + mov CX,STRTYPE ; string type + pushm + C_call alloc_bl,,Load_ES ; alloc_block + mov SP,BP + pushm + restore + 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 ; 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 + xor CX,CX + pushm + C_call get_port,,Load_ES ; get the port object + mov SP,BP + restore ; 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 + call adj4bord ; adjust window region +rest_10: pushm + restore + 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 + 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 + 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 + 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 + 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 + + \ No newline at end of file diff --git a/realio.asm b/realio.asm new file mode 100644 index 0000000..21add80 --- /dev/null +++ b/realio.asm @@ -0,0 +1,1903 @@ +; =====> REALIO.ASM +;***************************************************** +;* TIPC Scheme Runtime Support * +;* Real Mode I/O Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: November 1987 (tc) * +;* Last Modification: * +;***************************************************** + include schemed.equ ;for port defs + include screen.equ + .286c +; +; Local equates +; + +RETURN equ 0Dh ; Carriage Return Character +LINEFEED equ 0Ah ; Line Feed Character +DOS equ 021h ; Dos function request +WRITEFILE equ 040h ; Write Fiel function request +DISK_FULL equ -1 ; Disk full error designator + +TIPC equ 1 ; Designates machine type as TIPC + +TI_CRT equ 049h +IBM_CRT equ 010h + +; +; Segment Definitions +; + +PGROUP group PROG +DGROUP group DATA + +; This stack is used for the standard XLI interface. However, a different +; stack (i.e. PCS's) is used during calls to a graphics driver. +STACK segment word stack 'STACK' +stackstart = $ + dw 16 dup (?) +stacksize = $ - stackstart +STACK ends + +; +; Data definitions +; +DATA segment byte public 'DATA' + assume DS:DGROUP +datastart = $ + +callers_ds dw ? +callers_es dw ? + +;----------------------------------------------------------------------------- +; Type/Monitor info +;----------------------------------------------------------------------------- +PC_MAKE dw 0 +VID_MODE dw 3 +MAX_ROWS db DEFAULT_NUM_ROWS +MAX_COLS db DEFAULT_NUM_COLS +CHAR_HGT dw 8 + +;----------------------------------------------------------------------------- +; Jump table for handler based on op_code +;----------------------------------------------------------------------------- +OP_CODE dw BELL ; 0 - Sound Bell + dw CLEAR ; 1 - Clear Screen + dw BORDER ; 2 - Draw Border + dw SAVE_SCR ; 3 - Save Screen + dw REST_SCR ; 4 - Restore Screen + dw ? ; 5 - was turn cursor on + dw ? ; 6 - was turn cursor off + dw ? ; 7 - was position cursor + dw PUTCHAR ; 8 - Put Character on screen + dw SCROLLUP ; 9 - Scroll Screen Up 1 Line + dw SCROLLDN ; 10 - Scroll Screen Dn 1 Line + dw ? ; 11 - was ega cursor emulation + dw CHGMODE ; 12 - Note Change to Video Mode + dw WSTRING ; 13 - Write string to output port + dw WBLOCK ; 14 - Write string to display +table_len equ $ - OP_CODE + +;----------------------------------------------------------------------------- +; XLI Setup +;----------------------------------------------------------------------------- +;;; ----- Equates ----- +; offsets into the PSP +term_addr equ 0Ah +fb_addr equ 5Ch +;;; ----- Data structures ----- +; file block +file_block label word + dw 4252h + dw 10011b ;flags = sysint,0,0,16-bit,near + dw offset lookup_table, seg lookup_table + dw offset parm_block, seg parm_block +; reserved area of file block + dw 100h ;sysint# (256=%graphics) + dw offset handler, seg handler ;ISR entry point + dw 0,0,0,0,0 +; parameter block +parm_block label word ;not used + dw 0 +; lookup table +lookup_table label word + db '//' ;not used +; other needed values +psp dw ? ;PSP segment address +psize dw ? ;size of program in paragraphs +xwait dw 2 dup (?) ;XLI wait address +xbye dw 2 dup (?) ;XLI bye address + +; ___ __ __ +; + -| |- _|_ | -- | __| |__ | | (extra) +map_tab db 0c5h,0b4h,0c3h,0c1h,0c2h,0c4h,0b3h,0d9h,0c0h,0bfh,0dah,0dah +map_tabx equ $ + +trns_tab db 0dah,0c2h,0c3h,0c5h,0c3h,0c2h,0c2h,0c5h,0c3h,0c5h,0c5h + db 0c2h,0bfh,0c5h,0b4h,0b4h,0c2h,0c2h,0c5h,0c5h,0b4h,0c5h + db 0c3h,0c5h,0c0h,0c1h,0c3h,0c1h,0c5h,0c1h,0c3h,0c5h,0c5h + db 0c5h,0b4h,0c1h,0d9h,0b4h,0c1h,0c5h,0c1h,0c5h,0b4h,0c5h + db 0c3h,0b4h,0c3h,0b4h,0b3h,0c5h,0c5h,0c5h,0c3h,0b4h,0c5h + db 0c2h,0c2h,0c1h,0c1h,0c5h,0c4h,0c2h,0c1h,0c5h,0c5h,0c5h + +m14_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 1,0,2,2,1,4,2,0,0,3,3,7,3,5,6,2,6,6,5,3,5,2,1,2,2,1,7,3 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 2,6,1,2,2,0,3,0,0,0,3,1,0,4,0,0,1,1,3,0,3,0,2,0,1,3,1,1 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 0,1,0,0,0,3,7,1,5,0,3,4,3,3,3,0,6,6,0,0,2,2,3,2,3,2,3,2 + +;117-126 u v w x y z { | } ~ + db 2,3,3,2,2,2,3,1,0,1 + +;127-191 + db 64 dup (0) + +;192-197 + db 5,2,0,0,0,4 + +;198-218 + db 20 dup (0) +;219-220 + db 2,5 + +m16_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 3,1,4,4,4,7,4,2,2,6,6,11,6,9,9,4,10,10,9,6,9,4,2,4,4,3,10,6 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 5,10,3,4,5,2,5,2,2,2,5,2,2,8,2,2,2,2,5,2,5,2,4,2,2,5,2,2 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 2,2,2,2,2,3,12,2,9,2,6,7,6,6,6,2,10,11,2,2,5,5,6,5,6,5,6,4 + +;117-126 u v w x y z { | } ~ + db 5,5,5,5,5,5,6,2,2,3 + db 64 dup (0) + db 7,2,0,0,0,7 + db 20 dup (0) + db 2,7 + + public m18_attr +m18_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 2,1,4,4,8,8,4,2,2,6,6,10,9,10,05,4,10,10,10,6,10,4,2,4,4,10,10,6 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 9,06,2,4,4,2,6,2,2,2,6,2,2,8,2,2,2,2,6,2,6,2,4,2,2,6,2,2 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 2,2,2,3,2,3,13,2,10,2,6,8,6,6,6,2,10,12,2,2,5,5,6,5,6,5,6,4 + +;117-126 u v w x y z { | } ~ + db 5,6,6,5,5,5,6,2,2,2 + db 64 dup (0) + db 10,4,0,0,0,8 + db 20 dup (0) + db 8,8 + +; +; The following jump table is used wstring to handle control characters +; written to the screen. +; +wn_handle dw wwin_default ;00 - Null character + dw wwin_default ;01 - + dw wwin_default ;02 - + dw wwin_default ;03 - + dw wwin_default ;04 - + dw wwin_default ;05 - + dw wwin_default ;06 - + dw wwin_bell ;07 - Bell + dw wwin_backspace ;08 - Backspace + dw wwin_tab ;09 - Tab + dw wwin_linefeed ;0A - Linefeed + dw wwin_default ;0B - + dw wwin_default ;0C - + dw wwin_creturn ;0C - Carriage Return + +; +; The following jump table is used by wstring to handle control characters +; written to disk. +; +ds_handle dw wfil_default ;00 - Null character + dw wfil_default ;01 - + dw wfil_default ;02 - + dw wfil_default ;03 - + dw wfil_default ;04 - + dw wfil_default ;05 - + dw wfil_default ;06 - + dw wfil_default ;07 - + dw wfil_backspace ;08 - Backspace + dw wfil_tab ;09 - Tab + dw wfil_newline ;0A - Linefeed + dw wfil_default ;0B - + dw wfil_default ;0C - + dw wfil_newline ;0D - Carriage Return + + +last_char db 0dbh + +c_col dw 0 +c_row dw 0 +c_len dw 0 +c_nrows dw 0 + +sav_di dw 0 + +datasize = $-datastart +DATA ends + + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +PROG segment byte public 'PROG' + assume CS:PGROUP,DS:DGROUP +progstart = $ + +;----------------------------------------------------------------------------- +; name HANDLER -- Interface Handler to IO routines +; +; AX will contain error indicator (-1) if error encountered +; +hand_args struc + dw ? ; callers bp + dd ? ; return address (far) +opcode dw ? ; IO operation to perform +hand_args ends + + public handler +handler proc far + mov BX,DS ; temp save caller's DS + mov AX,data + mov DS,AX ; establish local data segment + mov callers_ds,bx ; save callers data seg + mov callers_es,es ; and extra seg + mov ES,AX +; Load sub opcode + push bp + mov bp,sp + mov BX,[BP].opcode ; load operation code + pop bp + add BX,BX ; adjust for index into jump table + cmp BX,table_len ; bad op_code? + jae bad_op + +; Jump desired IO handler + call OP_CODE[BX] + jmp short hand_ret + +bad_op: mov AX,-1 + +; Return to caller +hand_ret: + push callers_ds + pop ds ; restore caller's data seg + push callers_es + pop es ; restore caller's data seg + ret ; return to caller +handler endp + + +;************************************************************************ +;* 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 bell +bell proc near + cmp PC_MAKE,TIPC ; If not tipc + jne zbmbell ; then jump +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 + xor ax,ax + 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 + xor ax,ax + ret +bell endp + +;************************************************************************ +;* Clear a Window * +;************************************************************************ +cl_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +cl_op dw ? ; clear window op code +cl_row dw ? ; upper left hand corner row number +cl_col dw ? ; upper left hand corner column number +cl_nrows dw ? ; number of rows +cl_len dw ? ; line length (number of characters) +cl_attrib dw ? ; character attributes +cl_args ends + + public clear +clear proc near + push BP ; save caller's BP + mov BP,SP +; Put cursor at beginning of next row +c_loop: mov DL,byte ptr [BP].cl_row ; load current row number + mov DH,byte ptr [BP].cl_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].cl_attrib ; load attribute flag + + cmp vid_mode,14 ; IBM EGA modes? + jl c_01 + cmp BL,87h ; attribute is rv white? + jne c_22 + mov AX,09dbh ; use the block character not the blank + and BL,7fh ; strip off the xor bit + +c_01: mov CX,[BP].cl_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].cl_row ; increment row number + dec [BP].cl_nrows ; decrement row count + jg c_loop ; if more rows, loop (jump) +; Return to caller +c_end: pop BP ; restore caller's BP + xor ax,ax ; return status + ret ; return + + ; clear out the line by writing directly to the graphics planes +c_22: + mov AX,[BP].cl_nrows + mov c_nrows,ax + mov AX,[BP].cl_row ; set AX to the row + mov c_row,AX + mov AX,[BP].cl_col ; add in the starting column + mov c_col,AX + mov AX,[BP].cl_len ; number of columns to blank + mov c_len,AX + call z_ega ; restore counter + + jmp c_end ; return + +clear endp + +;************************************************************************ +;* Draw Border * +;************************************************************************ +b_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +b_opcode dw ? ; border opcode +b_line dw ? ; upper left corner line number +b_col dw ? ; upper left corner column number +b_nlines dw ? ; number of lines +b_ncols dw ? ; number of columns +b_battr dw ? ; border attributes +b_label dw ? ; pointer to label text +b_args ends + + public border +border proc near +;;; int 3 + push BP ; save caller's BP + mov BP,SP + +; output corners + mov BL,byte ptr [BP].b_battr ; load attribute bits + mov DH,byte ptr [BP].b_col ; load left column number + mov DL,byte ptr [BP].b_line ; load left line number + dec DL + dec DH + mov AL,0DAh ; load upper left corner character + call zcorner + inc DH + add DH,byte ptr [BP].b_ncols + mov AL,0BFh ; load upper right corner character + call zcorner + inc DL + add DL,byte ptr [BP].b_nlines + mov AL,0D9h ; load lower right corner character + call zcorner + dec DH + sub DH,byte ptr [BP].b_ncols + mov AL,0C0h ; load lower left corner character + call zcorner + +; output sides + mov DH,byte ptr [BP].b_col ; reload upper left column number + mov DL,byte ptr [BP].b_line ; and line number + dec DH ; decrement column number + mov CX,[BP].b_nlines + call zside ; draw the left hand border + mov DH,byte ptr [BP].b_col ; reload upper left column number + mov DL,byte ptr [BP].b_line ; and line number + add DH,byte ptr [BP].b_ncols ; add in line length + mov CX,[BP].b_nlines + call zside ; draw the right hand border + +; Output the top of the border + mov DL,byte ptr [BP].b_line ; load upper left row number + dec DL + jl z_no_top ; if row negative, skip write + mov DH,byte ptr [BP].b_col ; load upper left column number + mov CX,[BP].b_ncols + call ztop +; Put the label in the top left corner of the border, if it'll fit + mov BX,[BP].b_label ; get segment of label + cmp BX,0 + je z_no_top ; jump, if NULL pointer + mov ES,BX + mov BX,0 ; ES:BX => label + mov DX,[BP].b_ncols ; load window width + xor CX,CX ; zero the character counter +b_loop: cmp byte ptr ES:[BX],0 ; end of string? + je b_eos ; if end of string, jump + inc CX ; increment the character count + inc BX ; increment the character string pointer + cmp CX,DX ; compare to window width + jl b_loop ; if label still shorter than window, loop +b_eos: jcxz z_no_top ; if no label, jump + push CX ; save label length +; Write the label + mov DL,byte ptr [BP].b_line ; load upper left row number + mov DH,byte ptr [BP].b_col ; load upper left column number + dec DL ; decrement row number + xor BH,BH ; IBMism (page 0 for text-mode) + mov AH,02h ; load "put cursor" code + call CRT_DSR ; put cursor in upper left corner of border + pop CX ; restore label's character count + cmp PC_MAKE,TIPC + jne ibm_cblk + mov AH,011h ; load "write block of characters" code + mov DX,ES ; load segment address + mov BX,0 ; load label offset + int TI_CRT ; write the label + jmp short z_no_top +; +ibm_cblk: mov AL,byte ptr [BP].b_col + add AL,CL + cmp AL,MAX_COLS + jle b_sml ; jump if label length is OK + sub AL,MAX_COLS + sub CL,AL ; force label to remain within 80-col screen +b_sml: mov DI,0 ; load label offset +lbl_loop: mov AH,0Eh ; Write ASCII Teletype + mov AL,byte ptr ES:[DI] + mov BL,byte ptr [BP].b_battr ; load attribute bits just in case + xor BH,BH ; page # for alpha mode + push CX + push DI + int IBM_CRT + pop DI + pop CX + inc DI + loop lbl_loop ; DECrement CX and jump if != 0 +; Output the bottom of the border +z_no_top: + mov dx,ds + mov es,dx + mov BL,byte ptr [BP].b_battr ; load attribute bits + mov DL,byte ptr [BP].b_line + add DL,byte ptr [BP].b_nlines + mov DH,byte ptr [BP].b_col ; load upper left column number + mov CX,[BP].b_ncols + call ztop + +; return to caller + pop BP ; restore caller's BP + xor ax,ax + ret ; return +border endp + +;************************************************************************ +;* Local Support: Draw a single character at cursor position * +;* * +;* Input Registers: AL - the character to be output * +;* BL - the character attributes for the write * +;* DH - column * +;* DL - row * +;* * +;* Registers Modified: AX,CX,SI,DI * +;************************************************************************ +zcorner proc near ; draw a single corner character + cmp DH,MAX_COLS + jae zcornret + cmp DL,MAX_ROWS + jae zcornret + push DX ; save cursor coordinates + push AX ; save character to be output + xor BH,BH ; page number (=0 for graphics mode also) + mov AH,02h ; load "put cursor" code + call CRT_DSR ; position the cursor +; read the character in this screen position +; ** This is tricky 'cause DH/DL are correct but +; ** will be swapped back (to incorrect) by CRT_DSR proc +; ** if using an IBM!!! + cmp PC_MAKE,TIPC + je no_swap + xchg DH,DL + xor BH,BH ; IBM display page +no_swap: mov AH,08h + call CRT_DSR +; see if it's one of the borderline characters + call map_char + mov SI,AX + pop AX ; recover character to be output + cmp SI,0 + jl zcornput +; map corner to border character + call map_char + mov DL,map_tabx-map_tab-1 + mul DL + add SI,AX + mov AL,trns_tab+[SI] +; output the corner character +zcornput: mov AH,09h ; load "write character/attribute" code + mov CX,1 ; number of characters = 1 + xor BH,BH ; Display page for IBM text mode (=0) + call CRT_DSR ; write it to the screen at cursor position + pop DX ; restore cursor coordinates +zcornret: ret ; return +zcorner endp + +;************************************************************************ +;* Local Support: Draw a border sides * +;* * +;* Input Registers: DH - column * +;* DL - row * +;* CX - number of rows * +;* * +;* Registers Modified: AX,CX,DL * +;************************************************************************ +zside proc near + cmp DH,MAX_COLS ; is column within the CRT's boundaries? + jae zsideret ; if not, jump +zside_lp: mov AL,0B3h ; load "|" border character + push CX ; save line count + push DX ; save next cursor position + call zcorner ; output the border character + pop DX ; restore current cursor position + pop CX ; restore line counter + inc DL ; increment the row number + loop zside_lp ; loop until side is drawn +zsideret: ret +zside endp + +;************************************************************************ +;* Local Support: Draw a border - Top or Bottom * +;* * +;* Input Registers: DH - column * +;* DL - row * +;* CX - number of columns * +;* * +;* Registers Modified: AX,CX * +;************************************************************************ +ztop proc near + cmp DL,MAX_ROWS ; is row within the CRT's boundaries? + jae ztopret ; if not, jump +ztop_lp: mov AL,0C4h ; load "-" border character + push CX ; save line count + push DX ; save next cursor position + call zcorner ; output the border character + pop DX ; restore current cursor position + pop CX ; restore line counter + inc DH ; increment the column number + loop ztop_lp ; loop until top/bottom is drawn +ztopret: ret +ztop endp + +;************************************************************************ +;* Local Support: return character mapping * +;* * +;* Input Registers: AL = character * +;* * +;* Registers Modified: CX,DI * +;************************************************************************ +map_char proc near + mov CX,map_tabx-map_tab + mov DI,offset map_tab +repne scasb + mov AX,CX + dec AX + ret +map_char endp + +;************************************************************************ +;* Save Screen Contents * +;* * +;* Purpose: To save a rectangular region of the CRT in a string data * +;* object. * +;* * +;* Calling Sequence: save_scr(str_reg, ul_row, ul_col, n_rows, ncols) * +;* where str_reg - pointer to string data object * +;* which is to receive the screen * +;* contents * +;* ul_row - row number of the upper left * +;* corner of the region to be * +;* saved * +;* ul_col - column number of the upper left * +;* corner of the region to be * +;* saved * +;* n_rows - number of rows in the region to * +;* be saved * +;* n_cols - number of columns in the region * +;* to be saved * +;************************************************************************ +sv_args struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address + dd ? ; caller's return address +sv_op dw ? ; save screen opcode +sv_str dw ? ; address of register pointing to string +sv_ulrow dw ? ; upper left hand corner's row number +sv_ulcol dw ? ; upper left hand corner's column number +sv_nrow dw ? ; number of rows +sv_ncol dw ? ; number of columns +sv_args ends + + public save_scr +save_scr proc near +;;; int 3 + push ES + push BP ; save the caller's BP register + mov BP,SP ; and establish local addressability +; create a pointer to the string object +;;; mov BX,[BP].sv_str ; load address of register +;;; mov DI,[BX].C_disp ; load the string +;;; mov BX,[BX].C_page ; pointer +;;; %LoadPage ES,BX ; load string page's paragraph address +;;; mov ES,pagetabl+[BX] ; load string page's paragraph address +;;; add DI,BLK_OVHD ; advance pointer past string header + + mov ES,[BP].sv_str + xor DI,DI ;ES:DI => string + +; store number of rows and columns into the first two bytes of the string + mov AL,byte ptr [BP].sv_nrow + stosb + mov AL,byte ptr [BP].sv_ncol + stosb +; adjust number of lines/columns for test conditions + mov AX,[BP].sv_ulrow + add [BP].sv_nrow,AX + mov AX,[BP].sv_ulcol + add [BP].sv_ncol,AX +; loop until all rows processed + mov DL,byte ptr [BP].sv_ulrow +rw_loop: mov DH,byte ptr [BP].sv_ulcol +; position cursor +cl_loop: push DX ; save current position + mov AH,02h ; load "put cursor" function id + xor BH,BH ; IBMism (page number for cursor) + call crt_dsr ; position the cursor +; read character/attributes at current screen position + mov AH,08h ; load "read char/attribute" function id + xor BH,BH ; IBMism (display page #) + call crt_dsr ; read said +;******* + cmp vid_mode,14 + jl sav_01 ; not graphics modes + cmp AL,0 ; don't bother with attributes if nul + je sav_01 +; cmp AL,07fh ; is it above the first 128 characters ? +; jno sav_00 ; no + cmp AL,0dah + jbe sav_00 +; test AL,010h ; look for D0-DF +; je sav_00 + xor AL,AL ; set to nul + jmp sav_01 +sav_00: call graph_attr ; mode 14 and 16 attribute function +;****** +sav_01: stosw ; store char/attr into output string +; increment column number, test, branch + pop DX + inc DH + cmp DH,byte ptr [BP].sv_ncol + jl cl_loop +; increment row number, test, branch + inc DL + cmp DL,byte ptr [BP].sv_nrow + jl rw_loop + +; return to caller + pop BP + pop ES + xor ax,ax + ret ; return to caller +save_scr endp + +;************************************************************************ +;* Restore Screen Contents * +;* * +;* Purpose: To restore a rectangular region of the CRT from a string * +;* data object. * +;* * +;* Calling Sequence: rest_scr(str_reg, ul_row, ul_col) * +;* where str_reg - pointer to string data object * +;* which contains the screen * +;* contents * +;* ul_row - row number of the upper left * +;* corner of the region to be * +;* restored * +;* ul_col - column number of the upper left * +;* corner of the region to be * +;* restored * +;************************************************************************ +rs_args struc +rs_nrow dw ? ; number of rows in saved data +rs_ncol dw ? ; number of columns in saved data +rs_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address + dd ? ; callers return address +rs_op dw ? ; restore screen opcode +rs_str dw ? ; segment address of string +rs_ulrow dw ? ; upper left hand corner's row number +rs_ulcol dw ? ; upper left hand corner's column number +rs_mrow dw ? ; number of rows in new window +rs_mcol dw ? ; number of columns in new window +rs_args ends + + public rest_scr +rest_scr proc near + int 3 + push ES + push BP ; save the caller's BP register + sub SP,offset rs_BP + mov BP,SP ; and establish local addressability + +; address the string + + mov ES,[BP].rs_str + xor SI,SI ; ES:SI => string + +; get number of rows and columns from screen object + xor AH,AH + lods byte ptr ES:[SI] + add AX,[BP].rs_ulrow + mov [BP].rs_nrow,AX + xor AH,AH + lods byte ptr ES:[SI] + add AX,[BP].rs_ulcol + mov [BP].rs_ncol,AX +; adjust number of lines/columns for test conditions + mov AX,[BP].rs_ulrow + add [BP].rs_mrow,AX + mov AX,[BP].rs_ulcol + add [BP].rs_mcol,AX +; loop until all rows processed + mov DL,byte ptr [BP].rs_ulrow +xw_loop: mov DH,byte ptr [BP].rs_ulcol +; position cursor +xl_loop: cmp DH,byte ptr [BP].rs_mcol ; column too long for new window? + jge x_long ; if too long, jump + push DX ; save current position + mov AH,02h ; load "put cursor" function id + xor BH,BH ; IBMism (page number/0 in graphic mode) + call crt_dsr ; position the cursor +; read character/attributes at current screen position + lods word ptr ES:[SI] ; fetch the character and attribute + +;;;;;;;; cmp AL,20h +;;;;;;;; je x_sp ; if a space skip + + mov BL,AH ; and copy attribute to BL + mov AH,09h ; load "write char/attribute" function id + xor BH,BH ; IBMism (page number) + mov CX,1 ; character count = 1 + call crt_dsr ; read said +; increment column number, test, branch +x_sp: pop DX ; recover the row/column coordinates +x_more: inc DH ; increment the column number + cmp DH,byte ptr [BP].rs_ncol ; more characters in this row? + jl xl_loop ; if so, jump +; increment row number, test, branch + inc DL ; increment the row number + cmp DL,byte ptr [BP].rs_mrow ; check against new window boundary + jge rs_fin ; if all rows filled, jump + cmp DL,byte ptr [BP].rs_nrow ; check against saved data + jl xw_loop ; if more lines, jump + +; return to caller +rs_fin: add SP,offset rs_BP ; deallocate local storage + pop BP ; restore the caller's BP register + pop ES ; restore the caller's ES register + xor ax,ax + ret ; return to caller +; +x_long: inc SI ; increment index into saved screen + inc SI ; buffer + jmp short x_more ; continue processing row +rest_scr endp + + +;************************************************************************ +;* Output Character To Window * +;************************************************************************ +pch_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +p_op dw ? ; putchar opcode +p_line dw ? ; cursor position - line number +p_col dw ? ; cursor position - column number +p_char dw ? ; character to write +p_attr dw ? ; character's attributes +pch_args ends + + public putchar +putchar proc near + push BP ; save caller's BP + mov BP,SP +; position cursor for write + mov DL,byte ptr [BP].p_line ; load line number + mov DH,byte ptr [BP].p_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].p_attr ; load its attributes + cmp vid_mode,14 ; only attribute for EGA modes is a + jl pchar_1 ; simulated reverse video + + mov BH,BL ; save the attribute + and BH,80h ; reverse video? + jz pchar_1 ; zero indicates bit 8 not set + +pchar_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 +pchar_1: mov AL,byte ptr [BP].p_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 + xor ax,ax + pop BP + ret +putchar endp + +;************************************************************************ +;* Scroll Window Up one line * +;************************************************************************ +su_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +su_op dw ? ; scroll opcode +su_line dw ? ; upper left hand corner line number +su_col dw ? ; upper left hand corner column number +su_nline dw ? ; number of lines +su_ncols dw ? ; number of columns +su_attr dw ? ; text attributes (used for blanking) +su_args ends + + public scrollup +scrollup proc near + push BP ; save caller's BP + mov BP,SP +; scroll window's text up one line + mov CL,byte ptr [BP].su_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].su_ncols ; load number of columns + mov DL,byte ptr [BP].su_line ; load upper left line number + mov DH,byte ptr [BP].su_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,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].su_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].su_col ; load starting column number + mov DL,byte ptr [BP].su_line ; load upper line number + add DL,byte ptr [BP].su_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].su_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].su_ncols ; load line length + call crt_dsr ; write a line of blanks +; return to caller +z_quit: pop BP + xor ax,ax + ret +scrollup endp + + +;************************************************************************ +;* Scroll Window Down one line * +;************************************************************************ +sd_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +sd_op dw ? ; op code +sd_line dw ? ; upper left hand corner line number +sd_col dw ? ; upper left hand corner column number +sd_nline dw ? ; number of lines +sd_ncols dw ? ; number of columns +sd_attr dw ? ; text attributes (used for blanking) +sd_args ends + +scrolldn proc near + push BP ; save caller's BP + mov BP,SP +; scroll window's text down one line + mov CL,byte ptr [BP].sd_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].sd_ncols ; load number of columns + mov DL,byte ptr [BP].sd_line ; load upper left line number + mov DH,byte ptr [BP].sd_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].sd_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].sd_col ; load starting column number + mov DL,byte ptr [BP].sd_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].sd_attr ; load attribute bit setting + xor BH,BH ; IBMism + mov CX,[BP].sd_ncols ; load line length + call crt_dsr ; write a line of blanks +; return to caller +quit: pop BP ; restore caller's BP + xor ax,ax + ret +scrolldn endp + +;**************************************************************************** +;* * +;* Change Video Mode * +;* * +;* Purpose: to note changes to video mode. * +;* * +;**************************************************************************** +chgvmode struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +chg_op dw ? ; op code +chg_chgt dw ? ; new character height +chg_mode dw ? ; new video mode +chg_rows dw ? ; new max rows for screen +chgvmode ends + + public chgmode +chgmode proc near + int 3 + push bp + mov bp,sp + mov ax,[bp].chg_mode + mov VID_MODE,ax + mov ax,[bp].chg_chgt + mov CHAR_HGT,ax + mov ax,[bp].chg_rows + mov MAX_ROWS,al + pop bp + xor ax,ax + ret +chgmode endp + + + +;**************************************************************************** +;* * +;* WRITE BLOCK OF CHARACTERS * +;* * +;* Purpose: Write a character string to the display * +;* * +;**************************************************************************** +wblk_args struc + dw ? ;caller's BP + dw ? ;return address + dd ? ;caller's return address +blk_op dw ? ;op code +blk_len dw ? ;length of block to write +blk_buf db 100 dup (?) ;buffer to write +blk_txt dw ? ;text attributes +blk_cur dw ? ;cursor position +wblk_args ends + + public wblock +wblock proc near + int 3 + push bp + mov bp,sp + + mov ah,02h ;load "put cursor" code + xor bh,bh ;IBMism - page 0 for text mode + mov dx,[bp].blk_cur ;dx = cursor coordinates + call crt_dsr ;position the cursor + + mov cx,[bp].blk_len ;cx = number of characters + + cmp PC_MAKE,TIPC ;on what flavor PC are we running? + jne blk_ibm ;if an IBM, jump +; Write line to TIPC's screen + mov al,byte ptr [bp].blk_txt ;load text attributes + mov ah,010h ;load "write block w/ attr" code + mov dx,ss ;load segment address + mov bx,bp ;load buffer offset in segment + add bx,blk_buf + int TI_CRT + jmp blk_end + +; Write line to IBM's screen +blk_ibm: mov di,bp + add di,blk_buf ;load buffer offset + mov dx,[bp].blk_cur ;reverse row/column coordinates + xchg dl,dh + mov [bp].blk_cur,dx + push cx ; save + jmp short blk_imidl ;jump into middle of loop + +blk_iloop: + push cx ;save the character counter + mov dx,[bp].blk_cur ;load the previous cursor coordinates, + inc dl ;increment the column number + mov [bp].blk_cur,dx ;and save new coordinates + xor bh,bh ;page number (0 for graphics mode) IBMism + mov ah,02h ;load "put cursor" code + push di + int IBM_CRT ;position the cursor + pop di +blk_imidl: + mov ah,09h ;load "write char w/ attributes" code + mov al,byte ptr ss:[di] ;load character from buffer + mov BL,byte ptr [bp].blk_txt ;load attribute bits + xor bh,bh ;page # for alpha mode + mov cx,1 ;load repeat count = 1 + pop dx ;restore character count +; test to see if we buy anything by using a repeat count +blk_imore: + cmp dx,1 ;more characters to display? + jle blk_ibotm ;if no more characters, jump + cmp al,byte ptr ss:[di]+1 ;is next character the same as previous? + jne blk_ibotm ;if not same character, jump + inc cx ;increment the repeat count + inc di ;increment the output buffer index + inc byte ptr [bp].blk_cur ;increment the cursor position + dec dx ;decrement the character count + jmp blk_imore ;try for another +blk_ibotm: +; output the character(s) + push dx ;save the adjusted character count + push di ;save the output buffer index + int IBM_CRT ;output the char(s) + pop di ;restore the output buffer index + pop cx ;restore character counter + inc di ;increment buffer pointer + loop blk_iloop ;continue 'til all characters output + +blk_end: + pop bp ;restore stack + ret ; and return +wblock endp + +;**************************************************************************** +;* * +;* WRITE CHARACTER STRING * +;* * +;* Purpose: Write a character string to the given port object * +;* * +;**************************************************************************** +wstr_args struc + dw ? ; caller's BP + dw ? ; return address + dd ? ; caller's return address +wrt_op dw ? ; op code +;;; wrt_newl dw ? ; newline before writing +wrt_wrap dw ? ; check wrap before writing string +wrt_offs dw ? ; string offset +wrt_seg dw ? ; string segment +wrt_len dw ? ; # characters +wrt_port dw ? ; port object +wstr_args ends + + public wstring +wstring proc near + int 3 + push bp + mov bp,sp + cmp [bp].wrt_len,0 ;anything to write? + jg wst_10 ; yes, continue + jmp wst_fin +wst_10: + + cmp [bp+wrt_wrap],0 ;check wrap before writing? + je wst_15 ; no, continue + xor ax,ax ;ax = wrap indicator (0 = no) + mov bx,[bp+wrt_port].pt_ncols ;bx = line length + cmp bx,0 ;maintaining line length? + je wst_15 ; no, jump + mov cx,[bp+wrt_port].pt_ccol ;cx = current column + cmp cx,1 ;in first column already? + jle wst_15 ; yes, jump + sub bx,cx ;determine space remaining + cmp bx,[bp+wrt_len] ;room left on current line? + jge wst_15 ; yes, jump + inc ax ;set wrap indicator +wst_15: + mov [bp+wrt_wrap],ax ;update wrap indicator + mov bx,[bp+wrt_port].pt_pflgs ;get window flags + test bx,OPEN ;is port open for writing? + jz wst_esc ; no, get outa here + test bx,STRIO ;is port a string? + jnz wst_esc ; yes, return + test bx,WINDOW ;is port a window? + jnz wst_win ; yes, go to window code + jmp wst_fil ; no, go to file code +wst_esc: jmp wst_fin +;***************************************************************************** +; We have a valid window port. Write the string to the display. +;***************************************************************************** +wst_win: + les di,dword ptr [bp+wrt_offs] ;es:di => string buffer + + mov bx,[bp+wrt_port].pt_cline ;bx = current line + mov ax,[bp+wrt_port].pt_ccol ;ax = current column + mov dx,[bp+wrt_port].pt_ullin ;dx = upper left line # + cmp [bp+wrt_wrap],0 ;wrap before writing string? + je wwin_start ; no, jump + xor ax,ax ;clear current column + inc bx ;bump current line + cmp bx,[bp+wrt_port].pt_nline ;exceeded number of lines? + jl wwst_w10 ;no, skip scroll + int 3 + call scrollit ;scroll the display +wwst_w10: + push ax + push di + push es:[di] ;next character + call isspace ;determine if whitespace + pop di + or ax,ax ;is it? + pop ax + jz wwin_start ; no, jump + inc di + dec [bp+wrt_len] ;decrement string length + jnz wwin_start ;if non-zero, go + mov [bp+wrt_port].pt_cline,bx ;save current cursor line number + mov [bp+wrt_port].pt_ccol,ax ;save current cursor column number + jmp wst_fin ; else return +wwin_start: + mov cx,[bp+wrt_len] +; +; loop through the chars, writing them to the display +; +wwin_loop: + push cx + push di + + mov cl,es:[di] + cmp cl,RETURN ;if char = carriage return +;;;;;;;; je wwin_creturn ; then jump + ja wwin_default ;if not control char, jump + xor ch,ch + mov si,cx + shl si,1 ;get index into jump table + jmp [wn_handle+si] ;go to handler + +; default character handler +; +wwin_default: + cmp ax,[bp+wrt_port].pt_ncols ;are we in the last column? + jl wwin_linechk ; no, jump + test [bp+wrt_port].pt_wflgs,W_WRAP ;wrap option on? + jnz wwin_scrl ; yes, jump + inc ax ;clip - bump column + jmp wwin_100 ; continue +wwin_linechk: + cmp bx,[bp+wrt_port].pt_nline ;out of lines? + jl wwin_wchar ;no, return +wwin_scrl: + inc bx ;bump current line + xor ax,ax ;clear column + cmp bx,[bp+wrt_port].pt_nline ;exceeded number of lines? + jl wwin_wchar ; no, jump + call scrollit +wwin_wchar: + push ax ;save current column + push bx ;save current line + + cmp vid_mode,3 + jne wwin_gen + cmp pc_make,1 + je wwin_gen + + xchg ax,bx + add ax,[bp+wrt_port].pt_ullin + mov ah,80 + mul ah + add ax,bx + add ax,[bp+wrt_port].pt_ulcol + shl ax,1 + mov si,ax + mov ch,byte ptr [bp+wrt_port].pt_text + push ds + push 0B800h + pop ds + mov [si],cx + pop ds + jmp wwin_nxt +wwin_go: + jmp wwin_loop +wwin_gen: + push [bp+wrt_port].pt_text ;push text character attribute + push es:[di] ;push the character + add ax,[bp+wrt_port].pt_ulcol + push ax ;column number to console + add bx,[bp+wrt_port].pt_ullin + push bx ;line number to console + sub sp,6 + call putchar ;display character + add sp,14 ;dump args off stack +wwin_nxt: + pop bx ;restore current line + pop ax ;restore current column + inc ax ;increment current column +wwin_100: mov [bp+wrt_port].pt_cline,bx ;save current cursor line number +wwin_120: mov [bp+wrt_port].pt_ccol,ax ;save current cursor column number + pop di + inc di + pop cx + loop wwin_go +;;;; loop wwin_loop ;if more chars, loop + jmp wst_fin ; else go home + +; +; Handlers for special characters (RETURN,LINEFEED,TAB,BACKSPACE) +; + +; Carriage return character handler +wwin_creturn: + mov cl,LINEFEED ;fall thru to linefeed handler +; Line Feed character handler +wwin_linefeed: + xor ax,ax ;clear column + inc bx ;bump line number + cmp bx,[bp+wrt_port].pt_nline ;exceeded number of lines? + jl wwin_100 ; no, jump + call scrollit ; yes, scroll + jmp wwin_100 +; Backspace character handler +wwin_backspace: + dec AX ;decrement current column + cmp AX,0 ;if column now positive + jge wwin_120 ; then return + xor AX,AX ;cur_col = 0 + jmp wwin_120 ;return +; Bell character handler +wwin_bell: + push ax + push bx + call bell ;sound the alarm + pop bx + pop ax + jmp wwin_120 ;and return +; Tab character handler +wwin_tab: + mov cx,ax ;cx = current column + mov dx,8 ;dl = 8 + div dl ;ah = (cur_col % 8) + sub dl,ah + add cx,dx + mov ax,cx ;update current column + jmp wwin_120 ;and return + +;***************************************************************************** +; We have a valid file port. Write the string to the disk. +;***************************************************************************** +wst_fil: + int 3 + xor ax,ax ;clear ax for char later + les di,dword ptr [bp+wrt_offs] ;es:di => string buffer + + test [bp+wrt_port].pt_pflgs,BINARY ;binary file? + jnz wfil_start ; yes, skip newline + cmp [bp+wrt_wrap],0 ;wrap before writing string? + je wfil_start ; no, go write chars to disk + mov al,RETURN ; yes, write CR/LF to file + call write_char + xor ax,ax ;set current column to 0 + call upd_port ;update port object + mov al,LINEFEED + call write_char + xor ax,ax ;set current column to 0 + call upd_port ;update port object + push di + push es:[di] + call isspace ;determine next char whitespace + pop di + or ax,ax ;is it? + jz wfil_start ; no, jump + inc di ; + dec [bp+wrt_len] ;decrement string length + jnz wfil_start ;if non-zero, continue + jmp wst_fin ; else return +wfil_start: + mov cx,[bp+wrt_len] +; +; loop through the chars, writing them to the display +; +wfil_loop: + push cx ;save length + push di ;save index to string + + mov cl,es:[di] ;get character just written + cmp cl,RETURN ;test for control char + ja wfil_default ; if not, handle as default case + je wfil_newline ; if return, go handle + xor ch,ch ;clear high byte + mov si,cx ;move char to index reg + shl si,1 ;get index into jump table + jmp [ds_handle+si] ;go to handler + +wfil_default: + mov cx,1 ;cx = length + mov bx,[bp+wrt_port].pt_handl ;bx = handle + mov dx,di ;dx = offset + mov ax,es ;ax = segment + call diskout + mov ax,[bp+wrt_port].pt_ccol ;ax = current column + cmp ax,[bp+wrt_port].pt_ncols ;have we exceeded line length + jl wfil_10 ; no, jump + xor ax,ax ;clear current column + jmp wfil_upd ;go update port data +wfil_10: inc ax ;bump current column +wfil_upd: call upd_port + pop di ;restore string index + inc di ;and increment + pop cx ;restore length + loop wfil_loop ;loop if more +wst_fin: + xor ax,ax + pop bp + ret ;return to caller + +; +; Handlers for special characters (RETURN,LINEFEED,TAB,BACKSPACE) +; + +; Carriage return or linefeed character handler +wfil_newline: + test [bp+wrt_port].pt_pflgs,BINARY ;binary file? + jnz wfil_default ; yes, output char + mov al,RETURN ; no, output cr/lf + call write_char + xor ax,ax ;set current column to 0 + call upd_port ;update port object + mov al,LINEFEED + call write_char + xor ax,ax + jmp wfil_upd + +; backspace character handler +wfil_backspace: + test [bp+wrt_port].pt_pflgs,BINARY ;binary file? + jnz wfil_10 ;yes, output char + mov al,byte ptr es:[di] ;al = backspace char + call write_char ;write it out + mov ax,[bp+wrt_port].pt_ccol ;ax = current column + dec ax ;decrement it + cmp ax,0 + jge wfil_upd + xor ax,ax + jmp wfil_upd +; tab character handler +wfil_tab: + test [bp+wrt_port].pt_pflgs,BINARY ;binary file? + jnz wfil_10 ;yes, jump + mov al,byte ptr es:[di] ;al = tab char + call write_char ;write it out + mov ax,[bp+wrt_port].pt_ccol ;ax = current column + mov cx,ax + mov dx,8 + div dl ; ah = (cur_col % 8) + sub dl,ah + add cx,dx + mov ax,cx + jmp wfil_upd + + +;***************************************************************************** +; Utilty routines for writing characters to display or disk +;***************************************************************************** + +;UPD_PORT - update port object +; entry: ax = current column +upd_port proc near + cmp [bp+wrt_port].pt_ncols,0 ;if line length = 0 + je upd_05 ; then don't maintain column + mov [bp+wrt_port].pt_ccol,ax ;save current column +upd_05: + mov ax,[bp+wrt_port].pt_bfpos ;get current buffer position + inc ax ;bump the position + cmp ax,256 ;crossed chunk boundary? + jle upd_10 ; no, jump + sub ax,256 ;ax=excess above chunk + inc [bp+wrt_port].pt_chunk ;update chunk number +upd_10: mov [bp+wrt_port].pt_bfpos,ax ;update buffer position + ret +upd_port endp + +;WRITE_CHAR - write character to port +; entry: ax = character to write to port +write_char proc near + mov cx,1 ;length + mov bx,[bp+wrt_port].pt_handl ;handle + push ax + mov dx,sp + mov ax,ss + call diskout + pop ax + ret +write_char endp + + +;DISKOUT - output char(s) to disk +; entry: ax=segment, bx=handle, cx=buffer length, dx=offset +; exit: carry set = error, ax=status +; errors will return to the caller of wstring +diskout proc near + push ds + mov ds,ax + mov ah,WRITEFILE + int DOS ;perform disk write + pop ds + jc diskerr + cmp ax,cx ;everything written? + je diskret ; yes, return + mov ax,DISK_FULL ;note disk full error + jmp derr_ret +diskerr: + int 3 +;;; +;;; For some reason, the following doesn't work. Must be a failure by +;;; AI Architects support of Get Extended Error. In the interim, just +;;; use the return value in ax. Returning is easy, just dump local +;;; storage from the stack, pop the callers bp, and return. +;;; +;;; xor bx,bx +;;; mov AH,059h ;GET_EXTENDED_ERROR +;;; int DOS ;Extended error code in AX +derr_ret: mov sp,bp ;dump everything off stack + pop bp ;return to handler, error in ax +diskret: + ret +diskout endp + +;ISSPACE - determine if character is whitespace +; +isspace proc near + pop di + pop ax + cmp al,' ' + je issp + cmp al,9 + jb isntsp + cmp al,13 + jbe issp +isntsp: xor ax,ax +issp: jmp di +isspace endp + + +;Scrollit - local support to scroll window +; entry: ax = column, bx = line +; exit: ax = column, bx = line +scrollit proc near + cmp bx,[bp+wrt_port].pt_nline ;out of lines? + jl scrl_ret ;no, return + push [bp+wrt_port].pt_text + push [bp+wrt_port].pt_ncols + push [bp+wrt_port].pt_nline + push [bp+wrt_port].pt_ulcol + push [bp+wrt_port].pt_ullin + sub sp,6 ;dummy args for scroll + call scrollup ;scroll window up one line + add sp,16 ;dump args off stack + mov bx,[bp+wrt_port].pt_nline ;bx = number of lines + dec bx ;bx = line number + xor ax,ax ;ax = column +scrl_ret: + ret +scrollit endp + +wstring endp + +;************************************************************************ +;* Perform appropriate VIDEO I/O interrupt * +;* Any difference in register definition should be handled by * +;* the caller except where DH,DL contain row,col information. * +;************************************************************************ + public crt_dsr +crt_dsr proc near + cmp PC_MAKE,TIPC + jne ibm_dsr + int TI_CRT + ret +ibm_dsr: xchg DH,DL ; Do this now instead of making special checks + int IBM_CRT ; IBM's row,col is diff'rnt from TI's col,row + ret +crt_dsr endp + +z_ega proc near + + mov AX,0A000h + 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 + 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 c_nrows ; decrement row count + jg zc_03 ; if more rows, loop (jump) + ret +z_ega endp + +;************************************************************************ +;* Graphics Character Attribute * +;* * +;* Purpose: To retrieve the attribute of a character on an IBM screen * +;* in a graphics mode, either 14 or 16. * +;* * +;************************************************************************ + + public graph_attr +graph_attr proc near + + cmp AL,20h ; skip if a space + je grphend + + cmp AL,00h ; skip if a null + je grphend + + cmp AL,0dbh ; block character? + je grphend + + push ES + push SI + push AX ; save character + push DX ; save row and column + xor AH,AH ; clear AH + mov SI,AX ; use SI as an index + sub SI,21h + + mov AL,DL ; row + mul char_hgt ; pixels per character + xor BX,BX + + mov BL,byte ptr m18_attr[SI] ; default mode 18 adjustment + cmp vid_mode,18 ; are we in mode 18? + je grph_02 ; yes, jump + mov BL,byte ptr m16_attr[SI] ; default mode 16 adjustment + cmp vid_mode,16 ; are we in mode 16? + je grph_02 ; yes, jump + mov BL,byte ptr m14_attr[SI] ; must be mode 14 +grph_02: + add AX,BX + mov BX,80 ; 80 bytes per line + mul BX + + pop DX ; restore the column + xor DL,DL ; clear the row + xchg DH,DL ; set AX to the row + add AX,DX + mov SI,AX ; put result in SI + + mov AX,0a000h ; load in graphics plane + mov ES,AX + + xor CX,CX ; clear CX + + mov CH,01 + mov AH,0 +grph_03: call get_val + + shl CH,1 ; shift mask one bit to the left + inc AH ; next plane + cmp AH,3 + jbe grph_03 + + pop AX ; retrieve character + mov AH,CL ; set attribute byte + pop SI + pop ES +grphend: ret +graph_attr endp + +get_val proc near + push AX ; save AH + mov DX,3ceh ; port addr of sequencer + mov AL,04h ; index to other map mask register + out DX,AL ; set index register + inc DX + xchg AL,AH + out DX,AL ; enable bank + pop AX ; restore AH + mov AL,ES:[SI] + or AL,AL + jz get_end + or CL,CH ; set attribute bit +get_end: ret +get_val endp + +; PCTYPE +; Determine type of PC we are running on and initialize screen. +; +; Returns upon exit: +; Machine Type +; 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 +; F8 for PS2 Model 80 +; 0 for undeterminable +; Video Mode +; Character Height +; +pctype proc near + push es ; preserve regs for later + push ds + + 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" + 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,0f0h ; 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 + cmp bx,1 ; TIPC? + jne not_ti ; no, jump +; tipc, initialize graphics + mov di,0DF01h + mov es,di ; clear graphics planes + xor di,di + mov byte ptr es:[di],0AAh ; set red palette + mov byte ptr es:[di]+16,0CCh ; set green palette + mov byte ptr es:[di]+32,0F0h ; set blue palette + + mov ax,0DF82h + mov es,ax + mov byte ptr es:[di],040h ; turn text on + + mov ax,3 ; ax = video mode + ; bx = pc type code + mov cx,8 ; cx = character height + jmp pc_020 +; ibm, (assumed) get current video mode +not_ti: + push bx ; save pc type code around bios calls + mov ax,0500h ; set active display page (for alpha modes) + int 10h ; bios int + mov ah,15 ; get current video mode + int 10h ; bios int + xor ah,ah ; ax = video mode + pop bx ; bx = pc type code + mov cx,8 ; cx = character height + cmp ax,16 ; if video mode = 16 + jle pc_020 ; then + mov cx,14 ; reset character height +pc_020: + pop ds ; restore local data seg + pop es ; es:di addresses transaction buffer + xor di,di + + mov PC_MAKE,bx ; put PC_MAKE in transaction buffer + mov VID_MODE,ax ; ditto video mode + mov CHAR_HGT,cx ; ditto char height + ret +pctype endp + + + page +;----------------------------------------------------------------------------- +; The XLI interface. +;----------------------------------------------------------------------------- + +main proc far ;this file's initial entry point + mov AX,data + mov DS,AX +; mov AX,stack ;establish local stack +; mov SS,AX + + call pctype ;initialize type/monitor info + + mov psp,ES ;save PSP@ + mov word ptr ES:fb_addr,offset file_block ;poke file block@ + mov word ptr ES:fb_addr+2,seg file_block ;into PSP + mov AX,ES:term_addr ;calc ptrs in PCS to jump to + add AX,3 + mov xwait,AX + add AX,3 + mov xbye,AX + mov AX,ES:term_addr+2 + mov xwait+2,AX + mov xbye+2,AX + mov psize,plen ;calc program size + push psp + push psize + call dword ptr [xwait] ;connect with PCS +; Since this is a XLI SYSINT routine, no XCALL's ever cause a return. +; The only time we return is to terminate. + pop AX + pop AX + call dword ptr [xbye] ;disconnect from PCS +main endp + +progsize = $-progstart +plen equ (progsize+datasize+stacksize+100h+10h)/16 +PROG ends + end main + \ No newline at end of file diff --git a/realio.equ b/realio.equ new file mode 100644 index 0000000..ecabbb6 --- /dev/null +++ b/realio.equ @@ -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 , ;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 + 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 + + + \ No newline at end of file diff --git a/realschm.asm b/realschm.asm new file mode 100644 index 0000000..3d64d29 --- /dev/null +++ b/realschm.asm @@ -0,0 +1,1357 @@ +; =====> REALSCHM.ASM +; PC Scheme Real Procedures for Protected Mode Scheme +; (c) 1987 by Texas Instruments Incorporated -- all rights reserved +; Author: Terry Caudill +; History: +; tc 8/07/87 - to work in protected mode scheme (real mode side) +; tc 10/16/87 - modified to use local stack as transaction buffer + + + page 84,120 + name PCSXLI + title PC Scheme External Language Interface + + .286c ;; Utilize the expanded 80286 instruction set + include xli.mac + include xli.ref + include xli.equ + + subttl Stack and Data segment definitions + page + +stksize equ 20000 + +stack segment para stack 'STACK' +s_base db stksize dup (0) +stack ends + +data segment para public 'DATA' + public callers_ds,callers_dx + public load_table,work_area,active_exe +; +; Registers which should be saved due to RPC call +; +trans_buf equ $ +callers_dx dw 0 +callers_ds dw 0 +return_ss dw 0 +return_sp dw 0 +return_bp dw 0 +result_buffer dw 0 + +; +; jump table for specified function requests. this table is position +; dependent - see rpc.equ and pro2real.asm +; +first_sys_func equ 20 ;max number of rpc functions +next_avail_sys dw 0 ;next location in sys_func + +rpc_func dw ret_buffer ;0 - return stack buffer address + dw pctype ;1 - return pc type and graphics info + dw load_exe ;2 - load xli file + dw unload_all ;3 - unload all xli files + dw xesc ;4 - perform xternal escape function + dw ssr_return ;5 - Special Service return + dw takeover_crt ;6 - takeover crt int handler (for exec) + dw restore_crt ;7 - restore system crt int handler + dw 11 dup (unknown_func) ;9 - 19 + +sys_func dd unknown_func,prog ;20 + dd unknown_func,prog ;21 + dd unknown_func,prog ;22 + dd unknown_func,prog ;23 + dd unknown_func,prog ;24 + +; +; The following data structures support the XLI interface +; + +; Various tables +load_table dw N_EXE dup (0) ;PSP addresses (segment) +fb_table dd N_EXE dup (0) ;file block addresses (offset,segment) +pb_table dd N_EXE dup (0) ;parm block addresses (offset,segment) +state_table state N_EXE dup (<>) ;child's regs at point it called us +status_table label word ;records .EXE state (MSBy) and index (LSBy) +x = 0 + rept N_EXE + dw x +x = x+1 + endm + +; Parameter block for EXEC function request +zero equ $ ;a constant zero +exec_pblock dw 0 ;env@ (use Scheme's) + dw zero,seg zero ;cmd line@ (don't care) + dd -1 ;FCB@'s (don't care) + dd -1 + +; Working storage (during a given call to the external routine) + align 16,data +work_area label word ;for dealing with PCS data values + db PAD_SIZE*N_ARGS dup (0) ;during xesc, non-strings go here +; other information required during an xesc call +work_info xesc_struc <> ;general info +swap_table swap_struc N_ARGS dup (<>) ;records swap state for each XCALL arg +bid_name dw 0 ;pointer used for bidding child +; the child currently active or being loaded +active_exe dw 0 ;(same format as status table) + +; State (context) information +; child's registers upon calling PCS +save_ax dw 0 ;actually, we ignore ax..di entries +save_bx dw 0 +save_cx dw 0 +save_dx dw 0 +save_si dw 0 +save_di dw 0 +save_ds dw 0 +save_es dw 0 +save_ss dw 0 +save_sp dw 0 +save_bp dw 0 + +; our registers upon calling child +pcs_state state <> ;our state at point of calling child + + +pc_make dw 1 ;pc type 1 = tipc +crt_sav dw 0,0 ;location to save crt interrupt + +data ends + +prog segment para public 'PROG' + assume cs:prog,ds:data,es:data,ss:stack + + public load_exe,bid_child,c2p_handler,c2p_terminate + public xesc,unload_all,find_open_spot,table_search + public do_floarg,do_fixarg,do_bigarg,do_strarg + public do_floval,do_intval,do_TFval,do_strval + public unload_exe,unload_all + +; RPC_STARTUP +; This routine will be started initially by the protected mode +; application. Return the address of the message handler routine +; in DS:DX. +rpc_init proc far +rpc_startup: + mov ax,cs + mov ds,ax + mov dx,offset rpc_handler + ret +rpc_init endp + +; RPC_HANDLER +; Main control routine for calls to real procedures from protected mode +; scheme. When an RPC is issued, we will get control here. +; +; Upon entry: +; ds:dx => transaction buffer which contains a request. Typically, +; transaction_buffer[0] is an op code, which is used as +; an index into the RPC_FUNC table to determine the actual +; routine to call. Following locations in the transaction +; buffer can be used to pass other parameters and are +; dependent on the function called. +; Upon exit: +; Transaction_buffer[0] should contain an error indication. 0 = no error +; +rpc_handler proc far + int 3 ;for debugging purposes + pusha ;save callers state + +; First of all, lets instantiate our own data segment and save off the +; address of the transaction buffer. + mov ax,ds + mov es,ax ;es => transaction buffer + mov ax,data + mov ds,ax ;ds => our local data + mov callers_ds,es ;save off transaction buffer address + mov callers_dx,dx + mov di,dx + mov bx,es:[di] ;bx = the request opcode + mov word ptr es:[di],0 ;default return value to zero (o.k.) + ;handlers must reset for errors. + cmp bx,first_sys_func ;normal rpc function request? + jb rpc_h010 ;yes, jump + +; Opcodes >= first_sys_func reflect calls to system xli routines, and require +; arguments to be passed on the stack. Protected mode routines stuff the local +; stack segment (defined by STACK above) with the arguments before issueing +; the RPC. The code below must now instantiate the local stack and call a +; handler in the sys_func table above. + mov return_ss,ss ;save current stack segment + mov return_sp,sp ;save current stack pointer + mov return_bp,bp ;save current base pointer + mov ax,stack ;get local stack + mov ss,ax ; and instantiate + mov sp,es:[di]+2 ;transaction_buffer[2] = stack pointer + mov bp,sp ;base pointer = stack pointer + + sub bx,first_sys_func ;calc index into sys_func table + shl bx,1 + shl bx,1 + call dword ptr sys_func+[bx] ;call the routine + + mov ss,return_ss ;restore stack used upon entry + mov sp,return_sp + mov bp,return_bp + les di,dword ptr trans_buf ;restore access to transaction buffer + mov es:[di],ax ;transaction_buffer[0] = return status + jmp rpc_hret ;return to protected mode routine + +; We have a normal rpc call. Our local stack segment may have been stuffed with +; parmameters by the protected mode routine, so lets use it as our extra +; segment (AIA provides a stack segment with the rpc and we can just use it as +; our stack). +; +rpc_h010: + mov ax,stack + mov es,ax + xor di,di ;es:di => pro2real communication buffer + shl bx,1 ;convert func code to index + call rpc_func+[bx] ;call function +rpc_hret: + popa ;restore callers regs + ret ;return to protected mode + +rpc_handler endp + +; UNKNOWN_FUNC +; This routine is called when we get an undefined op-code. Return a +; negative one to the protected mode routine as an error indicator. +; +unknown_func proc near + les di,dword ptr trans_buf ;es:di => transaction buffer + mov word ptr es:[di],-1 ;return error condition + ret +unknown_func endp + +; RET_BUFFER +; Return address of local stack segment. This segment will be used by the +; protected mode routines as a communication buffer between real and protected +; mode. It will be used by other RPC function requests for passing args and +; returning values. For system xli calls, it will be instantiated as the +; stack (see above rpc_handler). +ret_buffer proc near + les di,dword ptr trans_buf ;es:di => transaction buffer + mov es:[di]+2,stksize ;return length of communication buffer + mov ax,offset s_base ;ax = stack base + mov es:[di]+4,ax ;return as communication buffer offset + mov ax,stack ;get buffer segment + mov result_buffer,ax ; and save for later + mov es:[di]+6,ax ;return communication buffer segment + ret +ret_buffer endp + + +; PCTYPE +; Determine type of PC we are running on and initialize screen. +; +; Upon Entry: +; es:di => communication buffer +; +; Upon Exit: +; Communication_buffer[0] = Machine Type +; 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 +; F8 for PS2 Model 80 +; 0 for undeterminable +; Communication_buffer[2] = Video Mode +; Communication_buffer[4] = Character Height +; +pctype proc near + push es ; save comm buffer + push ds ; save local data seg + + 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" + 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,0f0h ; 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 + cmp bx,1 ; TIPC? + jne not_ti ; no, jump + +; We have a tipc, initialize the graphics + push 0DF01h + pop es ; clear graphics planes + xor di,di + mov byte ptr es:[di],0AAh ; set red palette + mov byte ptr es:[di]+16,0CCh ; set green palette + mov byte ptr es:[di]+32,0F0h ; set blue palette + + push 0DF82h + pop es + mov byte ptr es:[di],040h ; turn text on + + mov ax,3 ; ax = video mode + ; bx = pc type code + mov cx,8 ; cx = character height + jmp pc_020 + +; We have an ibm, (assumed) get current video mode +not_ti: + push bx ; save pc type code around bios calls + mov ax,0500h ; set active display page (for alpha modes) + int 10h ; bios int + mov ah,15 ; get current video mode + int 10h ; bios int + xor ah,ah ; ax = video mode + pop bx ; bx = pc type code + mov cx,8 ; cx = character height + cmp ax,16 ; if video mode = 16 + jle pc_020 ; then + mov cx,14 ; reset character height +pc_020: + pop ds ; restore local data seg + pop es ; restore communication buffer + xor di,di + mov word ptr es:[di]+0,bx ; put PC_MAKE in transaction buffer + mov word ptr es:[di]+2,ax ; ditto video mode + mov word ptr es:[di]+4,cx ; ditto char height +; +; and just for something different ... lets try some interrupts +; +TI_PBI equ 05Dh ; TI Program Break Interrupt +IBM_PBI equ 01Bh ; IBM Program Break Interrupt +GET_VEC equ 035h +SET_VEC equ 025h + + mov pc_make,bx ;save pc type + mov al,TI_PBI ;default ti program break int + cmp bx,1 ;are we tipc? + je vec_01 ; yes, jump + mov al,IBM_PBI ; no, get ibm pbi +vec_01: + mov ah,GET_VEC ;get vector +fix_010: + push ds ;tempsave data seg + mov dx,offset pbi_brk ;dx=offset of handler + mov cx,cs + mov ds,cx ;ds:dx => handler + int 21h + pop ds ;restore data seg + ret + +pbi_brk: + int 3 ;lets just break and + iret ;ignore for now + +pctype endp + + +ibm_crtint equ 010h +ti_crtint equ 049h + + +; Install new routine at the CRT DSR interrupt +; +takeover_crt proc near + int 3 + push es + push ds ; save segments + + mov ah,035h ;ah = get int vector address + mov al,ibm_crtint ;al = ibm crt interrupt + cmp pc_make,1 ;is it an ibm? + jne take_010 ; yes, jump + mov al,ti_crtint ;al = ti crt interrupt +take_010: + push ax ;save around dos int + int 21h ;get interrupt vector + mov crt_sav+2,es + mov crt_sav,bx ;save existing interrupt vector + pop ax ;restore int + + mov ah,025h ;ah = set int vector, al = int number + mov dx,offset crtdsr + push cs + pop ds ;ds:dx => new interrupt handler + int 21h ;set interrupt vector + pop ds + pop es + ret +takeover_crt endp + +; +; This routine restores the original routine for the CRT DSR interrupt +; +restore_crt proc near + int 3 + push ds ;tempsave data segment + + mov ah,025h ;ah = set int vector address + mov al,ibm_crtint ;al = ibm crt interrupt + cmp pc_make,1 ;is it a ibm? + jne restore_010 ; yes, jump + mov al,ti_crtint ;al = ti crt interrupt +restore_010: + mov dx,crt_sav + mov ds,crt_sav+2 ;ds:dx => system interrupt handler + int 21h ;set interrupt vector + + pop ds ;restore data segment + ret +restore_crt endp + +; +; This is the do-nothing routine installed at the CRT DSR interrupt +; +crtproc proc far +crtdsr: + sti + mov ax,0 + iret +crtproc endp + + +; LOAD_EXE +; Load an XLI file as a child process, setting up all the necessary hooks +; so that it can be called via an xesc, or system xli call. +; +; Upon Entry: +; ES:DI => communication buffer. The structure ld_args (defined below) +; indicates the structure of the buffer. +; Upon Exit: +; The first word in the transaction buffer will be set as follows: +; The high order byte will contain a flags byte where +; success = carry clear +; failure = carry set +; The low order byte will contain the error +; 0 = no open slots +; <> 0 = EXEC failure code + +ld_args struc ;structure of transaction buffer for load exe +sysflag dw ? ;1 = system flag, 0 = user defined +exe_index dw ? ;offset to exe name within pathname +pathname db ? ;pcs-sysdir pathname +ld_args ends + +load_exe proc +; if we succeed, state=EXE_NONE + call find_open_spot ;this sets active_exe + mov ax,0 + jc le_exit ;no open slots +; set state=EXE_TSR for time between EXEC and TSR + load_index itself + mov bh,EXE_TSR + mov active_exe,bx + cmp es:[di].sysflag,1 ;loading system .EXE? + je le_5 ;yes, look only in pcs-sysdir + mov ax,es:[di].exe_index ;get address of filename only + mov bid_name,ax ;try current directory first + call bid_child + jnc le_10 ;bid succeeded, jump +le_5: + mov ax,pathname ;try looking in pcs-sysdir + add ax,di + mov bid_name,ax + call bid_child + jc le_exit ;bid failed, jump +; child is ready, set state=EXE_NORM +le_10: load_index itself + mov bh,EXE_NORM + mov ax,bx + load_index status_table + mov status_table[bx],ax + clc +le_exit: + lahf ;load flags into ah + les di,dword ptr trans_buf ;es:di => transaction buffer + mov es:[di],ax ;move result to rpc buffer + ret +load_exe endp + +;BID_CHILD +; Given a filename in bid_name, initialize it under XLI. +; +; Upon Entry: +; ES:bid_name => pathname of the file to bid +; +; Upon Exit: +; AX = EXEC status +; +; Assume AX..SI are destroyed; DS,ES,SS,SP,BP,DI are preserved. +bid_child proc + push di + push ds ;save parent's state + push es + push bp + save_parent + mov cs:stk_seg,ss + mov cs:stk_offset,sp + + mov dx,bid_name + mov ax,es + mov ds,ax ;DS:DX = parm block + mov bx,data + mov es,bx + lea bx,exec_pblock ;ES:BX = Asciiz pathname + mov ax,FR_EXEC + int 21h + +; The following are external entry points accessible by the child. +biddbg: jmp tsr_done ; --- THE BIG 4 --- (not for child's use) + jmp c2p_handler ; --- THE BIG 4 --- for XCALL's + jmp c2p_terminate ; --- THE BIG 4 --- for child termination + +tsr_done: cli + mov ss,cs:stk_seg + mov sp,cs:stk_offset + sti + pop bp + pop es + pop ds + pop di + ret + +stk_seg dw 0 ;bootstrap parent's state after EXEC +stk_offset dw 0 ;from here + +bid_child endp + + subttl Code segment: Child->Parent Handler + page + +;C2P_HANDLER +; This routine is invoked from the child program bid in BID_CHILD. Upon +; entry we are executing in the child's environment. The relevant stack +; stack entries at this point are: +; SS:SP (top) -> IP ;child's far return address +; CS +; length ;child's length; for TSR +; PSP@ ;child's PSP@ +; //// ;(the rest of the stack) +; The first time called, set up the linkage such that we can get back +; to the routine via the xesc functionality. + +c2p_handler label near + resume_parent + load_index itself + cmp bh,EXE_TSR ;first call (performing TSR) + je c2_10 ; yes, jump + jmp normal ; no, normal call - rejoin xesc +c2_10: + load_index state_table + lea bx,state_table[bx] + mov es,[bx].st_ss + mov bp,[bx].st_sp ;ES:BP is child's SS:SP + mov ax,es:[bp].cs_psp ;get child's PSP off its stack + load_index load_table + mov load_table[bx],ax ;save it + push ds ;-----> DS set to child's PSP + mov ds,ax + mov ax,ds:fb_ptr ;get file block @ + mov cx,ds:fb_ptr+2 + mov dx,ds:env_ptr ;get env block @ (seg addr) + pop ds ;<----- + load_index fb_table + mov word ptr fb_table[bx],ax ;save it + mov word ptr fb_table+2[bx],cx + push es ;tempsave child's SS:SP on stack + push bp + mov bp,ax + mov es,cx ;ES:BP is file block @ + mov ax,es:[bp].fb_pb + mov cx,es:[bp].fb_pb+2 ;get parm block @ + load_index pb_table + mov word ptr pb_table[bx],ax ;save it + mov word ptr pb_table+2[bx],cx +; + test word ptr es:[bp].fb_flags,FB_SYSINT ;system callable? + jz c2_40 ; no, jump + mov ax,es:[bp].fb_sysint_addr + mov cx,es:[bp].fb_sysint_addr+2 ;cx:ax is entry point + mov bx,next_avail_sys ;bx = next avail location + inc next_avail_sys ;bump next avail location + shl bx,1 ;make index + shl bx,1 + mov word ptr sys_func+[bx],ax ;save location in table + mov word ptr sys_func+[bx+2],cx + +c2_40: + int 3 + test word ptr es:[bp].fb_flags,FB_KEEPENV + ;keep child's env block? + jnz c2_50 ;yes, jump + dos_fr FR_RELMEM,,,,,dx ;no, release it for child +c2_50: pop bp + pop es + mov dx,es:[bp].cs_len ;get child's length off its stack +; we're ready to TSR the child + dos_fr FR_TSR,,,dx +; we don't drop through ----------------------------------------- + + + subttl Code segment: Child termination + page + +;C2P_TERMINATE +; After the child has performed its wrapup, it calls this routine +; to deallocate its memory and make its spot in the load table available. +c2p_terminate label near + mov ax,data ;we needn't save child's context now + mov ds,ax + restore_parent + load_index load_table ;release the child + dos_fr FR_RELMEM,,,,,load_table[bx] + jc ct_err + load_index itself ;mark its spot as available + xor bh,bh + mov ax,bx + load_index status_table + mov status_table[bx],ax + jmp normal1 ;rejoin unload_exe +ct_err: mov bx,XLI_ERR_RELMEM + jmp xli_err_exit + + subttl Code segment: xesc + page + +;XESC +; This is the handler for the "%xesc" opcode. +; +; On entry: +; ES:DI => Communication Buffer set up by protected mode routine. +; +; +-----------------------------------------------+ +; | Routine name length (1 word) | +; | Routine name (above length) | +; | . | +; | . | +; | Number of Arguments (1 word) | +; | Type of Arg1 (1 word) | +; | Arg1 (type dependent) | +; | . | +; | . | +; | . | +; | Type of Argn (1 word) | +; | Argn (type dependent) | +; +-----------------------------------------------+ +; +; On exit: +; Communication buffer will contain return status, type, and value +; +; +-----------------------------------------------+ +; | Return Status (1 word) | +; | Return Value Type (1 word) | +; | Return Value (type dependent) | +; | . | +; | . | +; | . | +; +-----------------------------------------------+ +; +; Return Status will either be 0 for normal return, or -1 +; for a special service request. +; +; Return Value Type should be from 0 to N_RV (4) which are +; defined return types, or RV_ERR (10) which allows the +; external program to send back an error message. +; +; Note: Return status for xesc is actually returned in the transaction +; buffer at TRANSACTION_BUFFER[0]. +; Buffer definition for passing data back to protected mode +xesc_result struc +xesc_status dw ? +xesc_vtype dw ? +xesc_value dw ? +xesc_result ends + + +xesc proc near + mov return_sp,sp ;save stack in case errors + + mov ax,ES:[di] ;get string length + mov work_area.srch_slen,ax ;save length of string data + add di,2 + mov work_area.srch_sptr,di ;save address of string data + mov work_area.srch_sptr+2,es + add di,ax ;point past string + mov ax,word ptr es:[di] ;AX = number of args + mov work_info.xs_nargs,ax ;set up number args passed + add di,2 + + mov work_info.xs_pc,di ;and save in local area + mov work_info.xs_pc+2,es + +; Look for a match. + call table_search ;is there a match? + ;(sets active_exe if so) + jnc xesc_10 ;yes, jump + mov bx,XLI_ERR_NO_SUCH_NAME ;error: no such name loaded + jmp xesc_err_exit +xesc_10: mov dx,ax ;tempsave selector +; There was a match. +; Collect the info we'll need to guide us thru xesc call. + load_index fb_table + mov bp,word ptr fb_table[bx] + mov es,word ptr fb_table+2[bx] ;ES:BP is file block @ + + mov ax,es:[bp].fb_id ;get XLI ID + cmp ax,XLI_ID ;compare to our version + je xesc_15 ;if equal, continue + mov bx,XLI_ERR_BAD_VERSION ; else note out of sync + jmp xesc_err_exit +xesc_15: mov ax,es:[bp].fb_flags ;flags + mov work_info.xs_flags,ax + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @ + mov work_info.xs_pb_segment,es ;parm block's segment address + lea ax,es:[bp].pb_rv + mov work_info.xs_rvptr,ax + mov work_info.xs_rvptr+2,es ;return value's address + mov es:[bp].pb_rv,0 ;zero out return value + mov es:[bp].pb_rv+2,0 + mov es:[bp].pb_rv+4,0 + mov es:[bp].pb_rv+6,0 + mov es:[bp].pb_rvtype,SWI_TF ;set ret value's type to T/F + mov es:[bp].pb_ss,0 ;zero out special service + add ax,8 + mov work_info.xs_args,ax ;first arg's address + mov work_info.xs_args+2,es + mov work_info.xs_local,offset work_area ;work area address + mov work_info.xs_local+2,seg work_area +; Begin initializing child's parameter block. + mov es:[bp].pb_select,dx ;store selector into parm block + mov work_info.xs_select,dx + +; Move the xesc arguments to their places for the xesc call. + + mov cx,0 +xesc_20: cmp cx,work_info.xs_nargs ;any left? + je xesc_50 ;no, jump + push cx ;tempsave current arg# + mov bx,cx ;BX = current arg# + shl bx,1 ; make index into swap table + shl bx,1 + mov ax,work_info.xs_args ;get arg address + mov word ptr swap_table[bx].sw_offset,ax ;and save for later + mov si,work_info.xs_pc + mov es,work_info.xs_pc+2 ;ES:SI points to arg type + mov di,word ptr es:[si] + inc si + inc si ;ES:SI points to arg +; Dispatch on argument type + call cs:word ptr do_arg[di] ;handle one type of object + add work_info.xs_local,PAD_SIZE ;incr XLI-local ptr + ;(maintain alignment) + pop cx ;restore current arg# + inc cx + jmp xesc_20 +xesc_50: + call_child 1 ;Call the child. + +; We're back with a return value--unless it's a special service call. +normal: cld + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @ + cmp es:[bp].pb_ss,0 ;any special services? + je xesc_60 ;no, jump + + jmp ssr ;special service. This will + ;return from protected mode + ;to ssr_return before calling + ;the child again at xesc_50 +; Now we're really back with the return value +xesc_60: mov di,es:[bp].pb_rvtype + mov work_area.xs_rvtype,di ;return value's type + + cmp di,RV_ERR ;external-pgm error return? + jne xesc_65 ;no, jump + mov si,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:SI points to return value + ;(external-pgm error message) + shl di,1 ;return type to return + call do_strval ;build the string + jmp xesc_75 ;and return + +xesc_65: cmp di,N_RV ;return value out of range? + jb xesc_70 ;no, jump + mov bx,XLI_ERR_VALUE_BAD_TYPE + jmp xesc_err_exit +xesc_70: shl di,1 + mov si,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:SI point to return value + call cs:word ptr do_val[di] ;handle one type of return value +xesc_75: + mov sp,return_sp ;clean up stack and return + ret + +; This file's error exit processing. Reset the stack so that we return +; correctly. BX should be set with an error code before jumping here. +xli_err_exit: +xesc_err_exit: + les di,dword ptr trans_buf ;es:di => rpc buffer + mov es:[di],bx ;return status + mov sp,return_sp ;clean up stack and return + ret + + + subttl Code segment: Special Services + page + +; "Swap" special service +; On entry, ES:BP is parm block pointer. + +ssr label near + +; mov bx,es:[bp].pb_ss ;get dispatch number +; cmp bx,SS_SWAP +; je ssr_swap +; jmp ss_exit + +ssr_swap: + mov ax,es:[bp].pb_ss_args ;AX = arg# + test work_info.xs_flags,FB_NEAR ;near data? + jnz ssr_10 ; yes, jump +; far data + xor bx,bx ;BX = length (null) + mov cx,bx ;CX = offset (null) + mov dx,bx ;DX = segment(null) + jmp ss_15 +; near data +ssr_10: + mov bx,es:[bp].pb_ss_args+2 ;BX = length + mov cx,es:[bp].pb_ss_args+4 ;CX = destination offset + mov work_info.xs_dest,cx ; save for return trip + mov dx,work_info.xs_pb_segment ;DX = destination segment +ss_15: + + mov di,stack + mov es,di + xor di,di ;ES:DI => result buffer + + mov es:[di].xesc_status,-1 ;SSR request + mov es:[di].xesc_status+2,ax ;arg # + mov es:[di].xesc_status+4,bx ;length + mov es:[di].xesc_status+6,cx ;offset address + mov es:[di].xesc_status+8,dx ;segment address + mov sp,return_sp ;clean up stack + ret ;and return to protected mode + ;routine to copy the string + +ssr_return label near + mov return_sp,sp + les di,dword ptr trans_buf ;load rpc buffer + mov ax,es:[di]+2 ;get # args copied + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table[bx]+2 + mov es:[bp].pb_ss,0 ;Clear ss field for normal exit + mov bx,es:[bp].pb_ss_args ;Get arg# + mov es:[bp].pb_ss_args,ax ;Update # chars copied + shl bx,1 + shl bx,1 ;index into swap table + mov bp,word ptr swap_table[bx].sw_offset ;ES:BP =>arg's loc in parm block. + + test work_info.xs_flags,FB_NEAR ;near data? + jnz ssr_r05 ; yes, jump +; far data + push es ;tempsave + mov bx,stack + mov es,bx + xor di,di ;es:di => result buffer + mov ax,es:[di]+6 ;ax = offset of string + mov bx,es:[di]+8 ;bx = segment of string + pop es ;restore + mov word ptr es:[bp],ax ;put far @ in parm block + mov word ptr es:[bp+2],bx + jmp xesc_50 +; near data +ssr_r05: + mov ax,work_info.xs_dest + mov es:[bp],ax ;put near @ in parm block + jmp xesc_50 + + +;; Jump tables +; indexed by argument type (standard PCS type tag) +do_arg dw do_fixarg ;0=list (#f only) + dw do_fixarg ;1=fixnum + dw do_floarg ;2=flonum + dw do_bigarg ;3=bignum + dw do_fixarg ;4=symbol (#t only) + dw do_strarg ;5=string + dw do_errarg ;6 the rest we don't care about + dw do_errarg ;7 + dw do_errarg ;8 + dw do_errarg ;9 + dw do_errarg ;10 + dw do_errarg ;11 + dw do_errarg ;12 + dw do_errarg ;13 + dw do_errarg ;14 + dw do_errarg ;15 + +; indexed by value type (SW-INT return types) +do_val dw do_intval ;0=integer + dw do_TFval ;1=true/false + dw do_strval ;2=string + dw do_floval ;3=flonum + + +xesc endp + + subttl Code segment: Copy arguments into place for child + page + +; On entry to all the argument handler routines: +; BX = pointer to VM reg with page:offset of Scheme object + +do_floarg proc near + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_flo10 ;no, jump +; Set up destination address + ; near + mov cx,work_info.xs_args ;dest is in child + mov dx,work_info.xs_args+2 + mov work_info.xs_dest,cx + mov work_info.xs_dest+2,dx + jmp short do_flo20 + ; far +do_flo10: mov cx,work_info.xs_local ;dest is in XLI-local area + mov dx,work_info.xs_local+2 + mov work_info.xs_dest,cx + mov work_info.xs_dest+2,dx +; Copy the flonum data +do_flo20: + mov di,work_info.xs_dest + push ds ;tempsave DS around copy + push es + mov es,work_info.xs_dest+2 ;ES:DI points to dest + pop ds ;DS:SI is Scheme object @ + mov cx,8 + rep movsb + pop ds ;restore our DS + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_flo30 ;no, jump +; Copy pointer to data + ; near (no copy needed--data is in child's space) + mov cx,8 ;incr arg@ past copied data + jmp short do_flo32 + ; far (pointer in child points to data in XLI space) +do_flo30: sub di,8 ;back up dest @ + mov cx,di + mov dx,es + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to arg position + mov es:[bp],cx + mov es:[bp]+2,dx ;copy pointer there +; Increment arg pointer by an appropriate amount. + mov cx,4 ;incr arg@ past copied ptr +do_flo32: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_flo35 ;no, skip + mov cx,PAD_SIZE +do_flo35: add work_info.xs_args,cx + add work_info.xs_pc,10 ;update arg counter +do_flo40: ret +do_floarg endp + +do_bigarg proc near + mov ax,es:[si] ;move longint to regs + mov dx,es:[si]+2 + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_big20 ;no, jump + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + mov es:[bp],ax ;copy LSBy to child + mov cx,2 + test work_info.xs_flags,FB_INT ;is 16-bit integer flag on? + jz do_big15 ;no, jump + ; is the longint small enough for an int? + cmp dx,0 ;DX should be either + ;all 0's or all 1's + je do_big32 ;we can safely truncate + xor dx,0FFFFh ;complement DX + cmp dx,0 ;try again + je do_big32 ;we can safely truncate + mov bx,XLI_ERR_BIG_TO_16_BITS ;error: bignum too big + ;to become int + jmp xesc_err_exit +do_big15: mov es:[bp]+2,dx ;copy MSBy to child + mov cx,4 + jmp short do_big32 + ; far (pointer in child points to data in XLI-local space) +do_big20: +; Copy either the longint or a pointer to it. + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + mov es:[bp],ax ;copy to child + mov es:[bp]+2,dx + mov cx,4 ;incr arg@ past longint + ;or pointer to longint +; Increment arg pointer by an appropriate amount. +do_big32: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_big35 ;no, skip + mov cx,PAD_SIZE +do_big35: add work_info.xs_args,cx + add work_info.xs_pc,6 ;update arg counter +do_big40: ret +do_bigarg endp + +do_fixarg proc near + mov ax,es:[si] ;move longint to regs + mov dx,es:[si]+2 + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_fix20 ;no, jump + ; near (copy int to child's space) + mov es:[bp],ax ;copy int to child + mov cx,2 ;incr arg@ past int + test work_info.xs_flags,FB_INT ;is 16-bit integer flag on? + jnz do_fix30 ;yes, jump + mov es:[bp]+2,dx ;no, copy high order 16 bits + mov cx,4 ;incr arg@ past longint + jmp short do_fix30 + ; far (pointer in child points to data in XLI-local space) +do_fix20: mov bx,work_info.xs_local + mov [bx],ax + mov [bx]+2,dx + mov ax,work_info.xs_local ;move far ptr to int + ;or longint to child + mov cx,work_info.xs_local+2 + mov es:[bp],ax + mov es:[bp]+2,cx + mov cx,4 ;incr arg@ past ptr to int +; Increment arg pointer by an appropriate amount +do_fix30: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_fix35 ;no, skip + mov cx,PAD_SIZE +do_fix35: add work_info.xs_args,cx + add work_info.xs_pc,6 ;update arg counter +do_fix40: ret +do_fixarg endp + +do_xxerr: jmp do_errarg ;conditional jumps + ;are too short +do_strarg proc near + add work_info.xs_pc,4 + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP is arg @ + mov word ptr es:[bp],0 + xor cx,cx + test work_info.xs_flags,FB_NEAR ;Near data? + jnz do_str50 + mov cx,2 + mov word ptr es:[bp+2],0 +do_str50: + add cx,2 + test work_info.xs_flags,FB_PAD ;padding on? + jz do_str65 + mov cx,PAD_SIZE +do_str65: add work_info.xs_args,cx + ret +do_strarg endp + +do_errarg proc near + mov bx,XLI_ERR_ARGN_BAD_TYPE + jmp xesc_err_exit +do_errarg endp + + + subttl Code segment: Copy return value back into Scheme + page + +; On entry to all the value handler routines: +; ES:SI = pointer to return value +; DI = return type +; + +do_floval proc near + push ds ;save for this routine + mov cx,result_buffer + xor dx,dx ;buffer for return values + + test work_info.xs_flags,FB_NEAR ;is near flag on? + mov ax,es + mov ds,ax ;ds now addresses result + jnz do_flv10 ;yes, jump + ; far + mov ax,[si] ;get ptr to number + mov bx,[si]+2 + mov si,ax + mov ds,bx ;DS:SI points to number + ; near +do_flv10: + mov ax,di ;save return type + mov es,cx + mov di,dx ;ES:DI points to result buffer + mov es:[di].xesc_status,0 ; set return status + mov es:[di].xesc_vtype,ax ; set return type + add di,xesc_value ; now address value field + cld + mov cx,8 + rep movsb ; move float to buffer + pop ds + ret +do_floval endp + +do_TFval proc near + mov ax,es:[si] ;get value + or ax,es:[si]+2 ;all bytes must = 0 to be nil + or ax,es:[si]+4 + or ax,es:[si]+6 +; + mov es,result_buffer + xor si,si ;ES:SI points to result buffer + mov es:[si].xesc_status,0 ; set return status + mov es:[si].xesc_vtype,di ; set return type + mov es:[si].xesc_value,ax ; set return value + ret +do_TFval endp + +do_intval proc near + test work_info.xs_flags,FB_NEAR ;near flag on? + jnz do_int10 ;yes, jump + ; far + mov ax,es:[si] ;get ptr to number + mov dx,es:[si]+2 + mov si,ax + mov es,dx ;ES:BP points to number + ; near +do_int10: mov ax,es:[si] ;get number + mov dx,es:[si]+2 + test work_info.xs_flags,FB_INT ;16-bit integer flag on? + jz do_int20 ;no, jump + cwd ;yes, propagate sign +do_int20: + mov es,result_buffer + xor si,si ;ES:SI points to result buffer + mov es:[si].xesc_status,0 ; set return status + mov es:[si].xesc_vtype,di ; set return type + mov es:[si].xesc_value,ax ; set return value + mov es:[si].xesc_value+2,dx + ret +do_intval endp + +do_strval proc near + mov ax,es:[si] + test work_info.xs_flags,FB_NEAR ;is near flag on? + jz do_stv10 ; no, jump + mov dx,work_info.xs_pb_segment ;DX:AX = string ptr + mov cx,es:[si]+2 ;CX = string length + jmp short do_stv15 +do_stv10: mov dx,es:[si]+2 ;DX:AX = string ptr + mov cx,es:[si]+4 ;get string length +do_stv15: mov bx,16380 ;BX is max string length + cmp cx,bx ;is CX short enough + jbe do_stv20 ;yes, jump + mov cx,bx ;no, truncate at max +; DX:AX = string ptr, CX = string length, DI = return type +do_stv20: + mov es,result_buffer + xor si,si ;ES:SI points to result buffer + mov es:[si].xesc_status,0 ; return status + mov es:[si].xesc_vtype,di ; return type + mov es:[si].xesc_value,cx ; length + mov es:[si].xesc_value+2,ax ; pass string pointer back + mov es:[si].xesc_value+4,dx + ret +do_strval endp + +do_errval proc near + mov bx,XLI_ERR_VALUE_BAD_TYPE + jmp xesc_err_exit +do_errval endp + + + subttl Code segment: unload_exe + page + + +; Given active_exe, release it from memory and make its spot available again. +unload_exe proc near + load_index state_table + mov es,word ptr state_table[bx].st_ss + mov bp,word ptr state_table[bx].st_sp ;ES:BP is child's SS:SP + mov es:[bp].cs_psp,0 ;set PSP@ to 0, our signal + ;to child to wrap things up + call_child 2 ;call child one last time +normal1: ret +unload_exe endp + + + subttl Code segment: unload_all + page + +; This routine is called during PCS termination. It notifies each +; child to do any wrapup, then the child will do its final call to us, +; where we release it. + +unload_all proc near + mov active_exe,0 +ua_10: cmp active_exe,N_EXE ;looked at all entries? + je ua_exit ;yes, jump + load_index status_table + mov bx,status_table[bx] + cmp bh,EXE_NONE ;is slot empty? + jne ua_20 ;no, jump +ua_15: inc active_exe ;incr to next entry + jmp ua_10 +ua_20: call unload_exe ;deallocate entry + jmp ua_15 +ua_exit: ret +unload_all endp + + subttl Code segment: table_search + page + +; We need to find a matching string. From it we'll know +; which child has it and what value it maps to. +; On entrance: +; work_area.srch_sptr is the seg:offset of the Scheme string (data proper) +; work_area.slen is the string's length +; On exit: +; if success: AX = selector value +; active_exe = xxnnh, where n is the child +; carry clear +; if fail: carry set +; AX..DI,ES,BP are destroyed. + +table_search proc near + cld ;to be safe + mov work_area.srch_exe,0 +ts_10: cmp work_area.srch_exe,N_EXE ;looked at them all? + jne ts_15 ;no, jump +; No child had a match. Return with carry set. + stc + jmp ts_exit +ts_15: mov bx,work_area.srch_exe + mov active_exe,bx + load_index status_table + mov ax,status_table[bx] + cmp ah,0 ;is this an open spot? + jne ts_20 ;no, jump +ts_next: inc work_area.srch_exe ;increment to next spot + jmp short ts_10 +; We have a loaded file. Figure out where its lookup table is. +ts_20: load_index fb_table + mov bp,word ptr fb_table[bx] + mov es,word ptr fb_table+2[bx] ;ES:BP is file block @ + mov ax,es:[bp].fb_lut + mov dx,es:[bp].fb_lut+2 + mov di,ax + mov es,dx ;ES:DI is lookup table @ + mov ah,0 ;AH will be selector value + mov al,'/' ;AL is name delimiter +; Find the next name in the lookup table. +ts_30: cmp byte ptr es:[di],al ;looking at last delimiter? + je ts_next ;yes, jump + mov si,di ;SI points at current name + mov cx,0FFh + repne scasb ;look for name delimiter + jcxz ts_next ;jump, should've found it by now + mov dx,di ;DI, DX point at next name + mov cx,di + sub cx,si + dec cx ;CX is length of name in table + cmp work_area.srch_slen,cx ;are lengths equal? + jne ts_40 ;no, jump +; We matched lengths. See if the strings themselves match. + mov di,si ;get current name @ back in DI + push ds ;tempsave our DS + mov si,work_area.srch_sptr + mov ds,work_area.srch_sptr+2 ;DS:SI is Scheme string @ + repe cmpsb + pop ds ;restore our DS + je ts_match ;jump if match +; The current table name didn't match. +ts_40: inc ah ;increment selector value + mov di,dx ;restore next name @ to DI + jmp ts_30 +; We matched. Active_exe has child#, replace it with the corr. status value. +; Calculate the selector value (0-based) of the name and return it in AX. +; Clear carry. +ts_match: mov al,ah + xor ah,ah + load_index status_table + mov bx,status_table[bx] + mov active_exe,bx + clc +ts_exit: ret +table_search endp + + subttl Code segment: find_open_spot + page + +; Find an open spot in the load_table. Clear carry and set the LSBy of +; active_exe with the child# if we succeeded, else set carry. +find_open_spot proc near + push bx + push cx + mov cx,N_EXE + mov bx,0 +fi_loop: cmp byte ptr status_table[bx]+1,EXE_NONE + je fi_found + inc bx + inc bx + dec cx + cmp cx,0 + jne fi_loop + stc ;set carry if no available entries + jmp short fi_exit +fi_found: mov bx,N_EXE + sub bx,cx + mov active_exe,bx + clc ;an open entry: clear carry, set active_exe +fi_exit: pop cx + pop bx + ret +find_open_spot endp + +prog ends + + end rpc_startup + \ No newline at end of file diff --git a/regschem.h b/regschem.h new file mode 100644 index 0000000..aae2713 --- /dev/null +++ b/regschem.h @@ -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) + \ No newline at end of file diff --git a/rpc.equ b/rpc.equ new file mode 100644 index 0000000..9cc63d5 --- /dev/null +++ b/rpc.equ @@ -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 + + +  \ No newline at end of file diff --git a/saprop.asm b/saprop.asm new file mode 100644 index 0000000..10c862c --- /dev/null +++ b/saprop.asm @@ -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 + \ No newline at end of file diff --git a/sasm.mac b/sasm.mac new file mode 100644 index 0000000..3359d59 --- /dev/null +++ b/sasm.mac @@ -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 + + \ No newline at end of file diff --git a/sbid.asm b/sbid.asm new file mode 100644 index 0000000..0fb576d --- /dev/null +++ b/sbid.asm @@ -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 + \ No newline at end of file diff --git a/sbigmath.asm b/sbigmath.asm new file mode 100644 index 0000000..d0f94cc --- /dev/null +++ b/sbigmath.asm @@ -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' + JE M3 ; branch if output file name + ENDIF +M10: CMP AL,'=' + JE M4 ; branch if stack size + endif + CMP AL,' ' + JE M11 ; branch if white space + CMP AL,TAB + JNE M12 ; branch if normal arg +M11: DEC CX + JG M1 + XOR CX,CX +M12: JMP M5 ; branch if no args found + ife scheme ; PCS doesn't scan for special args + IF MSDOS EQ 1 +; +; Get input file name +; +M2: MOV DI,OFFSET DGROUP:_INAME + JMP M31 +; +; Get output file name +; +M3: MOV DI,OFFSET DGROUP:_ONAME +; +; Save file name in data area +; +M31: XOR AH,AH +M32: DEC CX + JZ M33 + INC SI + MOV AL,ES:[SI] + CMP AL,' ' + JZ M33 + CMP AL,TAB + JZ M33 + MOV DS:[DI],AL + INC DI + INC AH + CMP AH,32 + JE M34 + JMP M32 +M33: MOV BYTE PTR DS:[DI],0 + JMP M11 +M34: MOV DX,OFFSET DGROUP:NAMERR + JMP NEAR PTR XCABT + ENDIF +; +; Get stack and heap sizes from command line +; +M4: CALL GETNUM ; get stack size + JC M47 ; branch if error + TEST BX,BX + JZ M42A ; bypass if size is 0 + CMP AL,'K' + JE M41 + CMP AL,'k' + JNE M42 ; branch if not kilobytes +M41: TEST BX,0FFC0H + JNZ M47 ; error if size > 63 + XCHG BH,BL ; multiply by 1024 + SHL BH,1 + SHL BH,1 + DEC CX ; advance to next character + JZ M42 + INC SI + MOV AL,ES:[SI] +M42: MOV _STACK,BX ; save stack size +M42A: TEST CX,CX + JZ M5 ; branch if end of command line + CMP AL,' ' + JE M46 ; loop if blank + CMP AL,TAB + JE M46 ; loop if tab + CMP AL,'/' + JNE M47 ; branch if not slash + CALL GETNUM ; get heap size + JC M47 ; branch if error + XOR DX,DX ; long result is in DX,BX + TEST BX,BX + JZ M45 ; branch if size is 0 + CMP AL,'K' + JE M43 + CMP AL,'k' + JNE M44 ; branch if not kilobytes +M43: XCHG BH,BL ; multiply by 1024 + ROL BX,1 + ROL BX,1 + MOV DX,BX + AND BX,0FC00H + AND DX,3FFH + DEC CX ; advance to next character + JZ M44 + INC SI + MOV AL,ES:[SI] +M44: MOV WORD PTR _MNEED,BX ; save heap size + MOV WORD PTR _MNEED+2,DX +M45: TEST CX,CX + JZ M5 ; branch if end of command line + CMP AL,' ' + JE M46 ; loop if blank + CMP AL,TAB + JNE M47 ; error if not tab +M46: JMP M11 +M47: MOV DX,OFFSET DGROUP:STKERR ; abort if stack/heap size error + JMP NEAR PTR XCABT + endif ;matches IFE near M12: +; +; Set up the stack +; + ife scheme ; PCS ignores DOS environment strings + IF LDATA EQ 0 +M5: MOV AX,_XSIZE ; reserve space for environment + ADD AX,15 + AND AX,0FFFEH + ELSE +M5: XOR AX,AX + ENDIF + else +M5: xor ax,ax + endif + + IFDEF PROMEM ;;; Protected Mode + mov bx,_top ; bx = top of stack + jmp M54a +M54: MOV DX,OFFSET DGROUP:MEMERR2 ; abort if error in releasing memory + JMP NEAR PTR XCABT +M54a: + ELSE + MOV BX,_STACK ; get stack size + SHR BX,1 ; make size even + ADD BX,BX + CMP BX,STKMIN + JA M51 + MOV BX,STKMIN ; use default if too small + MOV _STACK,BX +M51: ADD BX,AX ; add environment size + JC M54 ; abort if overflow + MOV DX,ES:2 ; compute available paragraphs + if scheme + mov _paras,dx ; save no. paragraphs for Scheme + endif + MOV AX,SS + SUB DX,AX + TEST DX,0F000H + JNZ M52 ; branch if greater than 64Kbytes + SHL DX,1 ; convert to bytes + SHL DX,1 + SHL DX,1 + SHL DX,1 + JMP M53 +M52: MOV DX,0FFF0H ; use largest value + IF LDATA +M53: CMP DX,BX ; check if stack will fit + JA M55 + ELSE +M53: CMP DX,BX ; check if stack will fit + JB M54 + ADD BX,_BASE ; adjust S/P model for statics + JNC M55 + ENDIF +M54: MOV DX,OFFSET DGROUP:MEMERR2 ; abort if error in releasing memory + JMP NEAR PTR XCABT +M55: CLI + MOV _TOP,BX ; set top-of-stack + MOV SP,BX ; set stack pointer + IF LDATA EQ 0 + MOV AX,DS + MOV SS,AX + ENDIF + MOV _SS,SS + STI + ENDIF ; IFDEF PROMEM + +; +; Set up memory allocation pointers +; + PUSH CX ; save command byte count + + IFDEF PROMEM ;;; Protected Mode + ; Assume small data model + MOV AX,SS ; ax=stack segment + MOV _MBASE+2,AX ; _mbase = top of stack + mov _mbase, bx ; + MOV _MNEXT+2,AX ; _mnext = _mbase + mov _mnext, bx ; + mov bx, 0fff0h ; Protected mode has a full 64K + sub bx, _top ; subtract out top of stack + MOV _MSIZE,BX ; _msize = size of heap pool + xor ax, ax + ELSE + ADD BX,15 ; compute mem pool base segment number + JC M54 + MOV CL,4 + SHR BX,CL + MOV AX,SS + ADD AX,BX + MOV _MBASE+2,AX + MOV _MNEXT+2,AX + MOV BX,ES:2 ; get top segment number + SUB BX,AX ; compute memory pool size + JBE M54 ; branch if insufficient memory + MOV CL,4 ; compute number of bytes + ROL BX,CL + MOV AX,BX + AND AX,15 + AND BX,0FFF0H + MOV _MSIZE,BX + ENDIF + + MOV _MSIZE+2,AX + + PUSH ES ; reset memory pool + PUSH SI + CALL RBRK + POP SI + POP ES + OR AX,AX + JNZ M54 ; branch if not enough memory + + if scheme + IFNDEF PROMEM ;;; Protected Mode - IGNORE + push si + call allmem ; allocate the rest of the data segment + ; to C's heap (small model only); + ; later, in "initmem", PCS will get the + ; rest of MSDOS's memory for itself + pop si + or ax,ax + jnz m54 + ENDIF + endif + + POP DX ; restore command line length +; +; Put return address at top of stack +; + IF MSDOS EQ 1 + PUSH ES ; return is to 1st word of prog prefix + XOR AX,AX + PUSH AX + MOV BP,SP ; BP contains stack linkage + ENDIF +; +; copy command line to stack +; + MOV CX,DX ; get residual command line length + SUB SP,CX ; allocate stack space + DEC SP + MOV DI,SP + MOV DX,SP ; save pointer to end of command + ADD DX,CX + JCXZ M71 ; skip if no bytes to move + PUSH DS ; move them + PUSH ES + POP DS + PUSH SS + POP ES + CLD + REP MOVSB + POP DS +M71: MOV BYTE PTR SS:[DI],0 ; append null byte + MOV WORD PTR _ARG,SP ; save arg array pointer + MOV WORD PTR _ARG+2,SS +; +; Move environment to stack for small data models +; + ife scheme ; PCS ignores DOS environment strings + IF LDATA EQ 0 + MOV CX,_XSIZE ; get extended env size + JCXZ M72 ; branch if no environment + SUB SP,CX ; allocate stack space + MOV DI,SP + PUSH DS ; save important regs + PUSH ES + PUSH SI + PUSH SS ; set stack as destination seg + POP ES + MOV SI,WORD PTR _ENV+2 + MOV WORD PTR _ENV,DI ; save relocated env pointer + MOV WORD PTR _ENV+2,SS + MOV DS,SI ; set env as source + XOR SI,SI + CLD ; move environment + REP MOVSB + POP SI ; restore regs and continue + POP ES + POP DS + ENDIF + endif +; +; Build argument vector +; + ife scheme ; PCS parses its own command line +M72: AND SP,0FFFEH ; make stack pointer even + MOV SI,DX ; prepare to scan command backwards + XOR CX,CX + PUSH CX ; push null terminator for argv + IF LDATA + PUSH CX + ENDIF + MOV BX,SP ; save this null byte address +M8: CMP SI,WORD PTR _ARG ; skip trailing white space + JNE M80 + JMP M83 +M80: DEC SI + CMP BYTE PTR SS:[SI],' ' + JE M8 + CMP BYTE PTR SS:[SI],TAB + JE M8 + MOV BYTE PTR SS:[SI+1],0 ; install null terminator byte + MOV AL,0 ; indicate white space scan + CMP BYTE PTR SS:[SI],'"' + JNE M81 ; branch if not quoted arg + CMP SI,WORD PTR _ARG + JE M81 + CMP BYTE PTR SS:[SI-1],'\' + JE M810 ; branch if \" + MOV AL,'"' ; indicate quote scan + MOV BYTE PTR SS:[SI],0 ; put null in place of quote +M81: CMP SI,WORD PTR _ARG + JE M82 ; branch if no more chars + DEC SI ; position to next char + CMP BYTE PTR SS:[SI],'"' + JNE M81C ; branch if not quote + CMP SI,WORD PTR _ARG + JE M81C ; branch if no more chars + CMP BYTE PTR SS:[SI-1],'\' + JNE M81C ; branch if not \" +M810: PUSH SI ; squish args to remove \ +M81A: DEC SI + CMP SI,WORD PTR _ARG + JE M81B + MOV AH,SS:[SI-1] + MOV SS:[SI],AH + JMP M81A +M81B: INC WORD PTR _ARG + POP SI + JMP M81D +M81C: OR AL,AL + JNZ M82A ; branch if not white space scan +M81D: CMP BYTE PTR SS:[SI],' ' ; find next white space + JE M81E + CMP BYTE PTR SS:[SI],TAB + JNE M81 +M81E: INC SI ; position to start of arg + IF LDATA +M82: PUSH SS ; add arg pointer to vector + PUSH SI + ELSE +M82: PUSH SI ; put arg pointer into argv + ENDIF + INC CX ; bump arg count + JMP M8 ; loop till all args done +M82A: CMP BYTE PTR SS:[SI],'"' ; come here to find starting quote + JNE M81 ; branch if not quote + MOV BYTE PTR SS:[SI],' ' ; replace it with white space + JMP M81E ; go save arg pointer +; +; Construct argv[0] +; +M83: CMP _DOS,2 + JLE M84 + MOV AX,WORD PTR _ENV ; use env trailer for DOS 3 + ADD AX,_ESIZE + INC AX + INC AX + IF LDATA + PUSH [WORD PTR _ENV+2] + ENDIF + PUSH AX + JMP M85 + IF LDATA +M84: PUSH SS ; use null byte for DOS 2 + PUSH BX + ELSE +M84: PUSH BX ; use null byte for DOS 2 + ENDIF +; +; Save argv information +; +M85: INC CX ; save arg count + MOV _ARGC,CX + IF LDATA + MOV WORD PTR _ARGV,SP ; save arg vector pointer + MOV WORD PTR _ARGV+2,SS + ELSE + MOV _ARGV,SP ; save arg vector pointer + ENDIF + + else ; PCS parses its own command line + +; ------------------------------------------------- +; The PCS command line parser +; ------------------------------------------------- + +; The PCS command line can look as follows: +; +; PCS (... ...) atom atom (... ...) "string" atom ... +; +; which parses into PCS-INITIAL-ARGUMENTS as: +; +; ( "(... ...)" "atom" "atom" "(... ...)" "\"string\"" "atom" ... ) +; +; Each command line argument is either an atom, list, or string. +; Each is treated as one argument for the argv vector, and each is +; converted to a string which becomes an element of PCS-INITIAL-ARGUMENTS. +; +; The command line parser is not a Scheme reader. It looks for blank-separated +; tokens, where a token can start with a ( and end with the matching ), +; start and end with a ", or just be a sequence of nonblanks. Backslashed +; delimiters are skipped over as you'd expect. We don't bother with | since +; that is a special character to DOS. The blanks between tokens are important +; since the parser replaces them with nulls to get things set up for C's +; argv vector, so situations like ...)(... won't be parsed correctly. +; The parser is implemented as a finite state automaton (FSA). +; +; The first command line argument has special meaning but that is +; handled in "smain.c". +; + +; On entry to this section: +; ES = SS (but we don't care) +; SP = ptr to start of cmdline +; DX = ptr to cmdline eos (cmdline on stack with eos at its end) + +M72: + push DS ; ES <- DS + pop ES + xor AX,AX ; AH is state, AL is current char + push AX ; push 0 at front of cmdline + ; (we're going to parse backwards) + and SP,0FFFEH ; make SP even + mov SI,DX ; SI is index into cmdline + xor DX,DX ; DH is paren counter, DL is argc + cld +M72loop: dec SI ; get the next char from cmdline + cmp byte ptr SS:[SI-1],'\' ; is it singly escaped? + jne M72a ; no, jump + dec SI ; yes, back up to escape char +M72a: mov AL,SS:[SI] + mov CX,scan_size ; look it up in char table + mov DI,offset scan_table + repne scasb ; put into CX the "char class" for + ; indexing into state table + mov AL,bytes_per_state ; do 2-D subscript into state table + mul AH ; ... row + shl CX,1 ; ... col + add AX,CX + mov BX,AX ; (BH=0 since subscript small enough) + mov AH,state[BX] ; get next state + mov BL,state+1[BX] ; do action routine + add BX,offset actions + jmp BX + +actions label near ; start action routines ----------> +ar_out2: inc SI ; 1 char past token, back up + push SI ; push next argv + dec SI + inc DL ; incr argc +ar_skip: mov byte ptr SS:[SI],0 ; output a null char +ar_decr: jmp short M72loop +ar_lpar: dec DH ; decr paren count + js ar_err ; wrong paren to start with + jnz short M72loop ; on an inner paren, keep looking + mov AH,0 ; override state in table +ar_out1: push SI ; matched delimiter, push next argv + inc DL ; incr argc + jmp short M72loop +ar_rpar: inc DH ; incr paren count + jmp short M72loop +ar_err: mov DX,offset dgroup:parserr ; abort on error in cmdline parsing + jmp near ptr XCABT +ar_out_end: inc SI ; 1 char past token, back up + push SI ; push next argv + dec SI + inc DL ; incr argc +ar_end: ; end action routines <---------- + +continue: xor AX,AX ; argv[0] = \0 + push AX + inc DL ; incr argc + mov _argv,SP ; save address of argv + mov DH,0 + push DX + mov _argc,DX ; save argc + + endif + +; +; Build environment vector +; + ife scheme ; PCS ignores DOS environment strings + XOR AX,AX ; push null terminating pointer + PUSH AX + IF LDATA + PUSH AX + ENDIF + MOV AX,_ENVC ; allocate stack space for vector + ADD AX,AX + JZ M87 ; branch if null environment + SUB SP,AX + IF LDATA + SUB SP,AX + ENDIF + MOV SI,SP ; scan environment + LES DI,_ENV + XOR AX,AX + MOV CX,7FFFH + MOV DX,_ENVC + CLD +M86: MOV SS:[SI],DI + ADD SI,2 + IF LDATA + MOV SS:[SI],ES + ADD SI,2 + ENDIF + DEC DX + JLE M87 + REPNE SCASB + JMP M86 +M87: MOV WORD PTR environ,sp + IF LDATA + MOV WORD PTR environ+2,SS + ENDIF + endif +; +; initialize 8087 numeric data processor +; + IFNDEF PROMEM ;;; Protected Mode - IGNORE + FNINIT ; reset + FNSTSW _NDPSW ; get status + MOV AX,100 ; this is just for delay + MOV DX,AX + IMUL DX + TEST _NDPSW,0B8BFH ; 8087 will reset all these + JNZ M9 + INC _NDP ; indicate ndp present + ENDIF +; +; set up args for _main and call it +; +M9: MOV _SP,SP ; save stack pointer reset value + PUSH DS ; make ES same as DS + POP ES + CALL _MAIN ; call C main + IF MSDOS EQ 1 + CMP _DOS,2 + JL M91 ; branch if DOS 1 + ENDIF + MOV AX,4C00H ; exit with return code of 0 + INT 21H + IF MSDOS EQ 1 +M91: MOV SP,BP ;restore ptr to far return + RET ;return to MS-DOS + ENDIF +;** +; +; name GETNUM -- get a number from the command line +; +; description This function is used internally by the start-up routine +; while processing the command line. +; +;** + ife scheme +GETNUM PROC NEAR + XOR BX,BX ; reset accumulator +NUM1: DEC CX ; advance to next character + JZ NUM3 ; branch if end of command line + INC SI + MOV AL,ES:[SI] + CMP AL,'0' + JL NUM3 ; return if not decimal digit + CMP AL,'9' + JG NUM3 ; return if not decimal digit + SUB AL,'0' ; multiply accumulator by 10 + ADD BX,BX + JC NUM2 + MOV DX,BX + ADD BX,BX + JC NUM2 + ADD BX,BX + JC NUM2 + ADD BX,DX + JC NUM2 + XOR AH,AH ; add this digit + ADD BX,AX + JNC NUM1 ; loop till done +NUM2: RET +NUM3: CLC ; clear carry to indicate no error + RET +GETNUM ENDP + endif + +;** +; +; name XCABT -- Ignominious abort +; +; description This area is entered by direct jump with a message +; pointer in DS:DX. It sends the message to the +; console via DOS function 9 and then aborts. +; + ENTRY XCABT + MOV AH,9 ; print error message + INT 21H + MOV ES,_PSP+2 + IF MSDOS EQ 1 + CMP _DOS,2 + JL A1 + ENDIF + MOV AX,4C01H + INT 21H + IF MSDOS EQ 1 +A1: PUSH ES + XOR AX,AX + PUSH AX + RET + ENDIF + + if scheme +; +; Scheme wrapup - the C fn "exit" calls "_exit" which calls this hook routine +; + public xcexit +DOS equ 21h ; MSDOS function request interrupt +xcexit proc near + + mov bp,sp ; don't lose our return address to _exit + + IFDEF EXPMEM + call rlsexp ; Release Expanded Memory (if any) + ENDIF + + call xli_term ; release all external programs + ; allocated under XLI + IFNDEF PROMEM + push ES ; return Scheme heap to DOS + mov AH,49h + mov ES,first_dos + int DOS + pop ES + jnc MA + MOV DX,OFFSET DGROUP:MEMERR2 ; abort if error in releasing memory + JMP NEAR PTR XCABT + ENDIF +MA: call rsttimer ; Reset the timer interrupt, if necessary + call unfixint ; Restore the keyboard "patch" (MWH2) + call zcuron ; Turn cursor back on + mov AX,15 ; Load character attribute = white,enable + push AX + mov AX,80 ; 80 Columns + push AX + mov AX,25 ; 25 Rows + push AX + xor AX,AX ; Origin at 0,0 + push AX + push AX + call zclear ; Clear the screen + xor AX,AX + push AX + push AX + inc cur_off ; keep cursor off for EGA modes + call zputcur ; Put cursor at 0,0 + mov sp,bp ; reestablish the return address to _exit + ret +xcexit endp + + endif + +CXINIT ENDP + + + IFDEF PROMEM ;;; Protected Mode + +;;; Reset heap break point (unix lingo) +;;; +;;; Set _mbase = _mnext = DS:_top +;;; Set _pool = 0:0, _melt = 0:0 +public rbrk +RBRK PROC NEAR + push bp + mov bp,sp + ; + ; set up memory allocation pointers + ; + mov bx, _top + add bx, 0fh ; round up to para + and bx, 0fff0h + mov _tsize, bx ; total size in paras + + mov ax,ds + mov _mbase+2,ax ; long ptr to heap base + mov _mbase, bx + mov _mnext+2,ax ; long ptr to heap top + mov _mnext, bx + + + xor ax,ax + mov [_msize+2],ax ; number of bytes left in pool + mov _msize, ax + +; Clear the 2nd level pool + mov [_melt],ax + mov [_pool],ax + mov [_melt+02],ax + mov [_pool+02],ax + pop bp + ret +RBRK ENDP + +; + +public lsbrk +lsbrk PROC NEAR + push bp + mov bp,sp + mov cx,[bp+6] ; requested size (high) + mov dx,[bp+4] ; requested size (low) + or cx, cx + jnz lsbrk_err1 + mov cx, 0FFF0h + sub cx, _mnext ; available bytes + cmp cx, dx + jb lsbrk_err1 + mov ax, _mnext ; next location in pool + add _mnext, dx ; bump by requested amount + mov bx, ax + pop bp + ret + +lsbrk_err1: + xor ax,ax + mov bx, ax + pop bp + ret +lsbrk ENDP + + +COMMENT % +;; _RBRK (int desire) +;; desire is initial heap in paras +;; return 0 if OK, ffff otherwise +;; +public _rbrk +;;extrn _model:word +_rbrk proc near + push bp + mov bp,sp + push es +;mov word ptr [_oserr],_model + + mov bx, 0 ;; what is really needed here? 128K? + mov [_tsize],bx ;; really total size with heap + + mov ax,[_mbase] ;; reset heap allocator ptrs + mov [_mnext],ax + mov ax,[_mbase+02] + mov [_mnext+02] ,ax + xor ax,ax + pop es + pop bp + ret +_rbrk_error1: + mov [_oserr],ax +_rbrk_error: + mov ax,0ffffh + pop es + pop bp + ret +_rbrk endp +% + ENDIF +;** +; +; Dummy segment to establish top of program for small program models +; + IF S8086 + IF COM +TAIL SEGMENT WORD 'PROG' + DW -1 +TAIL ENDS + ENDIF + ENDIF + + IF S8086 +PROG ENDS + ENDIF + IF D8086 +CODE ENDS + ENDIF + IF P8086 +_CODE ENDS +OLDCODE SEGMENT BYTE ; This catches Version 2 code + DW 0CACAH +OLDCODE ENDS + ENDIF + IF L8086 +_PROG ENDS +OLDPROG SEGMENT BYTE ; This catches Version 2 code + DW 0CACAH +OLDPROG ENDS + ENDIF + PAGE +;** +; +; DGROUP includes the segments named DATA, UDATA, and XSTACK. The startup +; routine initializes DS to point to this group, and DS must then be pre- +; served throughout the program. The segments within DGROUP are defined +; as follows: +; +; DATA => Contains all static (local and global) initialized items. +; UDATA => Contains all static (local and global) uninitialized items. +; XSTACK => Stack for the startup routine. +; +; During the startup routine, the initial stack (XSTACK) is replaced with +; one that has the correct size for program execution. This size is +; determined by examining the command line and the _STACK global item. Then +; for the S and P memory models, the stack is set up relative to DGROUP (i.e. +; stack items can addressed via DS). For the D and L models, the stack +; segment stands alone and can be up to 64K bytes. +; +; The heap (i.e. the space used by the memory allocator) resides above the +; stack and is also initialized by the startup routine. Any space not +; immediately needed for the heap (as defined by _MNEED) is returned to DOS. +; +; At the end of the startup routine, memory is organized in the following +; sequence: +; +; -- code -- +; -- DATA -- +; -- UDATA -- +; -- stack -- +; -- heap -- +; +; FOR PROPER OPERATION OF THE STANDARD MEMORY ALLOCATOR, THIS SEQUENCE IS +; EXTREMELY IMPORTANT. IF YOU TAMPER WITH THE STARTUP ROUTINE OR INTRODUCE +; SEGMENTS AND CLASSES THAT DO NOT FOLLOW LATTICE CONVENTIONS, CHECK THE +; LOAD MAP CAREFULLY. +; +;** + + +;** +; +; Initialized data +; +DATA SEGMENT PARA PUBLIC 'DATA' + EXTRN _STACK:WORD + EXTRN _MNEED:DWORD + + IFDEF PROMEM ;;; Protected Mode + EXTRN _POOL:WORD + EXTRN _MELT:WORD + ENDIF + + PUBLIC _MODEL,_VER,_TOP,_BASE,_PSP,_MBASE,_MNEXT,_MSIZE,_DSIZE,_PSIZE + PUBLIC _ENV,_DOS,_TSIZE,_ESIZE,_XSIZE,_SS,_SP,_NDP,_NDPSW,_NDPCW + PUBLIC _FPA,_FPERR,_OSERR,_SIGFPE,_ARGV,_ARGC,_ENVC,environ + if scheme + extrn _onexit:word ; our hook into C exit fn + extrn cur_off:byte + public _paras,first_pa,first_dos + endif + IF S8086 +_MODEL DW 0 + ENDIF + IF P8086 +_MODEL DW 1 + ENDIF + IF D8086 +_MODEL DW 2 + ENDIF + IF L8086 +_MODEL DW 3 + ENDIF +_VER DB "LC 3.00",0 +_DOS DB 0 ; DOS major version number + DB 0 ; DOS minor version number +_SS DW 0 ; stack segment number +_SP DW 0 ; SP reset value +_TOP DW 0 ; top of stack (relative to SS) +_BASE DW OFFSET DGROUP:SBASE ; base of stack (relative to DS) +_PSP DW 0 ; program segment prefix pointer + DW 0 +_MBASE DW 0 ; base of memory pool + DW 0 +_MNEXT DW 0 ; next available memory location + DW 0 +_MSIZE DW 0 ; number of bytes left in pool + DW 0 +_TSIZE DW 0 ; total size in paragraphs +_PSIZE DD 0 ; size of program in bytes +_DSIZE DW OFFSET DGROUP:SBASE ; size of static data in bytes + DW 0 + IF LDATA +_ARGV DD 0 ; argument vector pointer +environ DD 0 ; environment vector pointer + ELSE + DD 0 ; *** DOS 2.00 trashing bug *** +_ARGV DW 0 ; argument vector pointer +environ DW 0 ; environment vector pointer + ENDIF +_ARGC DW 0 ; argument count +_ENVC DW 0 ; environment count +_ARG DD 0 ; far pointer to original arg array +_ENV DD 0 ; far pointer to original env array +_ESIZE DW 0 ; environment size in bytes +_XSIZE DW 0 ; extended env size in bytes +_FPA DQ 0 ; floating point accumulator +_FPERR DW 0 ; floating point error code +_NDP DB 0 ; non-zero if 8087 is installed +_NDPSW DW 0FFFFH ; 8087 status word +_NDPCW DW 0 ; 8087 control word +_OSERR DW 0 ; DOS error code + IF LPROG +_SIGFPE DD 0 ; Floating point error signal + ELSE +_SIGFPE DW 0 ; Floating point error signal + ENDIF + + if scheme + +_PARAS DW 0 ; # of paragraphs of memory available +FIRST_PA DW 0 ; seg# of first para. actually used for + ; Scheme heap +FIRST_DOS DW 0 ; seg# of first para. from DOS for + ; Scheme heap + +; the characters sought by PCS's scanner +scan_table db 0,' ()"',0 +scan_size equ $-scan_table + +; the FSA transition table used to parse PCS's command line +; (This once included handling for vertical-bar delimited symbols, but +; DOS's use of | rendered it useless, so it was removed.) + +start_state equ 0 +list_state equ 1 +atom_state equ 2 +strg_state equ 3 +end_state equ 4 +err_state equ 5 + +state label byte + ; initial state + db atom_state,ar_decr-actions ; any char + db strg_state,ar_decr-actions ; " + db list_state,ar_rpar-actions ; ) + db err_state,ar_err-actions ; ( + db start_state,ar_skip-actions ; blank + db end_state,ar_end-actions ; null +bytes_per_state equ $-state + ; in list + db list_state,ar_decr-actions + db list_state,ar_decr-actions + db list_state,ar_rpar-actions + db list_state,ar_lpar-actions ; start_state also possible, see ar_lpar + db list_state,ar_decr-actions + db err_state,ar_err-actions + ; in atom + db atom_state,ar_decr-actions + db atom_state,ar_decr-actions + db atom_state,ar_decr-actions + db atom_state,ar_decr-actions + db start_state,ar_out2-actions + db end_state,ar_out_end-actions + ; in string + db strg_state,ar_decr-actions + db start_state,ar_out1-actions + db strg_state,ar_decr-actions + db strg_state,ar_decr-actions + db strg_state,ar_decr-actions + db err_state,ar_err-actions + +; The exit and error states are not explicitly represented +; in the table, action routines deal with them. + + endif + +STKERR DB "Invalid stack size",0DH,0AH,"$" +MEMERR DB "Insufficient memory",0DH,0AH,"$" + if scheme +memerr2 db "Error in returning memory to DOS",0dh,0ah,"$" +parserr db "Error in parsing command line",0dh,0ah,"$" + endif + + IF MSDOS EQ 1 + PUBLIC _INAME,_ONAME +_INAME DB 32 DUP(0) ; input file name +_ONAME DB 32 DUP(0) ; output file name +NAMERR DB "Invalid I/O redirection",0DH,0AH,"$" + ENDIF +DATA ENDS + + +;** +; +; Uninitialized data +; +UDATA SEGMENT PUBLIC 'DATA' +UDATA ENDS + +;** +; +; The stack segment is included to prevent the warning from the +; linker, and also to define the base (lowest address) of the stack. +; +STKRSV EQU 128 ; reserved stack size +STKMIN EQU 512 ; minimum run-time stack size + IF COM +XSTACK SEGMENT 'DATA' + ELSE +XSTACK SEGMENT STACK 'DATA' + ENDIF +SBASE DB STKRSV DUP (?) +XSTACK ENDS + + END CXINIT + \ No newline at end of file diff --git a/scannum.asm b/scannum.asm new file mode 100644 index 0000000..0cf0af7 --- /dev/null +++ b/scannum.asm @@ -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 + \ No newline at end of file diff --git a/scar_cdr.asm b/scar_cdr.asm new file mode 100644 index 0000000..27f3def --- /dev/null +++ b/scar_cdr.asm @@ -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 ; 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 ; 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 ; 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 + 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>, +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 + C_call set_src_,,Load_ES + restore + 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 ; 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,,Load_ES + add SP,WORDINCR + restore + 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 ; push dest reg number, temp_reg address + C_call alloc_li,,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 ; push arguments to cons + C_call cons,,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 ; 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 ; 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 ; 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 ; 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 ; and push + C_call set_src_,,Load_ES + restore + jmp sch_err + + +car_cdr endp + +prog ends + end + \ No newline at end of file diff --git a/schars.h b/schars.h new file mode 100644 index 0000000..fd62147 --- /dev/null +++ b/schars.h @@ -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'}; + \ No newline at end of file diff --git a/scheme.equ b/scheme.equ new file mode 100644 index 0000000..81cb158 --- /dev/null +++ b/scheme.equ @@ -0,0 +1,5 @@ + include schemed.equ + include schemed.ref + include schemed.mac + include smmu.mac + \ No newline at end of file diff --git a/scheme.h b/scheme.h new file mode 100644 index 0000000..b97ad66 --- /dev/null +++ b/scheme.h @@ -0,0 +1,4 @@ +/* =====> SCHEME.H */ +#include "memtype.h" +#include "schmdefs.h" + \ No newline at end of file diff --git a/schemed.asm b/schemed.asm new file mode 100644 index 0000000..95cd511 --- /dev/null +++ b/schemed.asm @@ -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 + + \ No newline at end of file diff --git a/schemed.equ b/schemed.equ new file mode 100644 index 0000000..1d9ce4f --- /dev/null +++ b/schemed.equ @@ -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 + \ No newline at end of file diff --git a/schemed.mac b/schemed.mac new file mode 100644 index 0000000..4f03730 --- /dev/null +++ b/schemed.mac @@ -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, + 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, + mov rr,[BP].save_&&rr + endm + endm + +; Push multiple +pushm MACRO objs + irp oo, + push oo + endm + endm + +; Pop multiple +popm MACRO objs + irp oo, + pop oo + endm + endm + +; Call Lattice C routine: C_call rtn, +; A call is made to "rtn". If "rtn" has not been declared, an "extrn" +; declaration is generated. "", 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 + irp rr, + mov [BP].save_&&rr,rr + endm +ENDIF +IFNB + mov AX,DS ; make ES point to the current + mov ES,AX ; data segment +ENDIF +IFNDEF rtn + extrn rtn:near +ENDIF + call rtn + endm + + \ No newline at end of file diff --git a/schmdefs.h b/schmdefs.h new file mode 100644 index 0000000..c6a1b9c --- /dev/null +++ b/schmdefs.h @@ -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) + \ No newline at end of file diff --git a/screen.equ b/screen.equ new file mode 100644 index 0000000..d9fb5af --- /dev/null +++ b/screen.equ @@ -0,0 +1,4 @@ +DEFAULT_NUM_ROWS equ 25 +DEFAULT_VGA_ROWS equ 30 +DEFAULT_NUM_COLS equ 80 + \ No newline at end of file diff --git a/scroll.asm b/scroll.asm new file mode 100644 index 0000000..2e1a740 --- /dev/null +++ b/scroll.asm @@ -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 + \ No newline at end of file diff --git a/senv.asm b/senv.asm new file mode 100644 index 0000000..dc20621 --- /dev/null +++ b/senv.asm @@ -0,0 +1,1052 @@ +; =====> SENV.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;*Interpreter -- Environment Operations* +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 5 March 1985 * +;* Last Modification: 2 FEB 1987 * +;*************************************** +; +; Modification history +; +; tc 2/10/87 fixed define so that it will define in +; to current environment if not already +; there. + + + + include scheme.equ + include sinterp.mac + + include sinterp.arg + include stackf.equ + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +m_ld_en db "ld-env",0 +m_st_en db "st-env",0 +m_def_en db "define-env",0 +m_en_par db "environment-parent",0 +m_env_lu db "env-lu",0 +m_ld_gl db "ld-global",0 +m_defb db "define!",0 +m_st_gl db "st-global",0 +m_setgnv db "set-global-env!",0 +; Note: the following three (3) definitions are order dependent +lcl_reg equ $ ; local "register" +lcl_disp dw 0 +lcl_page dw 0 +; End of order dependent definitions +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +s_env 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 ; All of the above, with "mov SP,BP" first + extrn src_err:near ; "source operand error" message display + extrn printf_c:near ; Error message print routine + extrn not_yet:near ; Feature not yet implemented + extrn sch_err:near ; Link to Scheme level debugger + +; Entry point defined in "svars.asm" + extrn lookup:near + +;************************************************************************ +;* push environment PUSH-ENV list-of-symbols * +;* * +;* Purpose: Scheme interpreter support to "push" a new rib onto the * +;* current heap allocated environment. * +;************************************************************************ + public push_env +push_env: lods byte ptr ES:[SI] ; load code block constant pointer +; allocate new environment object + mov BX,ENV_SIZE-BLK_OVHD ; load size of environment data object, + mov CX,ENVTYPE ; environment type code, and + mov DX,offset tmp_reg ; temporary register address + pushm ; push arguments to 'allocate_block' + C_call alloc_bl,,Load_ES ; allocate new environment object + +; fetch pointer to list-of-symbols + restore + mov BX,AX + shl AX,1 + add BX,AX ; BX <- constant number * 3 + add BX,CB_dis ; add code block displacement to BX + mov AX,ES:[BX].cod_cdis ; load constant from code block + mov DL,ES:[BX].cod_cpag + +; place previous env pointer in new one; update stack frame's env pointer + mov BX,tmp_page ; load pointer to new env object + mov DI,tmp_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov SI,FP ; load current stack frame pointer + xchg BL,S_stack+[SI].sf_hpage ; exchange old/new env pointers + mov ES:[DI].env_ppag,BL + mov CX,DI + xchg CX,word ptr S_stack+[SI].sf_hdisp + mov ES:[DI].env_pdis,CX + +; put list-of-symbols pointer into new environment data object + mov ES:[DI].env_npag,DL ; and store it + mov ES:[DI].env_ndis,AX + +; set tm2_reg to nil (initial empty list of values) + mov byte ptr tm2_page,NIL_PAGE*2 ; set tmp_reg to nil + mov tm2_disp,NIL_DISP + +; count number of symbols in the list-of-symbols + cmp DL,0 ; is list of symbols nil? + je psh_end ; if empty list, jump + mov ES:[DI].env_vpag,NIL_PAGE*2 ; make value list pointer in env + mov ES:[DI].env_vdis,NIL_DISP ; object nil to prevent GC problems + xor CX,CX ; zero the counter + xor BX,BX + mov BL,DL ; copy the list-of-symbols pointer + mov SI,AX ; into BX:SI +psh_enxt: inc CX ; increment list length counter + LoadPage ES,BX ; follow the cdr field of the linked list +;;; mov ES,pagetabl+[BX] ; follow the cdr field of the linked list + mov BL,ES:[SI].cdr_page + mov SI,ES:[SI].cdr + cmp BL,0 ; end of list? + jne psh_enxt + +; set up parameters for call to cons + mov DX,offset nil_reg + mov AX,offset tm2_reg + pushm + mov AX,DS ; load ES for call to Lattice C routine + mov ES,AX + +; create value list of nil pointers (linked through car field) +psh_cons: C_call cons, ; cons a nil value cell + restore ; reload counter + loop psh_cons ; decrement count, loop if not zero + add SP,WORDINCR*3 ; drop arguments off TIPC's stack + +; store pointer to list of values into environment data object + mov BX,tmp_page ; reload environment object pointer (it + LoadPage ES,BX ; may have been moved during the consing +;;; mov ES,pagetabl+[BX] ; may have been moved during the consing + mov DI,tmp_disp ; of the nil values list) +psh_end: mov AL,byte ptr tm2_page ; store pointer to list-of-values + mov ES:[DI].env_vpag,AL ; into env data object + mov AX,tm2_disp + mov ES:[DI].env_vdis,AX + + jmp next_SP ; return to interpreter + +;************************************************************************ +;* hash-environment HASH-ENV * +;* * +;* Purpose: Scheme interpreter support to return a hashed environment * +;* * +;************************************************************************ + public hash_env +hash_env: lods byte ptr ES:[SI] ; load destination register number +; allocate new environment object + mov BX,(HT_SIZE*3)+BLK_OVHD ; size of hashed env + mov CX,ENVTYPE ; environment type code + mov DX,offset tmp_reg ; temporary register address + pushm ; push arguments to 'allocate_block' + C_call alloc_bl,,Load_ES ; allocate new environment object + mov SP,BP + push tmp_disp ; push new environment's displacement + mov BX,tmp_page ; get page offset of new env. + shr BX,1 ; convert to number + push BX ; push new environment's page number + C_call zero_blk ; zero out the new environment + mov SP,BP + mov BX,tmp_page ; Now address the new environment + mov DI,tmp_disp + LoadPage ES,BX ; ES <= address of new environment + mov BX,FP ; get current stack frame pointer + mov AL,S_stack+[BX].sf_hpage ; get current env pointer from stack + mov ES:[DI].env_ppag,AL ; and store in new env object + mov AX,word ptr S_stack+[BX].sf_hdisp + mov ES:[DI].env_pdis,AX + restore ; restore saved regs + mov DI,AX ; DI <= destination register + mov BX,tmp_page ; get page number of new environment + mov byte ptr reg0_pag+[DI],BL ; and place in destination reg + mov BX,tmp_disp ; get disp of new environment + mov reg0_dis+[DI],BX ; and place in destination + jmp next + +;************************************************************************ +;* drop-environment DROP-ENV I(number to drop) * +;* * +;* Purpose: Scheme interpreter support to drop the most recently * +;* allocated rib from the current environment. * +;************************************************************************ + public drop_env +drop_env: lods byte ptr ES:[SI] ; load drop count + save ; save the current location pointer + mov CX,AX ; copy drop count to CX + mov DI,FP ; load the current stack frame pointer + xor BX,BX + mov BL,S_stack+[DI].sf_hpage ; load environment pointer from + mov SI,word ptr S_stack+[DI].sf_hdisp ; the current stack frame +drop_lp: LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov BL,ES:[SI].env_ppag ; copy parent's pointer from environment + mov SI,ES:[SI].env_pdis + loop drop_lp + mov S_stack+[DI].sf_hpage,BL ; rib into the stack frame + mov word ptr S_stack+[DI].sf_hdisp,SI + jmp next_PC ; return to interpreter + +;************************************************************************ +;* Macro Support for load/store-environment * +;************************************************************************ +ld_st macro direction,text + local x,y + lods word ptr ES:[SI] ; load operands + xor BH,BH + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI and + add DI,offset reg0 ; compute its address + save ; save location pointer, dest reg address + mov BL,AH ; copy constant number into + mov DI,BX ; TIPC register DI + shl BX,1 + add DI,BX ; DI <- constant number * 3 + add DI,CB_dis ; compute address of code block constant + xor BH,BH + mov BL,ES:[DI].cod_cpag ; load symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it? + jne x ; if not a symbol, error (jump) +; call "srch_all" to search the current environment + mov CX,BX ; copy symbol pointer into CX:DX + mov DX,ES:[DI].cod_cdis + mov SI,FP ; load current stack frame pointer + mov BL,S_stack+[SI].sf_hpage ; load current env pointer into + mov SI,word ptr S_stack+[SI].sf_hdisp ; BX:SI + call srch_all ; search environment for symbol + restore ; reload destination register address + cmp BL,0 ; was symbol found in environment? + je y ; if not found, error (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] +IFIDN , +; return value from cdr field of value cell returned by "srch_all" + mov AL,ES:[SI].cdr_page + mov byte ptr [DI].C_page,AL ; store value in destination register + mov AX,ES:[SI].cdr + mov [DI].C_disp,AX +ELSE +IFIDN , +; store value into cdr field of returned value cell + mov AL,byte ptr [DI].C_page ; store value into cdr field + mov ES:[SI].cdr_page,AL ; of cell + mov AX,[DI].C_disp + mov ES:[SI].cdr,AX +ELSE + ***error*** Invalid 'direction' +ENDIF +ENDIF +; return to the Scheme interpreter + jmp next_PC +; ***error-- operand is not a symbol*** +x: lea BX,text ; load text for instruction's name + jmp src_err ; display "source operand error" message +; ***error-- symbol not found in environment*** +y: corrpage CX +IFIDN , + xor AX,AX ; signal current environment being used + pushm ; push arguments for call + C_call sym_unde,,Load_ES ; call: sym_undefined(pg,ds,env,dest); +ELSE + pushm ; push arguments for call + C_call not_lexi,,Load_ES ; call: not_lexically_bound(pg,ds); +ENDIF + restore ; load next instruction's offset and + sub SI,3 ; back it up to retry the ld/st + jmp sch_err ; link to Scheme debugger + endm + +;************************************************************************ +;* Load From Environment LD-ENV R(dest),C(symbol) * +;* * +;* Purpose: Scheme interpreter support to load from the current * +;* environment. * +;************************************************************************ + public ld_env +; load and process operands +ld_env: ld_st load,m_ld_en + +;************************************************************************ +;* Store Into Environment ST-ENV R(value),C(symbol) * +;* * +;* Purpose: Scheme interpreter support to store into the current * +;* environment. * +;************************************************************************ + public st_env +; load and process operands +st_env: ld_st store,m_st_en + + purge ld_st + +;************************************************************************ +;* AL AL AH * +;* Define in Environment DEFINE R(d=s1),R(s2),R(s3) * +;* s1=sym,s2=val,s3=env/nil * +;* * +;* Purpose: Scheme interpreter support to define a symbol in a given * +;* environment. This routine supports the MIT Scheme construct * +;* (set! (access sym env) value). In essence, the current env * +;* is searched for sym. If found, then its binding is modified * +;* to value. Otherwise, a new binding is added to the current * +;* environment. * +;************************************************************************ +; ***error-- invalid operand for define*** +def_en_x: mov BX,offset m_def_en ; load "def-env" text + jmp src_err ; display "invalid source operand" message + + public def_env +def_env: lods byte ptr ES:[SI] ; load symbol operand + mov DI,AX ; copy symbol register number to + add DI,offset reg0 ; DI and compute the register's address + lods word ptr ES:[SI] ; load value/environment operands + save ; save loc ptr, dest reg addr, val/env opnds +; validate and load the symbol operand + mov BX,[DI].C_page ; fetch the symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; is first operand a symbol? + jne def_en_x ; if not a symbol, error (jump) + mov CX,BX ; place symbol pointer into CX:DX + mov DX,[DI].C_disp +; validate and load environment operand + mov BL,AH ; copy env register number to BX + mov SI,reg0_dis+[BX] ; load environment pointer into BX:SI + mov BL,byte ptr reg0_pag+[BX] + cmp byte ptr ptype+[BX],ENVTYPE*2 ; is it an envirnoment object? + je def_e_ok ; if an environment, jump + cmp BL,0 ; is it a nil pointer? + jne def_en_x ; if not nil, error (invalid operand; jump) + mov SI,FP ; load pointer to current stack frame + mov BL,S_stack+[SI].sf_hpage ; default environment to current + mov SI,word ptr S_stack+[SI].sf_hdisp ; environment +; search environment for the symbol +def_e_ok: pushm ; save environment pointer on stack + call srch_all ; search all rib's + restore ; restore 2nd and 3rd operands + cmp BL,0 ; was symbol found? + je def_bind ; if not found, jump + LoadPage ES,BX ; load value cell page's paragraph address +;;; mov ES,pagetabl+[BX] ; load value cell page's paragraph address + mov BL,AL ; copy value register number to BX + mov AL,byte ptr reg0_pag+[BX] ; set cdr of value cell to the + mov ES:[SI].cdr_page,AL ; contents of the value register + mov AX,reg0_dis+[BX] + mov ES:[SI].cdr,AX + jmp next_SP ; return to interpreter + +; Symbol not found in environment -- bind it in given rib +def_bind: restore ; restore symbol register address + pop [BP].temp_reg.C_disp ; restore env pointer in local temp_reg + pop [BP].temp_reg.C_page + mov BL,AL ; compute value register address + add BX,offset reg0 + lea SI,[BP].temp_reg ; load tmp_reg address + pushm ; push args to bind_it + call bind_it ; bind symbol in environment + jmp next_SP ; return to interpreter + +;************************************************************************ +;* Set Global Environment SET-GLOB-ENV! R(value) * +;* * +;* Purpose: Scheme interpreter support to initialize the Global * +;* Environment Register (GNV_reg). * +;************************************************************************ + public set_gnv +set_gnv: lods byte ptr ES:[SI] ; load operand + mov DI,AX ; copy source register number to DI and + add DI,offset reg0 ; compute source/destination reg address + mov AX,[DI].C_disp ; load pointer to new global environment + mov BX,[DI].C_page + cmp byte ptr ptype+[BX],ENVTYPE*2 ;it's an environment, isn't it? + jne set_g_er ; if operand not env, error (jump) + xchg byte ptr GNV_pag,BL ; copy env pointer to GNV_reg + xchg GNV_dis,AX + mov byte ptr [DI].C_page,BL ; store previous value of GNV_reg + mov [DI].C_disp,AX ; into the destination register + jmp next ; return to interpreter +; ***error-- operand is not an environment object*** +set_g_er: save ; save the location pointer + mov BX,offset m_setgnv ; load text for "set-global-env!" + jmp src_err ; display "source operand error" message + +;************************************************************************ +;* AL AH * +;* Load from Global Environment LD-GLOBAL R(d),C(s1) * +;* s1=symbol * +;* * +;* Purpose: Scheme interpreter support to retrieve values for symbols * +;* defined in the current global environment. * +;* * +;* Note: This instruction is an optimization of the LD-ENV operation. * +;* Here, the environment operand defaults to the current * +;* global environment, which is pointer to by GNV_reg. * +;************************************************************************ + public ld_globl +ld_globl: lods word ptr ES:[SI] ; load operands + mov BL,AL ; copy the destintation register + mov DI,BX ; into TIPC register DI and compute + add DI,offset reg0 ; the destination register's address + save ; save said, and the location pointer +; validate the symbol operand and load symbol pointer + mov BL,AH ; copy the constant number + mov SI,BX ; SI <- constant number * 3 + shl SI,1 + add SI,BX + add SI,CB_dis ; add in displacement of current code block + mov BL,ES:[SI].cod_cpag ; load symbol's page number + mov DX,ES:[SI].cod_cdis ; load symbol pointer into CX:DX +ld_gl_x: cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it? + jne ld_g_err ; if not a symbol, error (jump) + mov CX,BX +; load pointer to the global environment + mov BL,byte ptr GNV_pag + mov SI,GNV_dis +; search the global environment for the symbol-- test to see if found + pushm ; save symbol pointer + call srch_all ; search global environment + restore ; reload destination register address + cmp BL,0 ; was symbol found? + je ld_g_nf ; if not found, error (jump) +; copy cdr field of value cell returned into the destination register + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AL,ES:[SI].cdr_page ; copy cdr field of value cell + mov byte ptr [DI].C_page,AL ; into destination register + mov AX,ES:[SI].cdr + mov [DI].C_disp,AX + jmp next_SP ; return to interpreter +; ***error-- symbol operand wasn't a symbol pointer*** +ld_g_err: mov BX,offset m_ld_gl ; load text for "ld-global" + jmp src_err ; display "invalid source operand" message +; ***error-- global symbol not found*** +ld_g_nf: popm ; restore symbol pointer + corrpage CX ; correct page number for call to C + mov AX,offset GNV_reg ; load address of global env register + pushm ; push arguments for call + C_call sym_unde,,Load_ES ; call: sym_undefined(pg,ds,env,dest) + restore ; load next intstruction's offset and + sub SI,3 ; back up location pointer to retry load + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* AL AH * +;* Load from Global Environment (reg operand) LD-GLOBAL-R R(d),R(s1) * +;* s1=symbol * +;* * +;* Purpose: Scheme interpreter support to retrieve values for symbols * +;* defined in the current global environment. * +;* * +;* Note: This instruction is an optimization of the LD-ENV operation. * +;* Here, the environment operand defaults to the current * +;* global environment, which is pointer to by GNV_reg. * +;************************************************************************ + public ld_globr +ld_globr: lods word ptr ES:[SI] ; load operands + mov BL,AL ; copy the destintation register + mov DI,BX ; into TIPC register DI and compute + add DI,offset reg0 ; the destination register's address + save ; save said, and the location pointer +; load symbol pointer + mov BL,AH ; copy the symbol's register number + mov DX,reg0_dis+[BX] ; load symbol's displacement + mov BL,byte ptr reg0_pag+[BX] ; load symbol's page number + jmp ld_gl_x ; continue process as ld-global + +;************************************************************************ +;* AL AH * +;* Define in Global Environment DEFINE! R(d=s1),C(s2) * +;* s1=value,s2=symbol * +;* * +;* Purpose: Scheme interpreter support to assign a variable in the * +;* current "global" environment. * +;* * +;* Note: This instruction is an optimization of the DEFINE-ENV * +;* operation. Here, the environment operand defaults to * +;* the current global environment, which is pointed to by * +;* GNV_reg. * +;************************************************************************ + public define +define: lods word ptr ES:[SI] ; load operands + mov BL,AH ; copy constant number to BX + xor AH,AH + mov DI,AX ; copy value/destination register number + add DI,offset reg0 ; to DI and compute the register's address + save ; save location pointer, dest reg address +; validate symbol operands and load it into CX:DX + mov SI,BX ; copy constant number into SI + shl SI,1 + add SI,BX ; SI <- constant number * 3 + add SI,CB_dis ; add starting offset of current code block + mov BL,ES:[SI].cod_cpag ; load symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it? + jne defb_err ; if not a symbol, error (jump) + mov CX,BX ; put symbol pointer into CX:DX + mov DX,ES:[SI].cod_cdis + pushm ; save pointer to symbol +; load global environment pointer into BX:SI + mov BL,byte ptr GNV_pag + mov SI,GNV_dis +; search the global environment for the symbol-- test to see if found + call srch_env + cmp BL,0 + je defb_new +; symbol was found-- set cdr of field returned to the value specified + restore + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AL,byte ptr [DI].C_page + mov ES:[SI].cdr_page,AL + mov AX,[DI].C_disp + mov ES:[SI].cdr,AX + jmp next_SP ; return to interpreter +; symbol wasn't found-- create new binding in current global environment +defb_new: mov AX,SP ; get address of symbol + +; In case you're wondering what just went on with the above instruction, +; the page and displacement of the symbol to be bound are residing in the +; correct order on the top of the stack. The "mov AX,SP" captures the +; address of said pointer so that it may be used as an argument to +; sym_bind, below. + + mov BX,offset GNV_reg ; load GNV_reg address (contains env ptr) + pushm ; push sym,val,env register pointers + call bind_it ; create binding in global environment + jmp next_SP ; return to interpreter +; ***error-- symbol operand wasn't a symbol*** +defb_err: mov BX,offset m_defb + jmp src_err + +;************************************************************************ +;* AL AH * +;* Define in Global Environment ST-GLOBAL R(d=s1),C(s2) * +;* s1=value,s2=symbol * +;* * +;* Purpose: Scheme interpreter support to assign a variable in the * +;* current "global" environment. * +;* * +;* Note: This instruction is an optimization of the ST-ENV * +;* operation. Here, the environment operand defaults to * +;* the current global environment, which is pointed to by * +;* GNV_reg. * +;************************************************************************ + public st_globl +st_globl: lods word ptr ES:[SI] ; load operands + mov BL,AH ; copy constant number to BX + xor AH,AH + mov DI,AX ; copy value/destination register number + add DI,offset reg0 ; to DI and compute the register's address + save ; save location pointer, dest reg address +; validate symbol operands and load it into CX:DX + mov SI,BX ; copy constant number into SI + shl SI,1 + add SI,BX ; SI <- constant number * 3 + add SI,CB_dis ; add starting offset of current code block + mov BL,ES:[SI].cod_cpag ; load symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it? + jne st_gl_er ; if not a symbol, error (jump) + mov CX,BX ; put symbol pointer into CX:DX + mov DX,ES:[SI].cod_cdis + pushm ; save pointer to symbol +; load global environment pointer into BX:SI + mov BL,byte ptr GNV_pag + mov SI,GNV_dis +; search the global environment for the symbol-- test to see if found + call srch_all + restore + cmp BL,0 + je st_gl_nf +; symbol was found-- set cdr of field returned to the value specified + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AL,byte ptr [DI].C_page + mov ES:[SI].cdr_page,AL + mov AX,[DI].C_disp + mov ES:[SI].cdr,AX + jmp next_SP ; return to interpreter +; symbol wasn't found-- inquire from user as to what to do +st_gl_nf: popm ; restore pointer to symbol + corrpage CX ; adjust page number for C call + pushm ; push page, disp, value reg address + C_call not_glob,,load_ES ; resolve error situation + restore ; load next instruction's offset and back + sub SI,3 ; location pointer up to retry the store + jmp sch_err ; link to Scheme debugger +; ***error-- invalid operand to st-global*** +st_gl_er: mov BX,offset m_st_gl + jmp src_err + +;************************************************************************ +;* Environment Predicate ENV? object * +;* * +;* Purpose: Scheme interpreter support to test for an environment * +;* data object. * +;************************************************************************ + public env_p +env_p: lods byte ptr ES:[SI] ; load the operand + mov DI,AX ; and copy into TIPC register DI + mov BX,reg0_pag+[DI] ; load the operand's page number + cmp byte ptr ptype+[BX],ENVTYPE*2 ; is operand an environment? + je env_t ; if an environment object, jump +; object not an env-- return a value of nil in the destination register + mov byte ptr reg0_pag+[DI],NIL_PAGE*2 + mov reg0_dis+[DI],NIL_DISP*2 + jmp next ; return to interpreter +; object is an env-- return a value of 't in the destination register +env_t: mov byte ptr reg0_pag+[DI],T_PAGE*2 + mov reg0_dis+[DI],T_DISP*2 + jmp next ; return to interpreter + +;************************************************************************ +;* Make Environment MK-ENV dest * +;* * +;* Purpose: Scheme interpreter support to return a pointer to the * +;* current environment. * +;************************************************************************ + public mk_env +mk_env: lods byte ptr ES:[SI] ; load destination register number + mov DI,AX ; and put it in TIPC register DI + mov BX,FP ; load the current stack frame pointer + mov AL,S_stack+[BX].sf_hpage ; load current env pointer from stack + mov byte ptr reg0_pag+[DI],AL; and put in destination register + mov AX,word ptr S_stack+[BX].sf_hdisp + mov reg0_dis+[DI],AX + jmp next ; return to interpreter + +;************************************************************************ +;* Environment Parent ENV-PARENT env * +;* * +;* Purpose: Scheme interpreter return the "parent" of a given * +;* environment. * +;************************************************************************ + public env_par +env_par: lods byte ptr ES:[SI] ; load the environment operand + save ; save the current location pointer + mov DI,AX ; copy operand register number to DI + mov BX,reg0_pag+[DI] ; load operand's page number + cmp byte ptr ptype+[BX],ENVTYPE*2 ; is operand an environment? + jne env_p_er ; if not an environment, error (jump) + mov SI,reg0_dis+[DI] ; load pointer to environment object + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AL,ES:[SI].env_ppag ; load parent pointer from env object + mov byte ptr reg0_pag+[DI],AL ; and put in destination register + mov AX,ES:[SI].env_pdis + mov reg0_dis+[DI],AX + jmp next_PC ; return to interpreter +; ***error-- invalid operand*** +env_p_er: lea BX,m_en_par ; load text addr for "environment-parent" + jmp src_err ; display "invalid source operand" message + +;************************************************************************ +;* Lookup In Environment ENV-LU R(d=s1),R(s2) * +;* s1=symbol,s2=env * +;************************************************************************ + public env_lu +env_lu: lods word ptr ES:[SI] ; load operands +; fetch and validate first operand (symbol pointer) + xor BH,BH + mov BL,AL + mov DI,BX + add DI,offset reg0 + save ; save location pointer; dest reg address + mov CX,[DI].C_page ; copy symbol pointer into CX:DX + mov DX,[DI].C_disp + mov BX,CX ; test to make sure that first operand + cmp byte ptr ptype+[BX],SYMTYPE*2 ; is a symbol + jne env_lu_x ; if not a symbol, error (jump) +; fetch and validate second operand (environment pointer) + mov BL,AH ; copy env register number + mov SI,reg0_dis+[BX] ; copy environment pointer into BX:SI + mov BL,byte ptr reg0_pag+[BX] + cmp byte ptr ptype+[BX],ENVTYPE*2 ; it is an env, isn't it? + jne env_lu_x ; if operand not environment, error (jump) +; search the environment for the symbol + call srch_all ; search all ribs +; store result of search into destination register + restore ; reload the destination register address + mov byte ptr [DI].C_page,BL + mov [DI].C_disp,SI + jmp next_PC ; return to interpreter +; ***error-- invalid operand*** +env_lu_x: mov BX,offset m_env_lu + jmp src_err + +s_env endp + +;************************************************************************ +;* Local Support - Search Environment (all of it) * +;* * +;* Input Parameters: CX:DX - search symbol * +;* BX:SI - environment chain pointer * +;* * +;* Output Parameters: BX:SI - value cell for symbol * +;************************************************************************ +srch_all proc near + pushm ; save pointer to current rib + call srch_env ; search rib for desired symbol + cmp BX,0 ; was symbol found? + jne srch_ok ; if symbol found, jump + popm ; restore pointer to current rib + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load pointer to parent rib + mov BL,ES:[SI].env_ppag + mov SI,ES:[SI].env_pdis + cmp BX,0 ; does parent rib exist? + jne srch_all ; if no parent, symbol not found (jump) + jmp short srch_nok +srch_ok: add SP,WORDINCR*4 ; dump env pointer off stack +srch_nok: ret ; return search result to caller +srch_all endp + +;************************************************************************ +;* Local Support - Search Environment (one rib) * +;* * +;* Input Parameters: CX:DX - search symbol * +;* BX:SI - environment chain pointer * +;* * +;* Output Parameters: BX:SI - value cell for symbol * +;************************************************************************ +srch_env proc near + LoadPage ES,BX ; load paragraph address of env chain +;;; mov ES,pagetabl+[BX] ; load paragraph address of env chain + cmp ES:[SI].env_len,ENV_SIZE ; hash table or "rib"? + jne srch_ht ; if hash table, jump + pushm ; save pointer to environment +;;;; pushm ; save pointer to environment + mov AX,1 ; initialize counter + xor BX,BX + mov BL,ES:[SI].env_npag ; load pointer to list of symbols + mov SI,ES:[SI].env_ndis +srch_mor: cmp BL,0 ; more symbols in this rib? + je srch_nf ; if end of symbol list, jump + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp DX,ES:[SI].car ; is symbol disp eq to this entry? + jne srch_nxt ; if no match, jump + cmp CL,ES:[SI].car_page ; is page number eq? + je srch_fnd ; if symbol's page number eq, jump +srch_nxt: inc AX ; increment symbol count + mov BL,ES:[SI].cdr_page ; follow cdr field of linked list + mov SI,ES:[SI].cdr + jmp short srch_mor ; loop +srch_fnd: mov CX,AX ; move counter symbol counter to CX + popm ; recover pointer to environment chain + LoadPage ES,BX +;;;; popm ; recover pointer to environment chain + mov BL,ES:[SI].env_vpag ; load pointer to value list + mov SI,ES:[SI].env_vdis + jmp short srch_f1 +srch_lp: LoadPage ES,BX ; follow chain through car field of linked +;;; mov ES,pagetabl+[BX] ; follow chain through car field of linked + mov BL,ES:[SI].car_page ; list + mov SI,ES:[SI].car +srch_f1: loop srch_lp ; not value entry for symbol, loop (jump) + ret ; return to caller +; symbol not found-- return nil +srch_nf: add SP,WORDINCR*2 ; drop env pointer off stack + ret ; return to caller +; +; Hash Table Rib Format +; +srch_ht: pushm ; save arguments to srch_env + mov lcl_page,CX ; store symbol pointer in tmp_reg + mov lcl_disp,DX + mov AX,offset lcl_reg ; load address of lcl_reg and push + push AX ; it as an argument to sym_hash + call sym_hash ; get the hash value for the symbol + add SP,WORDINCR ; drop the argument off the stack + cmp AX,HT_SIZE ; valid hash value returned? + jae srch_htx ; if not valid, error (jump) +; fetch symbol chain from indicated hash table bucket + popm ; restore pointer to environment object + add SI,AX ; env-ptr += hash-value * 3 + shl AX,1 + add SI,AX + LoadPage ES,BX ; load environment page's paragraph address +;;; mov ES,pagetabl+[BX] ; load environment page's paragraph address + mov BL,ES:[SI].env_npag ; load pointer to hash chain + cmp BL,0 ; is chain empty? + je srch_nfx ; if chain is empty, symbol not found (jump) + mov SI,ES:[SI].env_ndis + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov DX,lcl_page ; restore symbol pointer into DX:AX + mov AX,lcl_disp + call lookup ; search for symbol in linked list + mov SI,DI ; put pointer returned in BX:SI + ret ; return to caller +; ***error-- symbol operand wasn't a symbol*** +srch_htx: add SP,WORDINCR*2 ; drop saved arguments off stack + xor BX,BX ; return a nil pointer +srch_nfx: xor SI,SI + ret +srch_env endp + +;************************************************************************ +;* Symbol Binding Routine * +;* * +;* Purpose: Lattice C callable routine to return the bind a value to * +;* a symbol in a given environment. * +;* * +;* Calling Sequence: sym_bind(symbol, value, environment) * +;* where symbol - register containing the symbol * +;* pointer * +;* value - register containing the value to * +;* be assigned * +;* environment - register containing a pointer to * +;* the environment in which the * +;* binding is to take place * +;************************************************************************ +bind_arg struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +bnd_sym dw ? ; address of symbol register +bnd_val dw ? ; address of value register +bnd_env dw ? ; address of environment register +bind_arg ends + + public sym_bind +bind_it proc near + push ES ; save the caller's ES register + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for local data + jmp sb_new ; bind symbol in current environment + +sym_bind: push ES ; save the caller's ES register + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for local data + +; see if symbol is already present in the environment + mov BX,[BP].bnd_sym ; load address of symbol register + mov CX,[BX].C_page ; load symbol pointer into CX:DX + mov DX,[BX].C_disp + mov BX,[BP].bnd_env ; load address of environment register + mov SI,[BX].C_disp ; load environment pointer into BX:SI + mov BX,[BX].C_page + call srch_all ; search the environment for the symbol + cmp BL,0 ; was the symbol found in the environment? + je sb_new ; if symbol not found, jump +; store the value into the cdr field of the returned value cell + LoadPage ES,BX ; load value cell's paragraph address +;;; mov ES,pagetabl+[BX] ; load value cell's paragraph address + mov BX,[BP].bnd_val ; load address of value register + mov AL,byte ptr [BX].C_page ; copy value from value register + mov ES:[SI].cdr_page,AL ; into the cdr field of the value cell + mov AX,[BX].C_disp + mov ES:[SI].cdr,AX + jmp sb_ret ; return to caller + +; fetch pointer to environment-- decide format of said +sb_new: mov SI,[BP].bnd_env + mov BX,[SI].C_page + mov SI,[SI].C_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp ES:[SI].env_len,ENV_SIZE + jne sb_ht +; +; bind symbol to "rib" format environment +; +; cons(env[name], symbol, env[name]) + mov AL,ES:[SI].env_npag ; copy name list chain from environment + mov byte ptr tmp_page,AL ; object to tmp_reg + mov AX,ES:[SI].env_ndis + mov tmp_disp,AX + mov AX,offset tmp_reg + pushm ; push arguments to "cons" + call cons ; cons symbol to front of name list + mov BX,[BP].bnd_env ; reload pointer to environment object + mov SI,[BX].C_disp ; (it may have been relocated during the + mov BX,[BX].C_page ; consing operation) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; + mov AL,byte ptr tmp_page ; update name list pointer in the + mov ES:[SI].env_npag,AL ; environment object + mov AX,tmp_disp + mov ES:[SI].env_ndis,AX +; cons(env[value], env[value], value) + mov AL,ES:[SI].env_vpag ; copy value list chain from environment + mov byte ptr tmp_page,AL ; object to tmp_reg + mov AX,ES:[SI].env_vdis + mov tmp_disp,AX + mov AX,offset tmp_reg + pushm <[BP].bnd_val,AX,AX> ; push arguments to "cons" + call cons ; cons value to front of value list + mov BX,[BP].bnd_env ; reload pointer to environment object + mov SI,[BX].C_disp ; (it may have been relocated during the + mov BX,[BX].C_page ; consing operation) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; + mov AL,byte ptr tmp_page ; update value list pointer in the + mov ES:[SI].env_vpag,AL ; environment object + mov AX,tmp_disp + mov ES:[SI].env_vdis,AX + jmp sb_ret ; return to caller +; +; bind symbol to "hash table" format environment +; +sb_ht: +; cons(tmp_reg, symbol, value) + mov AX,offset tmp_reg ; load address of tmp_reg + mov BX,offset nil_reg ; load address of nil_reg +; Note: we're pushing the arguments for both calls to "cons" in the +; following statement + pushm ; push args to cons + call cons + add SP,3*WORDINCR ; drop the top three arguments from the stack +; cons(tmp_reg, tmp_reg, nil_reg) + call cons +; obtain hash value for the symbol + push [BP].bnd_sym + call sym_hash + mov BX,AX ; multiply hash value by 3 + shl AX,1 + add BX,AX + mov SI,[BP].bnd_env ; load pointer to environment object + add BX,[SI].C_disp ; (which may have been moved during + mov SI,[SI].C_page ; the consing operations) + LoadPage ES,SI +;;; mov ES,pagetabl+[SI] + mov AX,tmp_page ; load pointer to second list cell + mov SI,AX + xchg AL,ES:[BX].env_npag ; swap list header in environment hash + mov DX,tmp_disp ; table with the pointer to the second + mov DI,DX ; list cell + xchg DX,ES:[BX].env_ndis + LoadPage ES,SI ; load pointer to second list cell +;;; mov ES,pagetabl+[SI] ; load pointer to second list cell + mov ES:[DI].cdr_page,AL ; update entry in environment hash table + mov ES:[DI].cdr,DX + +; return to calling procedure +sb_ret: mov SP,BP ; clean up the TIPC's stack + pop BP ; restore caller's BP + pop ES ; restore caller's ES, too + ret ; return to caller +bind_it endp + +;************************************************************************ +;* Symbol Lookup Routine * +;* * +;* Purpose: Lattice C callable routine to return the value bound to * +;* a symbol in a given environment. * +;* * +;* Calling Sequence: sym_bind(symbol, environment) * +;* where symbol - register containing the symbol * +;* pointer * +;* environment - register containing a pointer to * +;* the environment to be searched * +;************************************************************************ +look_arg struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +look_sym dw ? ; address of symbol register +look_env dw ? ; address of environment register +look_arg ends + + public sym_look +sym_look proc near + push ES ; save the caller's ES register + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for local data + +; see if symbol is already present in the environment + mov BX,[BP].look_sym ; load address of symbol register + mov CX,[BX].C_page ; load symbol pointer into CX:DX + mov DX,[BX].C_disp + mov BX,[BP].look_env ; load address of environment register + mov SI,[BX].C_disp ; load environment pointer into BX:SI + mov BX,[BX].C_page + call srch_all ; search the environment for the symbol + xor AX,AX ; set result to false, in case search failed + cmp BL,0 ; was the symbol found in the environment? + je look_ret ; if symbol not found, jump +; return the value in the cdr field in the argument register + LoadPage ES,BX ; load value cell's paragraph address +;;; mov ES,pagetabl+[BX] ; load value cell's paragraph address + mov BX,[BP].look_sym ; load address of register + mov AL,ES:[SI].cdr_page ; copy current binding into the + mov byte ptr [BX].C_page,AL ; argument register + mov AX,ES:[SI].cdr + mov [BX].C_disp,AX + mov AX,1 ; set result to "TRUE" +; return to calling procedure +look_ret: pop BP ; restore caller's BP + pop ES ; restore caller's ES, too + ret ; return to caller +sym_look endp + +;************************************************************************ +;* Symbol Hashing Routine * +;* * +;* Purpose: Lattice C callable routine to return the hash value for * +;* a given symbol. * +;* * +;* Calling Sequence: hash = sym_hash(reg) * +;* reg - register containing symbol pointer * +;* hash - the hash value (if page/disp don't point * +;* to a symbol, -1 is returned) * +;* * +;* Methods Used: The hash value is computed by summing the characters * +;* of the symbol and returning the remainder on division * +;* by the length of the hash table (HT_SIZE). * +;* * +;* Note: This routine must return the same hash value as the routine * +;* "hash" in SUPPORT.C. If the hashing algorithm is * +;* changed, it must be changed in both routines. * +;************************************************************************ +sh_args struc + dw ? ; caller's BP + dw ? ; return address +sh_reg dw ? ; symbol pointer register address +sh_args ends + + public sym_hash +sym_hash proc near + push BP ; save caller's BP + mov BP,SP +; Fetch pointer to symbol-- make sure object is a symbol + mov DI,[BP].sh_reg ; load register address + mov BX,[DI].C_page ; load symbol's page number + cmp byte ptr ptype+[BX],SYMTYPE*2 ; is object a symbol? + jne sh_error ; if not a symbol, error (jump) + push ES ; save caller's ES + LoadPage ES,BX ; load symbol page's paragraph address +;;; mov ES,pagetabl+[BX] ; load symbol page's paragraph address + mov SI,[DI].C_disp ; load symbol's displacement +; Fetch hash value from symbol object + xor AH,AH ; clear high order byte of AX + mov AL,ES:[SI].sym_hkey ; fetch hash key +; Return value in TIPC register AX + pop ES ; restore caller's ES +sh_ret: pop BP ; restore caller's BP + ret ; return +; ***error-- input argument wasn't a symbol pointer*** +sh_error: mov AX,-1 ; return a hash value of -1 + jmp short sh_ret ; return invalid hash value +sym_hash endp + +prog ends + end + \ No newline at end of file diff --git a/sexec.asm b/sexec.asm new file mode 100644 index 0000000..d8c6806 --- /dev/null +++ b/sexec.asm @@ -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 + \ No newline at end of file diff --git a/sgcmark.asm b/sgcmark.asm new file mode 100644 index 0000000..535b555 --- /dev/null +++ b/sgcmark.asm @@ -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 ; 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 + mov AX,DS + mov ES,AX + C_call printf + C_call exit + +sum_spac endp + +prog ends + end + + \ No newline at end of file diff --git a/sgcsweep.asm b/sgcsweep.asm new file mode 100644 index 0000000..7b2e3d6 --- /dev/null +++ b/sgcsweep.asm @@ -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 + + \ No newline at end of file diff --git a/sinterp.arg b/sinterp.arg new file mode 100644 index 0000000..90bdb8d --- /dev/null +++ b/sinterp.arg @@ -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 diff --git a/sinterp.asm b/sinterp.asm new file mode 100644 index 0000000..42c000c --- /dev/null +++ b/sinterp.asm @@ -0,0 +1,3213 @@ +; =====> SINTERP.ASM +;****************************************************************************** +;* TIPC Scheme '84 Runtime Support * +;* Interpreter * +;* * +;* (C) Copyright 1984,1985,1986,1987 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 2 May 1984 * +;* Last Modification: * +;* 11 Feb 86 - Replaced support for even? and odd? to reduce code size and * +;* to update error messages. * +;* - Improved error handling for divide,quotient, and remainder. * +;* - Fixed divide by zero error in Remainder function * +;* 21 Oct 86 - added an additional argument to %graphics - dbs * +;* 7 Nov 86 - %graphics accepts negative arguments (for clipping) - rb * +;* 7 Jan 87 - added random I/O - dbs * +;* 10 Feb 87 - added new opcode (186) for read-line - tc * +;* 8 Mar 87 - XLI - rb * +;* 16 Mar 87 - Added dos-err entry point for detection of Dos I/O errors. * +;* 17 Feb 88 - Mods so sinterp will work in protected mode - tc * +;* * Macros in SMMU.MAC allow stores into code segment * +;* * Graphics for pro mode moved to PROIO.ASM * +;* * %ESC function modified to look for sw-int and call * +;* SOFTINT function in PRO2REAL.ASM * +;* * Timer interrupts no longer taken over for pro mode. * +;* Engines work based on # vm instructions executed for pro * +;* mode. Interpreter loop for engines included (eng_next1) * +;* and settimer, rsttimer included here (conditionally of * +;* course). * +;* * +;* * +;****************************************************************************** + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; The following files are defined in smmu.equ but are split out here so +; that this module will assemble.... + + include schemed.equ + include schemed.ref + include schemed.mac + purge markedp,pushptr,popptr + include smmu.mac + purge %LoadPage,%LoadPage0,%LoadPage1 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + include sinterp.mac + include sinterp.arg + include pcmake.equ + include stackf.equ ; define stack frame format + +XGROUP group progx +progx segment word public 'progx' + +IFDEF PROMEM + extrn softint:far ; interface for sw_int (see PRO2REAL.ASM) +ELSE + extrn graphit:far ; interface to graphics primitives +ENDIF + extrn str_apnd:far ; substring append support + extrn str_disp:far ; %substring-display support + + +progx ends + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + + extrn page0:word + +; Primary opcode lookup table +op_table dw copy ; 000- load dest,src + dw ld_const ; 001- ld-const dest,constant-number (byte) + dw ld_imm ; 002- ld-imm dest,immed-value (byte) + dw ld_nil ; 003- ld-nil dest + dw PGROUP:ld_local ; 004- ld-local dest,entry-number (byte) + dw PGROUP:ld_lex ; 005- ld-lex dest,entry-no,delta-level + dw PGROUP:ld_env ; 006- ld-env R(dest),C(sym) + dw PGROUP:ld_globl ; 007- ld-global dest,constant-number (byte) + + dw PGROUP:ld_fluid ; 008- ld-fluid dest,constant-number (byte) + dw ld_off_s ; 009- ld-vec-s vect,offset (byte) + dw ld_off_l ; 010- ld-vec-l vect,offset (word) + dw ld_off_r ; 011- ld-vec-r vect,offset (reg) + dw PGROUP:st_local ; 012- st-local src,entry-number (byte) + dw PGROUP:st_lex ; 013- st-lex src,entry-no,delta-level + dw PGROUP:st_env ; 014- st-env R(val),C(sym) + dw PGROUP:st_globl ; 015- st-global src,constant-number (byte) + + dw PGROUP:st_fluid ; 016- st-fluid src,constant-number (byte) + dw st_off_s ; 017- st-vec-s vect,offset (byte),src + dw st_off_l ; 018- st-vec-l vect,offset (word),src + dw st_off_r ; 019- st-vec-r vect,offset (reg),src + dw PGROUP:set_car ; 020- set-car! dest,src + dw PGROUP:set_cdr ; 021- set-cdr! dest,src + dw recompil ; 022- (unused) formerly set-ref! + dw recompil ; 023- (unused) formerly swap-ref! + + dw PGROUP:spop ; 024- pop dest + dw PGROUP:spush ; 025- push src + dw PGROUP:sdrop ; 026- drop count (unsigned byte) + dw PGROUP:ld_globr ; 027- ld-global-r dest,sym + dw recompil ; 028- (unused- formerly push-heap) + dw PGROUP:bind_fl ; 029- bind-fl const,src + dw PGROUP:unbind_f ; 030- unbind_fl count (byte) + dw PGROUP:define ; 031- define! src,const + + dw jmp_shrt ; 032- jmp_s label (byte) + dw jmp_long ; 033- jmp_l label (word) + dw j_nil_s ; 034- jnil_s reg,label (byte) + dw j_nil_l ; 035- jnil_l reg,label (word) + dw j_nnil_s ; 036- jnnil_s reg,label (byte) + dw j_nnil_l ; 037- jnnil_l reg,label (word) + dw j_atm_s ; 038- jatom_s reg,label (byte) + dw j_atm_l ; 039- jatom_l reg,label (word) + + dw j_natm_s ; 040- jnatom_s reg,label (byte) + dw j_natm_l ; 041- jnatom_l reg,label (word) + dw j_eq_s ; 042- jeq_s reg,label (byte) + dw j_eq_l ; 043- jeq_l reg,label (word) + dw j_neq_s ; 044- jneq_s reg,label (byte) + dw j_neq_l ; 045- jneq_l reg,label (word) + dw recompil ; 046- (unused) formerly deref + dw recompil ; 047- (unused) formerly ref + + dw PGROUP:call_lcl ; 048- call lbl,delta-level,delta-heap + dw PGROUP:call_ltr ; 049- call-tr lbl,delta-level,delta-heap + dw PGROUP:call_cc ; 050- call/cc lbl,delta-level,delta-heap + dw PGROUP:cl_cctr ; 051- call/cc-tr lbl delta-level,delta-heap + dw PGROUP:call_clo ; 052- call-cl reg,number-args + dw PGROUP:call_ctr ; 053- call-cl-tr reg,number-args + dw PGROUP:clcc_c ; 054- call/cc-cl reg + dw PGROUP:clcc_ctr ; 055- call/cc-cl-tr reg + + dw PGROUP:apply ; 056- apply-cl reg,arg + dw PGROUP:apply_tr ; 057- apply-cl-tr reg,arg + dw PGROUP:execute ; 058- execute reg + dw PGROUP:s_exit ; 059- exit + dw PGROUP:cr_close ; 060- close dest,label,number-args + dw PGROUP:drop_env ; 061- drop-env count + dw PGROUP:hash_env ; 062- make-hashed-environment + dw PGROUP:ld_fl_r ; 063- ld-fluid-r dest,sym + + dw PGROUP:ld_car ; 064- car dest,src + dw PGROUP:ld_cdr ; 065- cdr dest,src + dw PGROUP:ld_caar ; 066- caar dest,src + dw PGROUP:ld_cadr ; 067- cadr dest,src + dw PGROUP:ld_cdar ; 068- cdar dest,src + dw PGROUP:ld_cddr ; 069- cddr dest,src + dw PGROUP:ld_caaar ; 070- caaar dest,src + dw PGROUP:ld_caadr ; 071- caadr dest,src + + dw PGROUP:ld_cadar ; 072- cadar dest,src + dw PGROUP:ld_caddr ; 073- caddr dest,src + dw PGROUP:ld_cdaar ; 074- cdaar dest,src + dw PGROUP:ld_cdadr ; 075- cdadr dest,src + dw PGROUP:ld_cddar ; 076- cddar dest,src + dw PGROUP:ld_cdddr ; 077- cdddr dest,src + dw PGROUP:ld_caddd ; 078- cadddr dest,src + dw PGROUP:s_cons ; 079- cons dest,car,cdr + + dw add ; 080- add dest,src + dw addi ; 081- add-imm dest,imm (signed byte) + dw sub ; 082- sub dest,src + dw mul ; 083- mul dest,src + dw muli ; 084- mul-imm dest,imm (signed byte) + dw div ; 085- div dest,src + dw divi ; 086- div-imm dest,imm (signed byte) + dw quo ; 087- quotient dest,src **integers only** + + dw modulo ; 088- remainder dest,src + dw PGROUP:ld_car1 ; 089- %car src=dest + dw PGROUP:ld_cdr1 ; 090- %cdr src=dest + dw random ; 091- %random dest + dw lt_p ; 092- < dest,src + dw le_p ; 093- <= dest,src + dw eq_n ; 094- = dest,src + dw gt_p ; 095- > dest,src + + dw ge_p ; 096- >= dest,src + dw ne_p ; 097- <> dest,src + dw maximum ; 098- max dest,src + dw minimum ; 099- min dest,src + dw eq_p ; 100- eq? dest,src + dw eqv_p ; 101- eqv? dest,src + dw equal_p ; 102- equal? dest,src + dw PGROUP:memq ; 103- memq dest,src + + dw PGROUP:memv ; 104- memv dest,src + dw PGROUP:member ; 105- member dest,src + dw reverseb ; 106- reverse! list + dw not_yet ; 107- reverse list + dw PGROUP:assq ; 108- assq obj,list + dw PGROUP:assv ; 109- assv obj,list + dw PGROUP:assoc ; 110- assoc obj,list + dw PGROUP:s_list ; 111- list obj + + dw PGROUP:appendb ; 112- append! list,obj + dw append ; 113- append list,obj + dw not_yet ; 114- delq! obj,list + dw not_yet ; 115- delete! obj,list + dw getprop ; 116- get-prop name,prop + dw putprop ; 117- put-prop name,val,prop + dw proplist ; 118- proplist name + dw remprop ; 119- remprop name,prop + + dw PGROUP:list2 ; 120- list2 dest=src1,src2 + dw not_yet ; 121- list-ref dest=src1,src2 + dw PGROUP:l_tail ; 122- list-tail dest,count + dw not_op ; 123- (unused) + dw not_op ; 124- (unused) + dw b_xor ; 125- bitwise-xor dest=src1,src2 + dw b_and ; 126- bitwise-and dest=src1,src2 + dw b_or ; 127- bitwise-or dest=src1,src2 + + +; Note: the second half of the opcodes are "second class" opcodes, +; in that TIPC register BH will not be zero at the entry to the +; support routine. For the following instructions, BH will +; contain the value one (1). + + dw atom_p ; 128- atom? dest + dw closur_p ; 129- closure? dest + dw code_p ; 130- code? dest + dw contin_p ; 131- continuation? dest + dw even_p ; 132- even? dest + dw float_p ; 133- float? dest + dw PGROUP:fluid_p ; 134- fluid-bound? dest + dw integr_p ; 135- integer? dest + + dw null_p ; 136- null? dest + dw number_p ; 137- number? dest + dw odd_p ; 138- odd? dest + dw pair_p ; 139- pair? dest + dw port_p ; 140- port? dest + dw proc_p ; 141- proc? dest + dw recompil ; 142- (unused) formerly ref? + dw string_p ; 143- string? dest + + dw symbol_p ; 144- symbol? dest + dw vector_p ; 145- vector? dest + dw eq_z_p ; 146- zero? dest + dw lt_z_p ; 147- negative? dest + dw gt_z_p ; 148- positive? dest + dw sabs ; 149- abs dest + dw float ; 150- float dest + dw minus ; 151- minus dest + + dw sfloor ; 152- floor dest + dw sceiling ; 153- ceiling dest + dw struncat ; 154- truncate dest + dw sround ; 155- round dest + dw char_p ; 156- char? dest + dw PGROUP:env_p ; 157- env? dest + dw not_op ; 158- (unused) + dw not_op ; 159- (unused) + + dw asc_char ; 160- asc->char reg + dw char_asc ; 161- char->asc reg + dw recompil ; 162- (unused) formerly gensym + dw not_op ; 163- (unused) + dw not_op ; 164- (unused) + dw slength ; 165- length list + dw lst_pair ; 166- last-pair list + dw substr ; 167- substr str,pos,len + + dw PGROUP:vec_allo ; 168- alloc-vec dest + dw PGROUP:vec_size ; 169- vect-length dest + dw PGROUP:vec_fill ; 170- vect-fill vect,val + dw not_yet ; 171- make-pack-vect len,bits/elem,signed? + dw s_disply ; 172- %substr-display str,start,end,row,wind + dw not_op ; 173- (unused) + dw set_tim ; 174- %start-timer src=ticks + dw rst_tim ; 175- %stop-timer dest=ticks remaining + + dw popen ; 176- open-port filename,mode + dw pclose ; 177- close-port port + dw PGROUP:spprin1 ; 178- prin1 obj,port + dw PGROUP:spprinc ; 179- princ obj,port + dw PGROUP:spprint ; 180- print obj,port + dw PGROUP:spnewlin ; 181- newline port + dw recompil ; 182- (unused) formerly read + dw recompil ; 183- (unused) formerly file-exists? + + dw PGROUP:prt_len ; 184- print-length obj + dw recompil ; 185- (unused) formerly current-column + dw PGROUP:srd_line ; 186- read-line dest=src (src={port}) + dw PGROUP:srd_atom ; 187- read-atom dest=src (src={port}) + dw PGROUP:read_cha ; 188- read-char dest=src + dw PGROUP:trns_chg ; 189- %transcript src + dw PGROUP:rd_ch_rd ; 190- read-char-ready? dest=src + dw sfasl ; 191- fasl string + + dw PGROUP:ch_eq_p ; 192- char= char1,char2 + dw PGROUP:ch_eq_ci ; 193- char-equal? char1,char2 + dw PGROUP:ch_lt_p ; 194- char< char1,char2 + dw PGROUP:ch_lt_ci ; 195- char-less? char1,char2 + dw PGROUP:ch_up ; 196- char-upcase char + dw PGROUP:ch_down ; 197- char-downcase char + dw str_lng ; 198- string-length string + dw PGROUP:st_ref ; 199- string-ref string,index + + dw PGROUP:st_set ; 200- string-set! string,index,char + dw PGROUP:make_str ; 201- make-string length,char + dw PGROUP:str_fill ; 202- string-fill! string,char + dw str2sym ; 203- string->symbol string + dw str2usym ; 204- string->uninterned-symbol string + dw sym2str ; 205- symbol->string symbol + dw srch_nx ; 206- srch-next str,start,end,charset + dw srch_pr ; 207- srch-prev str,start,end,charset + + dw PGROUP:make_win ; 208- make-window label + dw set_w_at ; 209- set-wind-attr wind,attr,value + dw PGROUP:get_wind ; 210- get-wind-attr wind,attr + dw clr_wind ; 211- clear-window wind + dw PGROUP:save_win ; 212- save-window wind + dw PGROUP:rest_win ; 213- restore-wind wind + dw s_append ; 214- %str-append R(d=s1),R(s2),...,R(s7) + dw PGROUP:sgraph ; 215- %graphics R(s1),R(s2),...,R(s7) + + dw sreify ; 216- %reify R(s1=d),R(s2) ;obj,indx + dw PGROUP:mk_env ; 217- mk-env R(d) + dw PGROUP:env_par ; 218- env-par R(d=s1) ; s1=env + dw PGROUP:env_lu ; 219- env-lu R(d=s1),R(s2) ; sym,env + dw PGROUP:def_env ; 220- def-env R(d=s1),R(s2),R(s3) sve + dw PGROUP:push_env ; 221- push-env C(s1) ; s1=list of syms + dw PGROUP:drop_env ; 222- drop-env + dw PGROUP:ld_env ; 223- ld-env R(d),C(s1) ; s1=symbol + + dw PGROUP:st_env ; 224- st-env R(d=s1),C(s2) ; val,sym + dw PGROUP:set_gnv ; 225- set-glob-env! R(s1) ; s1=env + dw sreifyb ; 226- %reify! R(s1),R(s2),R(s3);o,i,v + dw obj_hash ; 227- object-hash R(d=s1) + dw obj_unhs ; 228- object-unhash R(d=s1) + dw reify_s ; 229- reify-stack R(d=s1) + dw reify_sb ; 220- reify-stack! R(s1),R(s2) + dw sfpos ; 231- set-file-position! + + dw s_esc1 ; 232- %esc1 R(d=s1) + dw s_esc2 ; 233- %esc2 R(d=s1),R(s2) + dw s_esc3 ; 234- %esc3 R(d=s1),R(s2),R(s3) + dw s_esc4 ; 235- %esc4 R(d=s1),R(s2),...,R(s4) + dw s_esc5 ; 236- %esc5 R(d=s1),R(s2),...,R(s5) + dw s_esc6 ; 237- %esc6 R(d=s1),R(s2),...,R(s6) + dw s_esc7 ; 238- %esc7 R(d=s1),R(s2),...,R(s7) + dw xesc ; 239- %xesc R(d=s1),R(len), + ; R(arg1),...,R(arg16); + ; all R(argn) are optional + + dw not_op ; 240- (unused) + dw not_op ; 241- (unused) + dw not_op ; 242- (unused) + dw not_op ; 243- (unused) + dw not_op ; 244- (unused) + dw not_op ; 245- (unused) + dw not_op ; 246- (unused) + dw sgc2 ; 247- gc-with-compaction + + dw exit_op ; 248- halt=(exit) [return to MS-DOS] + dw gc ; 249- %garbage-collect + dw ptyme ; 250- %internal-time dest + dw reset ; 251- reset + dw s_reset ; 252- scheme-reset + dw clr_regs ; 253- %clear-registers + dw not_op ; 254- (reserved for escape) + dw debug_op ; 255- %begin-debug + +reset_BP dw 0 ; initial value of BP for reset purposes + +zero_reg dw 0,SPECFIX*2 ; a "register" containing a fixnum 0 +zero_adr dw zero_reg ; the address of "zero_reg" (for pushing) +m_one dw 1 ; a constant "one" (1) +m_zerodv dw ZERO_DIVIDE_ERROR ; error code for division by zero + +m_not_op db "[VM INTERNAL ERROR] Undefined opcode",LF,0 +m_cod_er db "[VM INTERNAL ERROR] %x:%04x isn't a code base",LF,0 +m_not_yt db "[VM INTERNAL ERROR] Feature not implemented",LF,0 +m_recomp db "[VM ERROR encountered!] Object module incompatible with " + db "this Version",LF,"Recompile from Source",LF,0 + +;;;m_il_st db "[VM ERROR encountered!] VECTOR-SET! operand is write " +;;; db "protected",LF,0 +;;;m_deref db "DEREF",0 +m_ld_r db "LD_R",0 +m_st_r db "ST_R",0 +;;;m_setref db "SET_REF!",0 +;;;m_swaprf db "SWAP_REF!",0 +m_revb db "REVERSE!",0 +m_even db "EVEN?",0 +m_odd db "ODD?",0 +m_v_ld db "VECTOR-REF",0 +m_v_st db "VECTOR-SET!",0 +m_DIV db "/",0 +m_MODULO db "REMAINDER",0 +m_QUOTNT db "QUOTIENT",0 +m_VOE dw VECTOR_OFFSET_ERROR ; error number for "offset out of range" +masc_ch db "INTEGER->CHAR",0 +mch_asc db "CHAR->INTEGER",0 +m_bckwrd db "[VM INTERNAL ERROR] sinterp: instruction preceding %x:%04x " + db "set direction flag",LF,0 +m_reg0 db "[VM INTERNAL ERROR] sinterp: instruction preceding %x:%04x " + db "clobbered register",LF,0 +;;;m_bad_st db "[VM INTERNAL ERROR] sinterp: instruction preceding %x:%04x " +;;; db "screwed up the stack",LF,0 +IFNDEF PROMEM +m_graph db "%GRAPHICS",0 +ENDIF +m_esc db "%ESCN",0 + +; XLI errors (numbered from 1, not 0) +xli_err dw 0 ;this spot unused + dw 0,xli_err2 ;other 0's no longer used spots + dw 0,xli_err4,xli_err5,xli_err6 + dw xli_err7,xli_err8,xli_err9,xli_err10,xli_err11,xli_err12 + dw xli_err13,xli_err14,xli_err15,xli_err16 +; XLI fatal errors print via print_and_exit +;xli_err1 db '[VM FATAL ERROR] Unable to determine length of %XESC VM instruction',LF,0 +; XLI normal errors print via sch_err as secondary line to [VM ERROR ...] message +xli_err2 db '[XLI] First argument to XCALL is not string or symbol',0 +;xli_err3 db '[XLI] Improper number of arguments given to XCALL',0 +xli_err4 db '[XLI] An argument to XCALL is invalid',0 +xli_err5 db '[XLI] The return value of XCALL is invalid',0 +xli_err6 db '[XLI] The function requested by XCALL is not available',0 +xli_err7 db '[XLI] Number too large to fit in 32 bits',0 +xli_err8 db '[XLI] Sync error',0 +xli_err9 db '[XLI] Error in releasing memory of external program',0 +xli_err10 db '[XLI] No memory is available for external program',0 +xli_err11 db '[XLI] Error in loading external program',0 +xli_err12 db '[XLI] No more external programs can be loaded',0 +xli_err13 db '[XLI] File to load not found',0 +xli_err14 db '[XLI] Number too large to fit in 16 bits',0 +xli_err15 db '[XLI] Version mismatch',0 +xli_err16 db '[XLI] Error reported by external program',0 + +IFDEF PROMEM +; +; Following definitions are for protected mode engines. They will be +; used in eng_next1, settimer, and rsttimer defined later in this +; module. +; +tickstat db -1 ;status of engine (0=timeout,1=running,-1=none) +lo_time dw ? ;timer ticks (per vm instuction executed) +hi_time dw ? +ENDIF + +data ends + + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +; Interpreter support routines defined in "scar_cdr.asm" + extrn ld_car:near + extrn ld_cdr:near + extrn ld_car1:near + extrn ld_cdr1:near + extrn ld_caar:near + extrn ld_cadr:near + extrn ld_cdar:near + extrn ld_cddr:near + extrn ld_caaar:near + extrn ld_caadr:near + extrn ld_cadar:near + extrn ld_caddr:near + extrn ld_cdaar:near + extrn ld_cdadr:near + extrn ld_cddar:near + extrn ld_cdddr:near + extrn ld_caddd:near + extrn set_car:near + extrn set_cdr:near + extrn s_cons:near + extrn s_list:near ; (list obj) + extrn list2:near ; (list a b) + extrn appendb:near ; (append! a b) + extrn l_tail:near ; (list-tail list count) + +; Interpreter support routines defined in "sstack.asm" + extrn set_pos:far ; set-file-position! + +; Interpreter support routines defined in "sstack.asm" + extrn spush:near ; push register contents onto Scheme stack + extrn spop:near ; pop into register from Scheme stack + extrn sdrop:near ; drop elements from top of Scheme stack + extrn ld_local:near ; load from local stack frame + extrn st_local:near ; store into local stack frame + extrn ld_lex:near ; load from higher level stack frame + extrn st_lex:near ; store into higher level stack frame + extrn call_lcl:near ; local call + extrn call_ltr:near ; local call, tail recursive + extrn call_clo:near ; call closure object + extrn call_ctr:near ; call closure object, tail recursive + extrn call_cc:near ; local call/cc + extrn cl_cctr:near ; local call/cc, tail recursive + extrn clcc_c:near ; call/cc, closure object + extrn clcc_ctr:near ; call/cc, closure object, tail recursive + extrn apply:near ; apply closure object + extrn apply_tr:near ; apply closure object, tail recursive + extrn execute:near ; execute code block + extrn s_exit:near ; exit procedure + extrn cr_close:near ; create closure + + extrn force_ca:near ; entry point to force call (to debugger) + +; Interpreter support routines defined in "svars.asm" + extrn ld_fluid:near ; load value of fluid variable + extrn ld_fl_r:near ; load value of fluid variable - reg source + extrn st_fluid:near ; store value into fluid variable + extrn bind_fl:near ; bind fluid variable + extrn unbind_f:near ; unbind fluid variables + extrn fluid_p:near ; fluid-bound? predicate + extrn vec_allo:near ; allocate vector + extrn vec_size:near ; vector-size + extrn vec_fill:near ; vector-fill + extrn memq:near ; memq + extrn memv:near ; memv + extrn member:near ; member + extrn assq:near ; assq + extrn assv:near ; assv + extrn assoc:near ; assoc + +; Interpreter support routines defined in "sstring.asm" + extrn ch_eq_p:near ; (char= char1 char2) + extrn ch_eq_ci:near ; (char-equal? char1 char2) + extrn ch_lt_p:near ; (char< char1 char2) + extrn ch_lt_ci:near ; (char-less? char1 char2) + extrn ch_up:near ; (char-upcase char) + extrn ch_down:near ; (char-downcase char) + extrn make_str:near ; (make-string len char) + extrn str_fill:near ; (string-fill! string char) + extrn st_ref:near ; (string-ref string index) + extrn st_set:near ; (string-set! string index char) + +; Interpreter support routines defined in "senv.asm" + extrn env_p:near ; (environment? obj) + extrn mk_env:near ; (make-environment) + extrn env_par:near ; (environment-parent env) + extrn env_lu:near ; (environment-lookup sym env) + extrn def_env:near ; (define symbol value env) + extrn push_env:near ; (push-environment list) + extrn drop_env:near ; (drop-environment) + extrn hash_env:near ; (make-hashed-environment) + extrn ld_env:near ; (load-env symbol) + extrn st_env:near ; (store-env value symbol) + extrn set_gnv:near ; (set-global-env! env) + extrn ld_globl:near ; load value of global variable + extrn ld_globr:near ; load value of global variable - reg source + extrn st_globl:near ; store value into global variable + extrn define:near ; define! value for global variable + +; Interpreter support routines defined in "sobjhash.asm" + extrn obj_hash:near ; (object-hash obj) + extrn obj_unhs:near ; (object-unhash obj) + +; Interpreter support routines defined in "cwindow.asm" + extrn make_win:near ; (make-window label) + extrn get_wind:near ; (get-window-attribute port attribute) + extrn save_win:near ; (window-save-contents port) + extrn rest_win:near ; (window-restore-contents port contents) + extrn trns_chg:near ; (transcript-on "filename") + extrn rd_ch_rd:near ; (read-char-ready? port) + extrn read_cha:near ; (read-char port) + +; Interpreter support routines defined in "cread.asm" + extrn srd_line:near ; (read-line port) + extrn srd_atom:near ; (read-atom port) + +; Interpreter support routines defined in "cprint.asm" + extrn spprin1:near + extrn spprinc:near + extrn spprint:near + extrn spnewlin:near + extrn prt_len:near + +; XLI + extrn xli_xesc:near ; XLI xesc handler +; extrn print_an:near ; fatal errors + +IFDEF PROMEM +; GRAPHICS - protected mode scheme graphics handler in PROIO.ASM + extrn sgraph:near ;Handle %graphics primitives +ENDIF + +; Entry point to force debug mode prior to next VM instruction + public force_de +force_de: mov AX,word ptr CS:trc_forc + STORE_WORD_IN_CS PROG,next1,AX ; Protected Mode Macro + ret + +IFNDEF PROMEM +; Entry point to force a timeout prior to next VM instruction. This +; will be called from the tick routine in STIMER.ASM. Protected +; mode scheme doesn't use this, as it counts vm instructions as +; engine ticks. +; + public force_ti +force_ti: mov AX,word ptr CS:tim_forc + XCHG_WORD_IN_CS PROG,next1,AX ;Protected Mode Macro + STORE_WORD_IN_CS PROG,reset_tim,AX ;Protected Mode Macro + ret +ENDIF + +; Entry point to process shift-break prior to next VM instruction + public shft_brk +dbg_addr dw VM_debug ; address of the variable VM_debug + dw DGROUP ; DGROUP segment address +sbrk_adr dw s_break ; address of the variable s_break +reset_sb dw 0 +shft_brk: push ES ; save the current ES + les SI,dword ptr CS:dbg_addr ; load the long address for VM_debug + mov DI,CS:sbrk_adr ; load address for s_break + inc word ptr ES:[DI] ; and increment shift-break flag + cmp word ptr ES:[SI],0 ; are we in VM_debug mode? + pop ES ; restore ES + jne force_de ; if we're in VM_debug mode, jump + mov AX,word ptr CS:shft_nxt ; else, force a trap to the debugger + cmp AX,word ptr CS:next1 ; Shift-Brk already depressed? + je shft_brt ; if a duplicate request, skip it + XCHG_WORD_IN_CS PROG,next1,AX ; else enter scheme debugger on + STORE_WORD_IN_CS PROG,reset_sb,AX ; next vm instruction +shft_brt: ret ; continue processing + + public run,interp +run proc near + mov AX,word ptr CS:next_go1 ; modify interpreter loop to disable + STORE_WORD_IN_CS PROG,next1,AX ; instruction level trace capability +interp: push BP + sub SP,offset sint_BP + mov BP,SP + mov reset_BP,BP ; save initial value of BP for reset + +; Set up initial interpreter parameters + mov [BP].C_ES,ES + mov SI,[BP].cod_ent ; load address of entry point offset + mov SI,[SI] ; and load PC + mov BX,CB_pag ; load code base page number + cmp ptype+[BX],CODETYPE*2 ; if page doesn't contain code, + jne code_err ; we've got an error + LoadCode ES,BX ; load code page paragraph addr +; mov ES,pagetabl+[BX] ; load code page paragraph addr + mov [BP].save_ES,ES ; and save it off + jmp next ; jump to start of interpreter +; ***error-- invalid code base-- not a code page*** +code_err: ; push the ptr's disp, page no, and + mov AX,offset DGROUP:m_cod_er ; address of message + pushm + C_call printf ; print error message + jmp debug ; begin debug mode + +trc_oops: cld ; clear direction * checking code + lea BX,m_bckwrd ; * (see below) + jmp short trc_err ; * + +trc_reg0: lea BX,m_reg0 +trc_err: mov AX,CB_pag ; R0 not nil-- print error message + corrpage AX + pushm + C_call printf,,Load_ES + restore + jmp debug + +;**bad_stk: +;** lea BX,m_bad_st ; inconsistent runtime stack error +;** jmp short trc_err + +next_tr1: + dec [BP].no_insts ; decrement count of instructions to run + jge next_go ; if not zero, continue decoding + jmp exit ; out of instructions-- return to debugger +next_go1 equ $ +next_go: xor AX,AX ; Clear high order byte of AX + + mov BX,SI ;* These instructions check to make + xor SI,SI ; * sure that the direction flag is set + lodsb ; * in the forward direction. If not, + cmp SI,1 ; * the "lods" in the interpreter will + mov SI,BX ; * decrement the location pointer + jne trc_oops ;* instead of incrementing it. + + cmp reg0_pag,NIL_PAGE*2 ;* + jne trc_reg0 ; * These instructions check to + cmp reg0_dis,NIL_DISP ; * make sure R0 contains nil (by + jne trc_reg0 ;* convention) + + cmp page0,0 ;* + jne trc_reg0 ; * + cmp page0+2,0 ; * Verify that the location for + jne trc_reg0 ; * the null pointer (page 0, offset 0) + cmp page0+4,0 ; * is still (cons '() '()) + jne trc_reg0 ;* + +; Validate the contents of each of the Scheme registers + mov CX,NUM_REGS+4 ; load number of regsiter into CX (counter) +; Note: also checks GNV_reg, FNV_reg, CB_reg, and tmp_reg + mov DI,offset reg0 ; address of register 0 + mov DX,nextpage ; load number of pages allocated +more_reg: mov AX,[DI].C_page ; load page number field of next register + cmp AX,SPECFIX*2 ; does register contain a fixnum? + je off_ok ; if so, skip offset check (jump) + cmp AX,SPECCHAR*2 ; does register contain a character? + je off_ok ; if so, skip offset check (jump) + mov BX,AX ; copy page number (times 2) into BX + ror AX,1 ; divide by 2, LSB to sign position + cmp AX,DX ; is page number too large? + jae trc_reg0 ; if too large or odd, error (jump) + mov AX,[DI].C_disp ; load displacement field from register + cmp AX,psize+[BX] ; is offset too big? + jae trc_reg0 ; if offset too big, error (jump) +off_ok: add DI,size C_ptr ; increment register offset + loop more_reg ; continue testing all registers + +;** Test consistency of Scheme's runtime stack +;** mov BX,FP ; load current stack frame pointer +;** cmp BX,0 +;** je stk_ok +;**more_stk: +;** mov AL,S_stack+[BX] ; load return address code base page number +;** mov DI,AX +;** cmp byte ptr ptype+[DI],CODETYPE*2 ; is this a code block? +;** jne bad_stk ; if not, bad dynamic link +;** cmp byte ptr S_stack+[BX]+6,SPECFIX*2 ; is dynamic link a fixnum? +;** jne bad_stk ; if not, bad dynamic link +;** mov BX,word ptr S_stack+[BX]+7 ; load pointer to caller's FP +;** sub BX,BASE ; inside current stack buffer? +;** ja more_stk ; if so, continue testing (jump) +;**stk_ok: + + xor AX,AX ; clear TIPC register AX + lods byte ptr ES:[SI] ; Fetch next instruction's opcode + mov BX,AX + shl BX,1 ; Multiply opcode by two for use as index + jmp op_table+[BX] + + +trc_go equ $ + jmp short $+(next_trc-next1) ; jump to overwrite "next" for debug +next_trc: jmp next_tr1 + +tim_forc equ $ + jmp short $+(next_tim-next1) ; jump to force debug mode +next_tim: jmp timeout ; Force execution into debug mode + +trc_forc equ $ + jmp short $+(next_dbg-next1) ; jump to force debug mode +next_dbg: jmp debug ; Force execution into debug mode + +shft_nxt equ $ + jmp short $+(next_sb-next1) ; jump to force Scheme debug mode +next_sb : jmp sc_debug ; Force execution into Scheme debug mode + +IFDEF PROMEM +; +; The following code is for use by engines under protected mode scheme. +; We had a problem collecting timer interrupts from AI Architects OSx86, +; so I just implemented a different interpreter loop which decrements +; a timer tick upon each vm instruction. +; +; Note: this code must be within 128 bytes of next1 (below) so that a +; short jump can be performed. + +eng_tick equ $ + jmp short $+(eng_next1-next1) ; jump to engine loop + +eng_next1: + sub lo_time,1 ;decrement engine tick + sbb hi_time,0 ;if not zero + jnz eng_next2 ; continue + cmp lo_time,0 + jnz eng_next2 + mov tickstat,0 ;zero counter, record timeout + jmp timeout ;force timeout condition +eng_next2: + xor ax,ax ;clear high order byte of ax + lods byte ptr es:[si] ;fetch next instruction's opcode + mov bx,ax + shl bx,1 ;make into index + jmp op_table+[bx] ;go execute the vm instruction code +ENDIF + +; +; Following is the main vm interpreter loop. Note that the location at +; next1 can (and will be) code modified to jump into the debugger, a +; trace loop, and a loop for handling engines in protected mode. +; + public next_SP,next_PC,next +next_SP: mov SP,BP ; Restore SP after call +next_PC: les SI,dword ptr [BP].save_SI ; Reload interpreter's PC & ES +next: +next1 equ $ + xor AX,AX ; Clear high order byte of AX + lods byte ptr ES:[SI] ; Fetch next instruction's opcode + mov BX,AX + shl BX,1 ; Multiply opcode by two for use as index + jmp op_table+[BX] ; go execute the vm instruction code + + +; Jump if nil, short JNILS reg,offset +j_nil_s: lods word ptr ES:[SI] ; load operand, offset + mov BL,AL ; copy register number + cmp byte ptr reg0_pag+[BX],0 ; test for null pointer + jne next ; Jump if not nil + mov AL,AH + cbw ; Sign extend short displacement + add SI,AX ; Add jump offset to current PC + jmp next ; Return to interpreter + +; Jump if not nil, short JNNILS reg,offset +j_nnil_s: lods word ptr ES:[SI] ; load operand, offset + mov BL,AL ; copy register number + cmp byte ptr reg0_pag+[BX],0 ; test for null pointer + je next ; Jump if nil + mov AL,AH + cbw ; Sign extend short displacement + add SI,AX ; Add jump offset to current PC + jmp next ; Return to interpreter + +; Jump if atom,short JATOMS reg,offset +j_atm_s: lods word ptr ES:[SI] ; Load register, offset + mov BL,AL ; copy register number to test + test attrib+[BX],ATOM ; test for atom attribute + jz next ; if not atom, return to interpreter + mov AL,AH ; position branch offset and + cbw ; sign extend to 16 bits + add SI,AX ; add jump offset to current PC + jmp next ; return to interpreter + +; Jump if not atom,short JNATOMS reg,offset +j_natm_s: lods word ptr ES:[SI] ; Load register, offset + mov BL,AL ; copy register number to test + test attrib+[BX],ATOM ; test for atom attribute + jnz next ; if atom, return to interpreter + mov AL,AH ; position branch offset and + cbw ; sign extend to 16 bits + add SI,AX ; add jump offset to current PC + jmp next ; return to interpreter + +; Jump if eq?, short JEQS src1,src2,offset +j_eq_s: lods word ptr ES:[SI] ; load registers to compare + mov BL,AH + mov DI,BX + add DI,offset reg0 ; compute address of src2 + mov BL,AL ; copy src1 register number + lods byte ptr ES:[SI] ; load branch displacement, + cbw ; sign extend, + mov CX,AX ; and save it + mov AX,reg0_dis+[BX] + cmp AX,[DI].C_disp ; are displacements eq? + jne next +j_eq_s1: mov AL,byte ptr reg0_pag+[BX] + cmp AL,byte ptr [DI].C_page ; are page numbers eq? + jne j_eq_nxt + add SI,CX ; add offset to current PC +j_eq_nxt: jmp next + +; Jump if not eq?, short JNEQS src1,src2,offset +j_neq_s: lods word ptr ES:[SI] ; load registers to compare + mov BL,AH + mov DI,BX + add DI,offset reg0 ; compute address of src2 + mov BL,AL ; copy src1 register number + lods byte ptr ES:[SI] ; load branch displacement, + cbw ; sign extend, + mov CX,AX ; and save it + mov AX,reg0_dis+[BX] + cmp AX,[DI].C_disp ; are displacements eq? + jne j_neq_s2 +j_neq_s1: mov AL,byte ptr reg0_pag+[BX] + cmp AL,byte ptr [DI].C_page ; are page numbers eq? + je j_neq_s3 +j_neq_s2: add SI,CX ; add offset to current PC +j_neq_s3: jmp next + +; Jump if eq?, long JEQL src1,src2,offset +j_eq_l: lods word ptr ES:[SI] ; load registers to compare + mov BL,AH + mov DI,BX + add DI,offset reg0 ; compute address of src2 + mov BL,AL ; copy src1 register number + lods word ptr ES:[SI] ; load branch displacement + mov CX,AX ; and save same + mov AX,reg0_dis+[BX] + cmp AX,[DI].C_disp ; are displacements eq? + je j_eq_s1 ; if eq?, continue testing + jmp next ; otherwise, back to interpreter + +; Jump if not eq?, long JNEQL src1,src2,offset +j_neq_l: lods word ptr ES:[SI] ; load registers to compare + mov BL,AH + mov DI,BX + add DI,offset reg0 ; compute address of src2 + mov BL,AL ; copy src1 register number + lods word ptr ES:[SI] ; load branch displacement + mov CX,AX ; and save same + mov AX,reg0_dis+[BX] + cmp AX,[DI].C_disp ; are displacements eq? + je j_neq_s1 ; if equal, continue test + add SI,CX ; add offset to current location pointer + jmp next ; back to the interpreter + +; Jump if nil, long JNILL reg,offset +j_nil_l: lods byte ptr ES:[SI] ; Load the register to test + mov BL,AL ; copy register number + lods word ptr ES:[SI] ; load branch offset + cmp byte ptr reg0_pag+[BX],0 ; Test for null pointer + jne j_nil_l1 ; Jump if not nil + add SI,AX ; Add jump offset to current PC +j_nil_l1: jmp next ; Return to interpreter + +; Jump if not nil, long JNNILL reg,offset +j_nnil_l: lods byte ptr ES:[SI] ; Load the register to test + mov BL,AL ; copy register number + lods word ptr ES:[SI] ; load branch offset + cmp byte ptr reg0_pag+[BX],0 ; Test for null pointer + je j_nnil_1 ; if nil, return to interpreter + add SI,AX ; Add jump offset to current PC +j_nnil_1: jmp next ; Return to interpreter + +; Jump if atom,long JATOMS reg,offset +j_atm_l: lods byte ptr ES:[SI] ; Load register to test + mov BL,AL ; copy register number to test + lods word ptr ES:[SI] ; load branch offset + test attrib+[BX],ATOM ; test for atom attribute + jz j_atm_l1 ; if not atom, return to interpreter + add SI,AX ; add jump offset to current PC +j_atm_l1: jmp next ; return to interpreter + +; Jump if not atom,long JNATOMS reg,offset +j_natm_l: lods byte ptr ES:[SI] ; Load register to test + mov BL,AL ; copy register number to test + lods word ptr ES:[SI] ; load branch offset + test attrib+[BX],ATOM ; test for atom attribute + jnz j_natm_1 ; if atom, return to interpreter + add SI,AX ; add jump offset to current PC +j_natm_1: jmp next ; return to interpreter + +; Jump unconditionally, short +jmp_shrt: lods byte ptr ES:[SI] + cbw ; sign extend the byte offset + add SI,AX + jmp next + +; Jump unconditionally, long +jmp_long: lods word ptr ES:[SI] + add SI,AX + jmp next + +; Move register to register: COPY dest,src +copy: lods word ptr ES:[SI] ; load regs, increment PC + mov BL,AH ; copy source register number into + mov DI,BX ; DI (clear high byte) + mov BL,AL ; copy destination register number + mov AX,reg0_dis+[DI] + mov reg0_dis+[BX],AX + mov AL,byte ptr reg0_pag+[DI] + mov byte ptr reg0_pag+[BX],AL + jmp next + +;************************************************************************ +;* AL AH * +;* Load constant from constant's area LD-CONST dest,const * +;* * +;* Purpose: Interpreter support for loading a compile time constant * +;* into a register of the Scheme virtual machine. * +;************************************************************************ +ld_const: lods word ptr ES:[SI] ; load dest reg and constant number + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI + mov BL,AH ; isolate constant number + mov AX,BX ; BX <- constant number * 3 + shl AX,1 + add BX,AX + add BX,CB_dis ; add displacement to start of code block + mov AL,ES:[BX].cod_cpag + mov byte ptr reg0_pag+[DI],AL + mov AX,ES:[BX].cod_cdis + mov reg0_dis+[DI],AX + jmp next + +;************************************************************************ +;* AL AH * +;* Load immediate value LD-IMM dest,imm * +;* * +;* Purpose: Interpreter support for loading an immediate value * +;* into a register of the Scheme virtual machine. * +;************************************************************************ +ld_imm: lods word ptr ES:[SI] ; load dest reg, immediate value + mov BL,AL ; copy the destination register number + mov AL,AH ; isolate and sign extend the + cbw ; immediate value + sal AX,1 ; clear high order byte of immediate + shr AX,1 ; value, and + mov reg0_dis+[BX],AX ; store it + mov byte ptr reg0_pag+[BX],SPECFIX*2 ; set reg tag=fixnum + jmp next + +;************************************************************************ +;* Load nil ld-nil dest * +;* * +;* Purpose: Scheme interpreter support to load the value "nil" into * +;* a VM register * +;************************************************************************ +ld_nil: lods byte ptr ES:[SI] ; load destination register number + mov BX,AX + xor AX,AX + mov byte ptr reg0_pag+[BX],AL ; store value of 'nil into + mov reg0_dis+[BX],AX ; destination register + jmp next ; back to the interpreter + + +;************************************************************************ +;* Macro Support for Vector Load * +;************************************************************************ +vec_load macro ld_type + local y,z +IFIDN , + mov DX,4 ; record length of this instruction + lods byte ptr ES:[SI] ; load vector pointer/destination reg + mov DI,AX ; copy pointer to TIPC register DI + lods word ptr ES:[SI] ; load fullword offset + jmp short ld_v_go1 ; continue processing +ELSE + lods word ptr ES:[SI] ; load vect pointer, offset operands + mov BL,AL ; copy vector pointer/destination reg + mov DI,BX ; number into TIPC register DI +IFIDN , + mov AL,AH ; convert immediate byte offset to + cbw ; a fullword value + jmp short ld_v_go ; continue processing +ELSE +IFIDN , + mov BL,AH ; copy number of index register + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; index a fixnum? + jne z ; if not, error (jump) + mov AX,reg0_dis+[BX] ; load immediate value from index register + shl AX,1 ; sign extend 15 bit immediate + sar AX,1 +ld_v_go: mov DX,3 ; record length of this instruction +ld_v_go1: save ; save current location pointer + mov CX,AX ; multiply the index value by 3 + shl AX,1 ; (3 bytes/element) + add AX,CX + jl y + mov BL,byte ptr reg0_pag+[DI] ; load page number for vector ptr + cmp byte ptr ptype+[BX],VECTTYPE*2 ; does it point to a vector? + jne z ; if not, error (jump) + LoadPage ES,BX ; load paragraph address for vector's page +; mov ES,pagetabl+[BX] ; load paragraph address for vector's page + mov SI,reg0_dis+[DI] ; load vector offset + add AX,offset vec_data ; add offset of 1st vector element + cmp AX,ES:[SI].vec_len ; is reference within bounds? + jge y ; if not, error (jump) + add SI,AX ; add index to vector offset + mov AL,ES:[SI].car_page ; copy vector element to destination + mov byte ptr reg0_pag+[DI],AL ; register + mov AX,ES:[SI].car + mov reg0_dis+[DI],AX + jmp next_PC ; return to the interpreter +; ***error-- offset out of bounds*** +y: mov AX,offset m_v_ld +vbad_off: restore ; restore the location pointer + sub SI,DX ; and back it up to start of instruction + pushm ; push LP and "VECTOR-REF/SET!" text as args + C_call disassem,,Load_ES ; disassemble instruction for *irritant* + pushm ; push numeric error parameters + C_call set_nume + restore ; reload next instruction's address + jmp sch_err ; link to Scheme debugger +; ***error-- invalid operand to vector-load instruction*** +z: lea BX,m_v_ld + jmp src_err ; display error message +ELSE + ***error*** bad macro operand +ENDIF +ENDIF +ENDIF + endm + +;************************************************************************ +;* AL AH * +;* Vector Load with short offset LD-VEC-S vect,offset * +;* * +;* Purpose: Scheme interpreter support for vector load instructions * +;* with short offset fields * +;************************************************************************ +ld_off_s: vec_load SHORT + +;************************************************************************ +;* AL AX * +;* Vector Load with long offset LD-VEC-L vect,offset * +;* * +;* Purpose: Scheme interpreter support for vector load instructions * +;* with long offset fields * +;************************************************************************ +ld_off_l: vec_load LONG + +;************************************************************************ +;* AL AH * +;* Vector Load with register offset LD-VEC-R vect,offset * +;* * +;* Purpose: Scheme interpreter support for vector load instructions * +;* with register offset fields * +;************************************************************************ +ld_off_r: vec_load REG + + purge vec_load + +;************************************************************************ +;* Macro Support for Vector Store * +;************************************************************************ +vec_st macro st_type + local x,y,z +IFIDN , + mov [BP].save_DX,5 ; record length of this instruction + lods byte ptr ES:[SI] ; load vector pointer register + mov DI,AX ; copy pointer to TIPC register DI + lods word ptr ES:[SI] ; load fullword offset + jmp short st_v_go1 ; continue processing +ELSE + lods word ptr ES:[SI] ; load vector pointer, offset operand + mov BL,AL ; copy vector pointer register + mov DI,BX ; number into TIPC register DI +IFIDN , + mov AL,AH ; convert immediate byte offset to + cbw ; a fullword value + jmp short st_v_go ; continue processing +ELSE +IFIDN , + mov BL,AH ; copy number of index register + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; index a fixnum? + jne z ; if not, error (jump) + mov AX,reg0_dis+[BX] ; load immediate value from index register + shl AX,1 ; sign extend 15 bit immediate + sar AX,1 +st_v_go: mov [BP].save_DX,4 +st_v_go1: mov CX,AX ; save index value in TIPC register CX + lods byte ptr ES:[SI] ; load source register number + save ; save current location pointer + xor DX,DX ; save the source register number in + mov DL,AL ; TIPC register DX + mov AX,CX ; multiply the index value by 3 + shl AX,1 ; (3 bytes/element) + add AX,CX + jl y + mov BL,byte ptr reg0_pag+[DI] ; load page number for vector ptr + cmp byte ptr ptype+[BX],VECTTYPE*2 ; does it point to a vector? + jne z ; if not, error (jump) +;;; test attrib+[BX],READONLY ; is vector's page write protected? +;;; jnz x ; if write protected, error (jump) + LoadPage ES,BX ; load paragraph address for vector's page +; mov ES,pagetabl+[BX] ; load paragraph address for vector's page + mov SI,reg0_dis+[DI] ; load vector offset + add AX,offset vec_data ; add in offset of 1st vector element + cmp AX,ES:[SI].vec_len ; is reference within bounds? + jge y ; if not, error (jump) + add SI,AX ; add index to vector offset + mov DI,DX ; copy source regsiter number into DI + mov AL,byte ptr reg0_pag+[DI] ; copy contents of source register + mov ES:[SI].car_page,AL ; into the element of the vector + mov AX,reg0_dis+[DI] + mov ES:[SI].car,AX + jmp next_PC ; return to the interpreter +;;;; ***error-- write protection violation*** +;;;x: error +; ***error-- offset out of bounds*** +y: restore + mov AX,offset m_v_st + jmp vbad_off +; ***error-- invalid operand to vector-load instruction*** +z: lea BX,m_v_st + jmp src_err ; display error message +ELSE + ***error*** bad macro operand +ENDIF +ENDIF +ENDIF + endm + +;************************************************************************ +;* AL AH AL * +;* Vector Store with short offset ST-VEC-S vect,offset,src * +;* * +;* Purpose: Scheme interpreter support for vector store instructions * +;* with short offset fields * +;************************************************************************ +st_off_s: vec_st SHORT + +;************************************************************************ +;* AL AX AL * +;* Vector Store with long offset ST-VEC-L vect,offset,src * +;* * +;* Purpose: Scheme interpreter support for vector store instructions * +;* with long offset fields * +;************************************************************************ +st_off_l: vec_st LONG + +;************************************************************************ +;* AL AH AL * +;* Vector Store with register offset ST-VEC-R vect,offset,src * +;* * +;* Purpose: Scheme interpreter support for vector store instructions * +;* with register offset fields * +;************************************************************************ +st_off_r: vec_st REG + + purge vec_st + + +;;;; Load from reference cell DEREF dest +;;;deref: lods byte ptr ES:[SI] ; fetch operand, increment location pointer +;;; mov DX,ES ; save TIPC register ES +;;; mov BX,AX ; move destination register field and +;;; add BX,offset reg0 ; and compute destination reg address +;;; mov DI,[BX].C_page ; load source reg page number +;;; cmp byte ptr ptype+[DI],REFTYPE*2 ; does page contain ref cells? +;;; jne not_ref ; if not, jump (must be reference type) +;;; mov ES,pagetabl+[DI] ; load page's paragraph address +;;; mov DI,[BX].C_disp ; load source displacement into page +;;; mov AX,ES:[DI].car ; load disp at source location +;;; mov [BX].C_disp,AX ; store into destination register +;;; mov AL,ES:[DI].car_page ; load page number at source location +;;; mov byte ptr [BX].C_page,AL ; store into destination register +;;; mov ES,DX ; restore TIPC register ES (code block para) +;;; jmp next ; branch back to interpreter +;;;; error-- object of ref not a reference cell +;;;not_ref: save ; save current location pointer +;;; lea BX,m_deref +;;; jmp src_err ; display error message + +;;;; Create a reference cell (ref obj) +;;;ref: lods byte ptr ES:[SI] ; load register number +;;; lea BX,[BP].temp_reg ; load address of temp register and +;;; push BX ; push as argument to "alloc_ref_cell" +;;; C_call alloc_re,,Load_ES ; allocate ref cell +;;; mov SP,BP +;;; mov BX,[BP].temp_reg.C_page ; Load page number of ref cell +;;; mov ES,pagetabl+[BX] ; load paragraph address of ref cell page +;;; mov DI,[BP].temp_reg.C_disp ; load the cell's displacement +;;; mov SI,[BP].save_AX ; restore reg number from old AX into SI +;;;; copy pointer to object into newly allocated ref cell-- update dest reg +;;; mov AX,DI ; copy displacement +;;; xchg AX,reg0_dis+[SI] ; load displacement, and +;;; mov ES:[DI].car,AX ; store into new ref cell +;;; mov AX,BX ; copy page number +;;; xchg AX,reg0_pag+[SI] ; load page number, and +;;; mov ES:[DI].car_page,AL ; store it, too +;;; jmp next_PC + +;************************************************************************ +;* AL AH * +;* Set Reference (set_ref! ref val) SETREF ref,val * +;************************************************************************ +;;;set_ref: lods word ptr ES:[SI] ; load src/dest register numbers +;;; save ; save the location pointer +;;; mov BL,AL ; copy dest register number +;;; mov DI,BX +;;; mov SI,reg0_dis+[DI] ; copy displacement of ref cell +;;; mov BL,byte ptr reg0_pag+[DI] ; copy ref cell's page number +;;; cmp byte ptr ptype+[BX],REFTYPE*2 ; it is a ref cell, isn't it? +;;; jne not_strf ; if not, error +;;; mov ES,pagetabl+[BX] ; load paragraph of ref cell's page +;;; mov BL,AH ; copy source register number +;;; mov AX,reg0_dis+[BX] ; load contents of source register and +;;; mov ES:[SI].car,AX ; and copy into ref cell +;;; mov reg0_dis+[DI],AX ; and into destination register +;;; mov AL,byte ptr reg0_pag+[BX] +;;; mov ES:[SI].car_page,AL +;;; mov byte ptr reg0_pag+[DI],AL +;;; jmp next_PC ; return to interpreter +;;;; Error-- destination of set_ref! or swap_ref! not a ref cell +;;;not_strf: error ; display error message + +;************************************************************************ +;* AL AH * +;* Swap Reference (swap_ref! ref val) SWAPREF dest,val * +;************************************************************************ +;;;swap_ref: lods word ptr ES:[SI] ; load src/dest register numbers +;;; save ; save the current location pointer +;;; mov BL,AL ; copy dest register number +;;; mov DI,BX +;;; mov SI,reg0_dis+[DI] ; copy displacement of ref cell +;;; mov BL,byte ptr reg0_pag+[DI] ; copy ref cell's page number +;;; cmp byte ptr ptype+[BX],REFTYPE*2 ; it is a ref cell, isn't it? +;;; jne not_swrf ; if not, error +;;; mov ES,pagetabl+[BX] ; load paragraph of ref cell's page +;;; mov BL,AH ; copy source register number +;;; mov AX,reg0_dis+[BX] ; load contents of source register and +;;; xchg ES:[SI].car,AX ; and exchange with contents of ref +;;; mov reg0_dis+[DI],AX ; cell +;;; mov AL,byte ptr reg0_pag+[BX] +;;; xchg ES:[SI].car_page,AL +;;; mov byte ptr reg0_pag+[DI],AL +;;; jmp next_PC ; return to interpreter +;;;not_swrf: error ; display error message + +; Negation (minus obj) MINUS dest +minus: lods byte ptr ES:[SI] ; load register field + mov DI,AX ; and copy into DI + add DI,offset reg0 ; load address of register + cmp [DI].C_page,SPECFIX*2 ; is this a fixnum? + jne minus_nf ; if not, go out of line + mov AX,[DI].C_disp ; load immediate value + shl AX,1 ; align for sign extension +minusmrg: neg AX ; negate the immediate value + jo minus_ov ; overflow? if so, make bignum + shr AX,1 ; re-align immediate value + mov [DI].C_disp,AX ; store result into register + jmp next ; return to interpreter +; Not a fixnum-- call arithmetic support +minus_nf: mov DX,MINUS_OP ; indicate negation sub-opcode + +; Process unary operation out of line +arith_1: pushm ; push reg addr, sub-opcode + C_call arith1,,Load_ES ; call unary arithmetic support + cmp AX,0 ; was error encountered? + jne arith_1x ; if error, jump + jmp next_SP ; process next instruction +arith_1x: jmp sch_err ; link to Scheme debugger + +minus_ov: mov AX,16384 ;Create result + sub DI,offset reg0 ; Convert register addr back to reg number + +; Fixnum overflow-- convert to bignum +enlrg1: cwd ; Convert to long integer +enlrg2: add DI,offset reg0 ; compute address of destination register + pushm ; push long int, reg addr + C_call enlarge,,Load_ES ; create bignum + jmp next_SP ; process next instruction + +; Support for absolute value (abs n) +sabs: lods byte ptr ES:[SI] ; load destination register number + mov DI,AX + add DI,offset reg0 ; load register address + cmp [DI].C_page,SPECFIX*2 ; Fixnum (immediate)? + jne abs_nf ; if not, go out-of-line + mov AX,[DI].C_disp ; load immediate value + shl AX,1 ; shift to position sign bit + cmp AX,0 ; how's it relate to zero? + jl minusmrg ; if negative, negate + jmp next ; else do nothing +abs_nf: mov DX,ABS_OP ; load absolute value subopcode + jmp arith_1 ; process out of line + +;************************************************************************ +;* Macro support for out-of-line calls to Lattice C * +;************************************************************************ +OTL_R_ = 1 +OTL_RT_ = 1 +OTL_R macro rtn,error_p + local x +IFNDEF rtn + extrn rtn:near +ENDIF + mov DI,offset PGROUP:rtn ; load address of routine +IFIDN , +IF OTL_RT_ +OTL_RT_ = 0 +otlr1t: lods byte ptr ES:[SI] ; load register operand + save ; save the location pointer + add AX,offset reg0 ; compute address of register + push AX ; and push as single argument + mov AX,DS ; set ES to point to the + mov ES,AX ; current data segment + call DI ; call desired routine + cmp AX,0 ; was error detected? + jl x ; if error, jump + jmp next_SP ; return to interpreter +x: jmp sch_err ; link to Scheme debugger +ELSE + jmp otlr1t ; call desired routine +ENDIF +ELSE +IF OTL_R_ +OTL_R_ = 0 +otlr1: lods byte ptr ES:[SI] ; load register operand + save ; save the location pointer + add AX,offset reg0 ; compute address of register + push AX ; and push as single argument + mov AX,DS ; set ES to point to the + mov ES,AX ; current data segment + mov AX,offset PGROUP:next_SP ; push "next_SP" as the + push AX ; return address + jmp DI ; tail recursive call to routine +ELSE + jmp otlr1 ; call desired routine +ENDIF +ENDIF + endm + +OTL_R2_ = 1 +OTL_R2T_ = 1 +OTL_R2 macro rtn,error_p + local x +IFNDEF rtn + extrn rtn:near +ENDIF + mov DI,offset PGROUP:rtn ; load address of routine +IFIDN , +IF OTL_R2T_ +OTL_R2T_ = 0 +otlr2t: lods word ptr ES:[SI] ; load register operand + save ; 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 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + call DI ; call desired routine + cmp AX,0 ; was error detected? + jl x ; if error, jump + jmp next_SP ; return to interpreter +x: jmp sch_err ; link to Scheme debugger +ELSE + jmp otlr2t +ENDIF +ELSE +IF OTL_R2_ +OTL_R2_ = 0 +otlr2: lods word ptr ES:[SI] ; load register operand + save ; 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 + pushm ; push register addresses as arguments + mov AX,DS ; set ES to point to the current data + mov ES,AX ; segment + mov AX,offset PGROUP:next_SP ; push address of "next_SP" as + push AX ; the return address + jmp DI ; tail recursive call to desired routine +ELSE + jmp otlr2 +ENDIF +ENDIF + endm + +OTL_R3_ = 1 +OTL_R3T_ = 1 +OTL_R3 macro rtn,error_p + local x +IFNDEF rtn + extrn rtn:near +ENDIF + mov DI,offset PGROUP:rtn ; load address of routine +IFIDN , +IF OTL_R3T_ +OTL_R3T_ = 0 +otlr3t: lods byte ptr ES:[SI] ; load 1st operand + add AX,offset reg0 ; and compute register address + mov CX,AX + lods word ptr ES:[SI] ; load 2nd and 3rd operands + save ; 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 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + call DI ; call desired routine + cmp AX,0 ; was error detected? + jl x ; if error, jump + jmp next_SP ; return to interpreter +x: jmp sch_err ; link to Scheme debugger +ELSE + jmp otlr3t ; call desired routine +ENDIF +ELSE +IF OTL_R3_ +OTL_R3_ = 0 +otlr3: lods byte ptr ES:[SI] ; load 1st operand + add AX,offset reg0 ; and compute register address + mov CX,AX + lods word ptr ES:[SI] ; load 2nd and 3rd operands + save ; 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 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + mov AX,offset PGROUP:next_SP ; push address of "next_SP" as + push AX ; the return address + jmp DI ; tail recursive call to desired routine +ELSE + jmp otlr3 ; call desired routine +ENDIF +ENDIF + endm + +OTL_R4_ = 1 +OTL_R4T_ = 1 +OTL_R4 macro rtn,error_p + local x +IFNDEF rtn + extrn rtn:near +ENDIF + mov DI,offset PGROUP:rtn ; load address of routine +IFIDN , +IF OTL_R4T_ +OTL_R4T_ = 0 +otlr4t: lods word ptr ES:[SI] ; load 1st and 2nd operands + xor CX,CX + xor DX,DX + mov DL,AL ; copy 1st operand register number + add DX,offset reg0 + mov CL,AH ; copy 2nd operand register number + add CX,offset reg0 + lods word ptr ES:[SI] ; load 3rd and 4th operands + save ; save the location pointer + xor BX,BX + mov BL,AH ; copy 4th operand register number + add BX,offset reg0 ; compute address of register + xor AH,AH + add AX,offset reg0 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + call DI ; call desired routine + cmp AX,0 ; was error detected? + jl x ; if error, jump + jmp next_SP ; return to interpreter +x: jmp sch_err ; link to Scheme debugger +ELSE + jmp otlr4t ; call desired routine +ENDIF +ELSE +IF OTL_R4_ +OTL_R4_ = 0 +otlr4t: lods word ptr ES:[SI] ; load 1st and 2nd operands + xor CX,CX + xor DX,DX + mov DL,AL ; copy 1st operand register number + add DX,offset reg0 + mov CL,AH ; copy 2nd operand register number + add CX,offset reg0 + lods word ptr ES:[SI] ; load 3rd and 4th operands + save ; save the location pointer + xor BX,BX + mov BL,AH ; copy 4th operand register number + add BX,offset reg0 ; compute address of register + xor AH,AH + add AX,offset reg0 + pushm ; push register addresses as arguments + mov AX,DS + mov ES,AX + mov AX,offset PGROUP:next_SP ; push address of "next_SP" as + push AX ; the return address + jmp DI ; tail recursive call to desired routine +ELSE + jmp otlr4 ; call desired routine +ENDIF +ENDIF + endm + +;************************************************************************ +; Convert number to fixnum (toward nearest integer) ROUND reg * +;************************************************************************ +sround: OTL_R round,TEST_RESULT + +;************************************************************************ +; Convert number to fixnum (toward - infinity) FLOOR reg * +;************************************************************************ +sfloor: OTL_R floor,TEST_RESULT + +;************************************************************************ +; Convert number to fixnum (toward + infinity) CEILING reg * +;************************************************************************ +sceiling: OTL_R ceiling,TEST_RESULT + +;************************************************************************ +; Convert number to fixnum (toward zero) TRUNCATE reg * +;************************************************************************ +struncat: OTL_R truncate,TEST_RESULT + +;************************************************************************ +; Convert number to fixnum FLOAT reg * +;************************************************************************ +float: OTL_R sfloat,TEST_RESULT + +;************************************************************************ +;* Support for string->symbol (string->symbol dest) * +;************************************************************************ +str2sym: OTL_R str_2_sy,TEST_RESULT + +;************************************************************************ +;* string->uninterned-symbol (string->uninterned-symbol dest) * +;************************************************************************ +str2usym: OTL_R str_2_us,TEST_RESULT + +;************************************************************************ +;* Support for symbol->string (symbol->string dest) * +;************************************************************************ +sym2str: OTL_R sym_2_st,TEST_RESULT + +;************************************************************************ +;* Support for fast load (fasl filename) * +;************************************************************************ +sfasl: OTL_R fasl,TEST_RESULT + +;;;;************************************************************************ +;;;;* Support for unique symbol generation (gensym sym) * +;;;;************************************************************************ +;;;gensym: OTL_R sgensym + +;************************************************************************ +;* Support for prop-list (prop-list name) * +;************************************************************************ +proplist: OTL_R prop_lis,TEST_RESULT + +;************************************************************************ +;* Support for random (random seed) * +;************************************************************************ +random: OTL_R srandom + +;;;;************************************************************************ +;;;;* Support for current-column (current-column dest) * +;;;;************************************************************************ +;;;curr_clm: OTL_R current_ + +;;;;************************************************************************ +;;;;* Support for line-length (line-length dest) * +;;;;************************************************************************ +;;;line_lng: OTL_R line_len + +;;;;************************************************************************ +;;;;* Support for set-line-length! (set-line-length! len) * +;;;;************************************************************************ +;;;set_lng: OTL_R set_line + +;;;;************************************************************************ +;;;;* Support for file-exists? (file-exists? string) * +;;;;************************************************************************ +;;;file_ex: OTL_R file_exi + +;************************************************************************ +;* Support for %internal-time (%internal-time dest) * +;************************************************************************ +ptyme: OTL_R ptime + +;************************************************************************ +;* Support for make-window (make-window dest) * +;************************************************************************ +;;;mk_wind: OTL_R make_win,TEST_RESULT + +;************************************************************************ +;* Support for clear-window (clear-window dest) * +;************************************************************************ +clr_wind: OTL_R clear_wi,TEST_RESULT + +;************************************************************************ +;* Support for read-char (read-char dest) * +;************************************************************************ +;;;readch: OTL_R read_cha,TEST_RESULT + +;************************************************************************ +;* Support for close-port (close-port port) * +;************************************************************************ +pclose: OTL_R spclose,TEST_RESULT + +;************************************************************************ +;* Support for newline (newline port) * +;************************************************************************ +;;;pnewlin: OTL_R spnewlin,TEST_RESULT + +;************************************************************************ +;* Support for read (read port) * +;************************************************************************ +;;;pread: OTL_R spread,TEST_RESULT + +;************************************************************************ +;* Support for print-length (print-length obj) * +;************************************************************************ +;;;prt_len_: OTL_R prt_len + +;************************************************************************ +;* Support for %transcript (%transcript port/nil) * +;************************************************************************ +;;;transcrip: OTL_R trns_chg + +;************************************************************************ +;* Support for read-char-ready? (read-char-ready? port) * +;************************************************************************ +;;;read_cr: OTL_R rd_ch_rd,TEST_RESULT + +;************************************************************************ +;* Support for save-window (save-window-contents port) * +;************************************************************************ +;;;sav_wind: OTL_R save_win,TEST_RESULT + +;************************************************************************ +;* Support for read-atom (read-atom port)* +;************************************************************************ +;;;read_at: OTL_R srd_atom,TEST_RESULT + +;************************************************************************ +;* Support for %start-timer (%start-timer #-ticks) * +;************************************************************************ +set_tim: OTL_R cset_tim,TEST_RESULT + +;************************************************************************ +;* Support for %stop-timer (%stop-timer) * +;************************************************************************ +rst_tim: OTL_R crst_tim,TEST_RESULT + +;************************************************************************ +;* Support for STRING-LENGTH (STRING-LENGTH STRING) * +;************************************************************************ +str_lng: OTL_R st_len,TEST_RESULT + +;************************************************************************ +;* Support for REIFY-STACK (REIFY-STACK index) * +;************************************************************************ +reify_s: OTL_R reif_stk,TEST_RESULT + +;************************************************************************ +;* Support for princ (princ obj {port}) * +;************************************************************************ +;;;pprinc: OTL_R2 spprinc,TEST_RESULT + +;************************************************************************ +;* Support for get-prop (get-prop name prop) * +;************************************************************************ +getprop: OTL_R2 get_prop + +;************************************************************************ +;* Support for rem-prop (rem-prop name prop) * +;************************************************************************ +remprop: OTL_R2 rem_prop + +;************************************************************************ +;* Support for get-window-attribute (get-window-attribute wind attr) * +;************************************************************************ +;;;get_w_at: OTL_R2 get_wind,TEST_RESULT + +;************************************************************************ +;* Support for open-port (open port mode) * +;************************************************************************ +popen: OTL_R2 spopen,TEST_RESULT + +;************************************************************************ +;* Support for prin1 (prin1 obj {port}) * +;************************************************************************ +;;;pprin1: OTL_R2 spprin1,TEST_RESULT + +;************************************************************************ +;* Support for print (print obj {port}) * +;************************************************************************ +;;;pprint: OTL_R2 spprint,TEST_RESULT + +;************************************************************************ +;* Support for restore-window (restore-window-contents port data) * +;************************************************************************ +;;;res_wind: OTL_R2 rest_win,TEST_RESULT + +;************************************************************************ +;* Support for REIFY-STACK! (REIFY-STACK index value) * +;************************************************************************ +reify_sb: OTL_R2 reif_stb,TEST_RESULT + +;************************************************************************ +;* Support for APPEND (APPEND list obj) * +;************************************************************************ +append: OTL_R2 sappend,TEST_RESULT + +;************************************************************************ +;* Support for put-prop (put-prop name value prop) * +;************************************************************************ +putprop: OTL_R3 put_prop,TEST_RESULT + +;************************************************************************ +;* Substring (substring string position length) SUBSTR str,pos,len * +;************************************************************************ +substr: OTL_R3 ssubstr,TEST_RESULT + +;************************************************************************ +;* Support for set-window-attr (get-window-attribute wind attr val) * +;************************************************************************ +set_w_at: OTL_R3 set_wind,TEST_RESULT + +;************************************************************************ +;* Support for subset-find-next-char-in-set (... str start end charset) * +;************************************************************************ +srch_nx: OTL_R4 srch_nxt,TEST_RESULT + +;************************************************************************ +;* Support for subset-find-prev-char-in-set (... str start end charset) * +;************************************************************************ +srch_pr: OTL_R4 srch_prv,TEST_RESULT + +;************************************************************************ +;* Interface to set file position (set-file-position! port chunk# bytes) +;************************************************************************ + +sfpos: OTL_R3 set_pos,TEST_RESULT + + purge OTL_R,OTL_R2,OTL_R3,OTL_R4 + +;************************************************************************ +;* AL AH AL * +;* Support for "reification" (%reify obj index) * +;* (%reify! obj index val) * +;************************************************************************ +sreifyb: mov CX,1 ; set flag for "store" operation + jmp short sreif_10 ; skip next instruction +sreify: xor CX,CX ; set flag for "load" operation +sreif_10: lods word ptr ES:[SI] ; load obj,index operand register numbers + xor BX,BX + mov BL,AL ; copy obj's register number and + lea DI,reg0+[BX] ; compute obj register's address + mov BL,AH ; copy index's register number and + add BX,offset reg0 ; compute index register's address + cmp CX,0 ; is this a load or a store? + je sreif_20 ; if a load, jump + xor AX,AX + lods byte ptr ES:[SI] ; load value register number and + add AX,offset reg0 ; compute value register's address + push AX ; push value reg as argument +sreif_20: pushm ; push index reg, obj reg, direction + C_call reify,,Load_ES ; call: reify(dir,obj,index{,val}); + cmp AX,0 ; test result of reification request + jne sreif_30 ; if error, jump + jmp next_SP ; return to interpreter +; ***error-- error status returned from reify call*** +sreif_30: restore ; reload the location pointer + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* Macro definition - Interpreter support for binary operations * +;* * +;* Purpose: To generate interpreter support for operations of the * +;* form: * +;* OP dest,src * +;* where: * +;* destination reg <- destination reg OP source reg * +;************************************************************************ +bin_op macro operation + local label1,label2,label3,label4 + lods word ptr ES:[SI] ; load destination/source register numbers + mov BL,AL ; copy destination reg number to + mov DI,BX ; register DI + mov AL,byte ptr reg0_pag+[DI] ; test to see in destination's + cmp AL,SPECFIX*2 ; page contains fixnums + jne label1 ; if not, process out of line (jump) + mov BL,AH ; copy source register number + cmp AL,byte ptr reg0_pag+[BX] ; is second operand also a fixnum? + jne label1 ; if not, process out of line (jump) + mov BX,reg0_dis+[BX] ; load source (second) operand + mov AX,reg0_dis+[DI] ; load destination (first) operand + shl AX,1 ; adjust sign bits of both + shl BX,1 ; operands +IFIDN , + add AX,BX ; add the two operands + jo add_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN , + sub AX,BX ; subtract the two operands + jo sub_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN , + sar AX,1 ; divide first operand by 2 + imul BX ; multiply the two operands + jo mul_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN ,
+ cmp BX,0 ; is the divisor zero? + je zero_div ; if so, error + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands + cmp DX,0 ; is remainder zero? + jne div_frac ; if so, return flonum result (jump) + shl AX,1 ; clear high order bit of result +ELSE +IFIDN , + cmp BX,0 ; is the divisor zero? + je zero_dvq ; if so, error + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands + shl AX,1 ; clear high order bit of result +ELSE +IFIDN , + cmp BX,0 ; is the divisor zero? + je zero_dvm ; if so, error (jump) + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands (gives remainder) + mov AX,DX ; copy remainder to AX +ELSE +IFIDN , + cmp AX,BX ; compare the two operands + jge max_done ; if destination operand biggest, jump + mov AX,BX ; copy the source operand to AX +ELSE +IFIDN , + cmp AX,BX ; compare the two operands + jle max_done ; if destination operand smallest, jump + mov AX,BX ; copy the source operand to AX +ELSE +IFIDN , + xor AX,BX ; xor the two operands +ELSE +IFIDN , + and AX,BX ; and the two operands +ELSE +IFIDN , + or AX,BX ; ior the two operands +ELSE + ***error*** ; undefined instruction +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF + shr AX,1 ; convert result to 15 bit value + mov reg0_dis+[DI],AX ; store result into destination register + jmp next ; return to the interpreter +IFIDN , +label1: mov DX,ADD_OP ; load operation type +; General arithmetic support for non-interget binary arithmetic operations +; Registers at this point: AH - source register number +; BH - (zero) +; DX - arithmetic sub-opcode (operation type) +; DI - destination register number +bin_ool: mov BL,AH ; copy source register number + add BX,offset reg0 ; compute source register's address + add DI,offset reg0 ; compute destination register's address + pushm ; push arguments on TIPC's stack + C_call arith2,,load_ES ; process the non-integer operation + cmp AX,0 ; error encountered? + jne label4 ; if error detected, jump + jmp next_SP ; return to the interpreter +label4: jmp sch_err ; link to Scheme debugger +ELSE +IFIDN , +label1: mov DX,GE_OP ; load operation type +max_ool: mov BL,AH ; copy source register number + add BX,offset reg0 ; compute source register's address + add DI,offset reg0 ; compute destination register's address + pushm ; push arguments on TIPC's stack + C_call arith2,,load_ES ; process the non-integer operation + cmp AX,0 ; what was the result of the comparison? + jl label3 ; if error detected, jump + jne label2 ; jump, if correct value already in dest reg + restore ; restore register addresses + mov AX,[BX].C_disp ; copy source operand into the destination + mov [DI].C_disp,AX ; register + mov AL,byte ptr [BX].C_page + mov byte ptr [DI].C_page,AL +label2: jmp next_SP ; return to the interpreter +label3: jmp sch_err ; link to Scheme debugger +ELSE +IFIDN , +label1: mov DX,LE_OP ; load operation type + jmp max_ool ; process non-integer comparison out of line +ELSE +label1: mov DX,operation&_OP ; load operation type + jmp bin_ool ; process non-integer operation out of line +ENDIF +ENDIF +ENDIF + endm + + +;************************************************************************ +; Addition (+ obj1 obj2) ADD dest,src * +;************************************************************************ +add: bin_op ADD +sub_ov: cmc ; complement the carry bit for subtract +add_ov: rcr AX,1 ; Shift in sign bit + jmp enlrg1 ; convert to bignum + +;************************************************************************ +;* Subtraction (- obj1 obj2) SUB dest,src * +;************************************************************************ +sub: bin_op SUB + +;************************************************************************ +;* Multiplication (* obj1 obj2) MUL dest,src * +;************************************************************************ +mul: bin_op MUL +mul_ov: sar DX,1 ;Divide product by 2 + rcr AX,1 + jmp enlrg2 ;Convert to bignum + +;************************************************************************ +;* Division (/ obj1 obj2) DIV dest,src * +;************************************************************************ +div: bin_op DIV +; ***Error-- Division by Zero*** +zero_div: mov BX,offset m_DIV ; load text for "\" +zd_010: sub SI,3 ; back up location pointer to start of inst. + pushm ; push inst addr, function name + C_call disassem,,Load_ES ; "disassemble" the instruction + pushm ; push irritant,div code,no restart + C_call set_nume ; set_numeric_error(1,ZERO_DIV,tmp_reg) + restore ; load restart address (not used) + jmp sch_err ; link to Scheme debugger +; ***Fractional Result from Division-- Convert to Flonum*** +div_frac: add DI,offset reg0 ; compute destination register address + push DI ; and push as argument to "sfloat" + C_call sfloat,,load_ES ; convert destination op to flonum + les SI,dword ptr [BP].save_SI ; restore location pointer + sub SI,2 ; back up the location pointer + xor BX,BX ; clear TIPC register BX + jmp div ; re-execute div in floating point + +;************************************************************************ +;* Integer Division (quotient obj1 obj2) QUOTIENT dest,src * +;************************************************************************ +quo: bin_op QUOT +zero_dvq: mov BX,offset m_QUOTNT ; load address of "QUOTIENT" text + jmp zd_010 ; indicate divide by zero + +;************************************************************************ +;* Modulo (mod obj1 obj2) MOD dest,src * +;************************************************************************ +modulo: bin_op MOD +zero_dvm: mov BX,offset m_MODULO ; load address of "REMAINDER" text + jmp zd_010 ; indicate divide by zero + +;************************************************************************ +;* Maximum value (max obj1 obj2) MAX dest,src * +;************************************************************************ +maximum: bin_op MAX +max_done: jmp next ; return to interpreter + +;************************************************************************ +;* Minimum value (min obj1 obj2) MIN dest,src * +;************************************************************************ +minimum: bin_op MIN + +;************************************************************************ +;* (bitwise-xor obj1 obj2) XOR dest,src * +;************************************************************************ +b_xor: bin_op XOR + +;************************************************************************ +;* (bitwise-and obj1 obj2) AND dest,src * +;************************************************************************ +b_and: bin_op AND + +;************************************************************************ +;* (bitwise-or obj1 obj2) OR dest,src * +;************************************************************************ +b_or: bin_op OR + + purge bin_op + +;************************************************************************ +;* Macro definition - Interpreter support for immediate operations * +;* * +;* Purpose: To generate interpreter support for operations of the * +;* form: * +;* OP dest,immediate * +;* where: * +;* destination reg <- destination reg OP immediate * +;************************************************************************ +immed_op macro operation + local label1,label2,label3,label4 + lods word ptr ES:[SI] ; load destination reg/immediate value + mov BL,AL ; copy destination reg number to + mov DI,BX ; register DI + mov AL,AH ; sign extend immediate operand + cbw + cmp byte ptr reg0_pag+[DI],SPECFIX*2 ; dest operand a fixnum? + jne label1 ; if not, process out of line (jump) + mov BX,AX ; move immediate operand to BX + mov AX,reg0_dis+[DI] ; load destination (first) operand + shl AX,1 ; adjust sign bits of both + shl BX,1 ; operands +IFIDN , + add AX,BX ; add the two operands + jo addi_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN , + sub AX,BX ; subtract the two operands + jo addi_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN , + sar AX,1 ; divide first operand by 2 + imul BX ; multiply the two operands + jo muli_ov ; overflow? if so, convert to bignum (jump) +ELSE +IFIDN ,
+ cmp BX,0 ; is the divisor zero? + je zero_dvi ; if so, error + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands + cmp DX,0 ; is remainder zero? + jne divi_frc ; if not, need flonum result (jump) + shl AX,1 ; clear high order bit of result +ELSE +IFIDN , + cmp BX,0 ; is the divisor zero? + je label2 ; if so, assume result is the dividend + cwd ; convert dividend to a doubleword + idiv BX ; divide the two operands (gives remainder) + mov AX,DX ; copy remainder to AX +label2: +ELSE +IFIDN , + cmp AX,BX ; compare the two operands + jge mxi_done ; if destination operand biggest, jump + mov AX,BX ; copy the source operand to AX +ELSE +IFIDN , + cmp AX,BX ; compare the two operands + jle mxi_done ; if destination operand smallest, jump + mov AX,BX ; copy the source operand to AX +ELSE + ***error*** ; undefined instruction +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF + shr AX,1 ; convert result to 15 bit value + mov reg0_dis+[DI],AX ; store result into destination register + jmp next ; return to the interpreter +IFIDN , +label1: mov DX,ADD_OP ; load operation type +; General arithmetic support for non-integer immediate operations +; Registers at this point: AX - immediate value +; DX - arithmetic sub-opcode (operation type) +; DI - destination register number +bini_ool: add DI,offset reg0 ; compute address of destination register + lea BX,[BP].temp_reg ; load address of temporary register + and AX,07fffH ; mask off sign bit of immediate value + mov [BX].C_disp,AX ; and create a fixnum value in a + mov [BX].C_page,SPECFIX*2 ; temporary register + pushm ; push arguments on TIPC's stack + C_call arith2,,load_ES ; process the non-integer operation + cmp AX,0 ; was error detected? + jne label3 ; if error encountered, jump + jmp next_SP ; return to the interpreter +label3: jmp sch_err ; link to Scheme debugger +ELSE +IFIDN , +label1: mov DX,GE_OP ; load operation type +maxi_ool: add DI,offset reg0 ; compute destination register's address + lea [BX].temp_reg ; load address of temporary register + and AX,07fffH ; mask off sign bit of immediate value + mov [BX].C_disp,AX ; and create a fixnum value in a + mov [BX].C_page,SPECFIX*2 ; temporary register + pushm ; push arguments on TIPC's stack + C_call arith2,,load_ES ; process the non-integer operation + cmp AX,0 ; what was the result of the comparison? + jl label4 ; if error detected, jump + jne label2 ; jump, if correct value already in dest reg + restore ; restore register addresses + mov AX,[BX].C_disp ; copy source operand into the destination + mov [DI].C_disp,AX ; register +label2: jmp next_SP ; return to the interpreter +label4: jmp sch_err ; link to the Scheme debugger +ELSE +IFIDN , +label1: mov DX,LE_OP ; load operation type + jmp maxi_ool ; process non-integer comparison out of line +ELSE +label1: mov DX,operation&_OP ; load operation type + jmp bini_ool ; process non-integer operation out of line +ENDIF +ENDIF +ENDIF + endm + + +;************************************************************************ +;* Add immediate ADDI reg,val * +;************************************************************************ +addi: immed_op ADD +addi_ov: jmp add_ov + + +;************************************************************************ +;* Multiply Immediate MULI reg,val * +;************************************************************************ +muli: immed_op MUL +muli_ov: jmp mul_ov ; convert to bignum + + +;************************************************************************ +;* Divide Immediate DIVI reg,val * +;************************************************************************ +divi: immed_op DIV +zero_dvi: jmp zero_div ; process divide by zero +divi_frc: add DI,offset reg0 ; compute destination register address + push DI ; and push as argument to "sfloat" + C_call sfloat,,load_ES ; convert destination op to flonum + les SI,dword ptr [BP].save_SI ; restore location pointer + sub SI,2 ; back up the location pointer + xor BX,BX ; clear TIPC register BX + jmp divi ; re-execute div immed in floating point + + purge immed_op + +;************************************************************************ +;* Test for (null? obj) NULL? reg * +;************************************************************************ +null_p: lods byte ptr ES:[SI] ; load number of register to test + mov BX,AX ; and copy it into BX + cmp byte ptr reg0_pag+[BX],0 ; is page number 0? + je null_t ; if register nil, jump + xor AX,AX ; set register to nil (test false) + mov byte ptr reg0_pag+[BX],AL + mov reg0_dis+[BX],AX + jmp next +null_t: mov AL,T_PAGE*2 ; set register to 't + mov byte ptr reg0_pag+[BX],AL + mov AX,T_DISP + mov reg0_dis+[BX],AX + jmp next + +;************************************************************************ +;* AL AH * +;* Test for eq? (pointers identical) EQ? dest,src * +;************************************************************************ +eq_p: lods word ptr ES:[SI] ; load source/dest operands + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI + mov BL,AH ; copy source register number + mov AX,reg0_dis+[BX] ; load page number of source operand + cmp AX,reg0_dis+[DI] ; are the displacements identical? + jne eq_p_no ; if not, jump + mov AL,byte ptr reg0_pag+[BX] ; load src operand's page number + cmp AL,byte ptr reg0_pag+[DI] ; are page numbers identical? + jne eq_p_no ; if not, jump + mov byte ptr reg0_pag+[DI],T_PAGE*2 ; they're "eq"-- set + mov reg0_dis+[DI],T_DISP ; result to 't (true) + jmp next ; return to the interpreter +; pointers are not identical-- set result to nil +eq_p_no: xor AX,AX + mov byte ptr reg0_pag+[DI],AL ; set page number and + mov reg0_dis+[DI],AX ; displacement of result register to nil + jmp next ; return to the interpreter + +;************************************************************************ +;* AL AH * +;* Test for eqv? (pointers identical, or numbers equal) EQ? dest,src * +;************************************************************************ +eqv_p: lods word ptr ES:[SI] ; load source/dest operands + mov BL,AL ; copy destination register number + mov DI,BX ; into TIPC register DI + mov BL,AH ; copy source register number + mov AX,reg0_dis+[BX] ; load page number of source operand + cmp AX,reg0_dis+[DI] ; are the displacements identical? + jne eqv_p_no ; if not, jump + mov AL,byte ptr reg0_pag+[BX] ; load src operand's page number + cmp AL,byte ptr reg0_pag+[DI] ; are page numbers identical? + jne eqv_p_no ; if not, jump + mov byte ptr reg0_pag+[DI],T_PAGE*2 ; they're "eq"-- set + mov reg0_dis+[DI],T_DISP ; result to 't (true) + jmp next ; return to the interpreter +; pointers are not identical-- test for numbers +eqv_p_no: mov AH,BL ; copy source register number and load + mov BL,byte ptr reg0_pag+[BX] ; page number from source reg + test attrib+[BX],FIXNUMS+BIGNUMS+FLONUMS + jz eqv_p_s ; if not a number, jump + mov AX,DI ; copy destination register number and load + mov BL,byte ptr reg0_pag+[DI] ; page number from dest reg + test attrib+[BX],FIXNUMS+BIGNUMS+FLONUMS + jz eqv_p_s ; if not a number, jump + sub SI,2 ; else set ip back to operands + jmp eq_n ; and go test with "=" +eqv_p_s: test attrib+[BX],STRINGS + jz eqv_p_f ; if not a string, operands aren't eqv (jump) + add DI,offset reg0 ; else compute address of destination reg + jmp short equal_p1 ; test using "equal?" +eqv_p_f: xor AX,AX + mov byte ptr reg0_pag+[DI],AL ; set page number and + mov reg0_dis+[DI],AX ; displacement of result register to nil + jmp next ; return to the interpreter + + +;************************************************************************ +;* AL AH * +;* Test equality of s-expressions equal? dest,src* +;* * +;* Purpose: Scheme interpreter support for the testing of "equality" * +;* of two s-expressions. * +;************************************************************************ +equal_p: lods word ptr ES:[SI] ; load operands to be compared + mov BL,AL ; copy destination register number + lea DI,reg0+[BX] ; and load its address +equal_p1: mov BL,AH ; copy source register number + add BX,offset reg0 ; and compute its address, too + pushm ; push arguments onto TIPC's stack + C_call sequal_p,,Load_ES ; call: sequal(&dest,&src) + pop DI ; restore destination register's address + cmp AX,0 ; are operands equal? (return code not zero) + je equal_f ; if not equal, jump + mov byte ptr [DI].C_page,T_PAGE*2 ; set result register + mov [DI].C_disp,T_DISP ; to 't + jmp next_SP ; return to interpreter +equal_f: mov byte ptr [DI].C_page,AL ; set result register to nil + mov [DI].C_disp,AX + jmp next_SP ; return to interpreter + + +;************************************************************************ +;* Macro definition - Support for attribute tests * +;************************************************************************ +attr_mac macro condition + mov DX,condition ; load attribute mask for test +IFIDN , +attr_1: lods byte ptr ES:[SI] ; fetch register to test + mov BX,AX ; copy register number + mov DI,reg0_pag+[BX] ; load page number and +attr_2: mov AX,attrib+[DI] ; and fetch page's attributes + and AX,DX ; test against mask + jnz attr_3 ; if non-zero, test is true (jump) + mov byte ptr reg0_pag+[BX],AL ; set result to nil (0) + mov reg0_dis+[BX],AX + jmp next ; return to interpreter +attr_3: mov AL,T_PAGE*2 ; set result to true + mov byte ptr reg0_pag+[BX],AL + mov AX,T_DISP + mov reg0_dis+[BX],AX + jmp next ; return to interpreter +ELSE + jmp attr_1 ; continue attribute test +ENDIF + endm + + +; Test for (atom? obj) +atom_p: attr_mac ATOM + +; Test for (char? obj) +char_p: attr_mac CHARS + +; Test for (closure? obj) +closur_p: attr_mac CLOSURE + +; Test for (code? obj) +code_p: attr_mac CODE + +; Test for (continuation? obj) +contin_p: attr_mac CONTINU + +; Test for (float? obj) +float_p: attr_mac FLONUMS + +; Test for (integer? obj) +integr_p: attr_mac FIXNUMS+BIGNUMS + +; Test for (number? obj) +number_p: attr_mac NUMBERS + +; Test for (pair? obj) +pair_p: attr_mac LISTCELL + +; Test for (port? obj) +port_p: mov DX,PORTS ; load "port" attribute bit mask + lods byte ptr ES:[SI] ; load instruction's operand + mov BX,AX ; and copy it into BX + mov DI,reg0_pag+[BX] ; load the page number of the operand + cmp DI,CON_PAGE ; is it same page as 'console? + jne attr_2 ; if not, jump + mov AX,reg0_dis+[BX] ; load the displacement of the operand + cmp AX,CON_DISP ; is it 'console? + je attr_3 ; if so, return #!true (jump) + jmp attr_2 ; if not 'console, return #!false + +; Test for (proc? obj) +proc_p: attr_mac CONTINU+CLOSURE + +; Test for (ref? obj) +ref_p: attr_mac REFS + +; Test for (string? obj) +string_p: attr_mac STRINGS + +; Test for (symbol? obj) +symbol_p: attr_mac SYMBOLS + +; Test for (vector? obj) +vector_p: attr_mac VECTORS + + purge attr_mac + +;************************************************************************ +;* Common Support for EVEN?/ODD? * +;* * +;* Input Parameters: ES:[SI] - pointer to even?/odd? instruction's * +;* operand. * +;* DX ------ text address for "EVEN?" or "ODD?" to * +;* be used to create an error message if * +;* an error is detected. * +;* * +;* Output Parameters: Zero Flag (condition code) - 0 => even number * +;* 1 => odd number * +;* * +;* Note: If an invalid operand is detected, this routine exits to the * +;* Scheme debugger. * +;************************************************************************ +eo_which: lods byte ptr ES:[SI] ; load operand to even?/odd? instruction + mov BX,AX ; copy register number to BX + add BX,offset reg0 ; and compute operand register's address + cmp byte ptr [BX].C_page,SPECFIX*2 ; is operand a fixnum? + jne eo_010 ; if not a fixnum, jump + test byte ptr [BX].C_disp,1 ; test LSB of fixnum value + ret ; return to even?/odd? support +; Operand isn't a fixnum-- test for a bignum +eo_010: mov DI,[BX].C_page ; fetch operand's page number + cmp byte ptr ptype+[DI],BIGTYPE*2 ; is operand a bignum? + jne eo_020 ; if not a bignum, error (jump) + mov CX,ES ; save value in ES + LoadPage ES,DI ; load bignum;s paragraph address +; mov ES,pagetabl+[DI] ; load bignum's paragraph address + mov DI,[BX].C_disp ; load bignum's displacement + test byte ptr ES:[DI].big_data,1 ; test LSB of bignum + mov ES,CX ; restore ES register + ret ; return to even?/odd? support +; ***Error-- operand isn't an integer*** +eo_020: pushm ; push operands to "set_src_error" + C_call set_src_,,Load_ES ; call said + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* is an integer even? even? dest * +;* * +;* Purpose: Scheme interpreter support for the even? predicate. * +;************************************************************************ +even_p: mov DX,offset m_even ; load text addr, in case of error + call eo_which ; is value even or odd? + jnz eo_false ; if LSB on, jump +eo_true: mov byte ptr [BX].C_page,T_PAGE*2 ; result is #!true + mov [BX].C_disp,T_DISP + jmp next ; return to Scheme interpreter + +;************************************************************************ +;* is an integer odd? odd? dest * +;* * +;* Purpose: Scheme interpreter support for the odd? predicate. * +;************************************************************************ +odd_p: mov DX,offset m_odd ; load text addr, in case of error + call eo_which ; is value even or odd? + jnz eo_true ; if LSB on, jump +eo_false: xor AX,AX ; create a zero value for use as #!false + mov byte ptr [BX].C_page,AL ; result is #!false + mov [BX].C_disp,AX + jmp next ; return to Scheme interpreter + +;************************************************************************ +;* Macro definition - Support for arithmetic testing (cond n1 n2) * +;************************************************************************ +JE_OPCOD = 01110100b +JNE_OPCOD = 01110101b +JL_OPCOD = 01111100b +JGE_OPCOD = 01111101b +JLE_OPCOD = 01111110b +JG_OPCOD = 01111111b +cond_mac macro cond + local x,y,y1,z,pred_T,labelx +IFIDN , + mov DX,NE_OP ; Load "!=" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JNE_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,LT_OP ; Load "<" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JL_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,GT_OP ; Load ">" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JG_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,LE_OP ; Load "<=" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JLE_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,GE_OP ; Load ">=" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JGE_OPCOD ;Protected Mode Macro + jmp short cnd_go +ELSE +IFIDN , + mov DX,EQ_OP ; Load "=" sub-opcode + STORE_BYTE_IN_CS PROG,cnd_jmp,JE_OPCOD ;Protected Mode Macro +cnd_go: lods word ptr ES:[SI] ; load register numbers to compare + mov BL,AL ; copy n1 register number + mov DI,BX ; into DI (clear high order byte) + cmp byte ptr reg0_pag+[DI],SPECFIX*2 ; is n1 a fixnum? + jne y ; if not, perform comparison out of line + mov BL,AH ; copy n2 register number + cmp byte ptr reg0_pag+[BX],SPECFIX*2; is n2 a fixnum? + jne y1 ; jump if not + mov AX,reg0_dis+[BX] ; load n2's immediate value + mov DX,reg0_dis+[DI] ; load n1's immediate value + shl DX,1 ; adjust immediate values to sign + shl AX,1 ; extend + cmp DX,AX ; compare the two operands +cnd_jmp equ $ + j&cond z ; jump if comparison is satisfied + xor AX,AX ; store '() in destination register + mov byte ptr reg0_pag+[DI],AL + mov reg0_dis+[DI],AX + jmp next ; return to interpreter +z: mov AL,T_PAGE*2 ; store 't in destination register + mov byte ptr reg0_pag+[DI],AL + mov AX,T_DISP + mov reg0_dis+[DI],AX + jmp next ; return to interpreter +; Operand(s) not fixnums-- perform comparison in C routine +y: mov BL,AH +y1: add BX,offset reg0 ; Load address of source register + add DI,offset reg0 ; Load address of destination register + pushm ; Push src, dest, op arguments + C_call arith2,,load_ES ; Call the arithmetic processor + restore + cmp AX,0 ; test result returned from arith2 + jl labelx ; jump if error condition detected + jne pred_T ; jump if comparison is "true" + mov byte ptr [DI].C_page,AL ; store '() into destination register + mov [DI].C_disp,AX + jmp next_SP ; return to interpreter +pred_T: mov byte ptr [DI].C_page,T_PAGE*2 ; set result register to 't + mov [DI].C_disp,T_DISP + jmp next_SP ; return to interpreter +labelx: jmp sch_err ; link to Scheme debugger +ELSE + ***ERROR*** condition not recognized +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF +ENDIF + endm + +; Test for numeric inequality (!= n1 n2) +ne_p: cond_mac ne + +; Test for numeric less than (< n1 n2) +lt_p: cond_mac l + +; Test for numeric greater than (> n1 n2) +gt_p: cond_mac g + +; Test for numeric less than or equal (<= n1 n2) +le_p: cond_mac le + +; Test for numeric greater than or equal (>= n1 n2) +ge_p: cond_mac ge + +; Test for numeric equality (= n1 n2) +eq_n: cond_mac e + + purge cond_mac + +;************************************************************************ +;* Macro definition - Support for arithmetic testing (cond:0 n) * +;************************************************************************ +cnd1_mac macro cond + local x,y,z,cnd1_T,w +IFIDN , + mov DX,NEG_OP ; load negative? comparison subopcode + STORE_BYTE_IN_CS PROG,cnd1_jmp,JL_OPCOD ;Protected Mode Macro + jmp cnd1_go ; process comparison with zero +ELSE +IFIDN , + mov DX,POS_OP ; load positive? comparison subopcode + STORE_BYTE_IN_CS PROG,cnd1_jmp,JG_OPCOD ;Protected Mode Macro + jmp cnd1_go ; process comparison with zero +ELSE +IFIDN , + mov DX,ZERO_OP ; load zero? comparison subopcode + STORE_BYTE_IN_CS PROG,cnd1_jmp,JE_OPCOD ;Protected Mode Macro +cnd1_go: lods byte ptr ES:[SI] ; load number of register to test + mov BX,AX + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; fixnum (immediate)? + jne y ; if not, go out of line + mov AX,reg0_dis+[BX] ; load immediate value + shl AX,1 ; position sign bit-- set compare code + cmp AX,0 +cnd1_jmp equ $ + j&cond z ; jump if condition satisfied + xor AX,AX ; return '() in destination regsiter + mov byte ptr reg0_pag+[BX],AL + mov reg0_dis+[BX],AX + jmp next ; return to interpreter +z: mov AL,T_PAGE*2 ; return 't in destintation register + mov byte ptr reg0_pag+[BX],AL + mov AX,T_DISP + mov reg0_dis+[BX],AX + jmp next ; return to interpreter +; operand is not a fixnum-- call C routine to perform test +y: add BX,offset reg0 ; load address of destination reg + pushm ; push arguments + C_call arith1,,Load_ES ; link to arithmetic support + restore + cmp AX,0 ; test result returned from "arith1" + jl w ; was error encountered? + jne cnd1_T ; if error, jump + mov byte ptr [BX].C_page,AL ; set result to "nil" + mov [BX].C_disp,AX + jmp next_SP ; return to interpreter +cnd1_T: mov byte ptr [BX].C_page,T_PAGE*2 ; set result to "t" + mov [BX].C_disp,T_DISP + jmp next_SP ; resume interpretation +w: jmp sch_err ; link to Scheme debugger +ELSE + ***ERROR*** invalid comparison type +ENDIF +ENDIF +ENDIF + endm + + +; Test for equality to zero (zero? n) +eq_z_p: cnd1_mac e + +; Test for less than zero (negative? n) +lt_z_p: cnd1_mac l + +; Test for greater than zero (positive? n) +gt_z_p: cnd1_mac g + + purge cnd1_mac + +;************************************************************************ +;* (ascii->char n) ascii->char dest * +;* * +;* Purpose: Scheme interpreter support for the ascii->char function. * +;************************************************************************ +asc_char: lods byte ptr ES:[SI] ; load operand + mov DI,AX ; copy dest register number into DI + cmp byte ptr reg0_pag+[DI],SPECFIX*2 ; is operand a finxum? + jne asc_cher ; if not, error (jump) + and reg0_dis+[DI],00ffH ; "and" off low order eight bits + mov byte ptr reg0_pag+[DI],SPECCHAR*2 ; convert to character + jmp next ; return to interpreter +asc_cher: save ; save the incremented location pointer + lea BX,masc_ch ; load address of "ascii->char" text + jmp src_err ; display invalid operand message + +;************************************************************************ +;* (char->ascii n) char->ascii dest * +;* * +;* Purpose: Scheme interpreter support for the char->ascii function. * +;************************************************************************ +char_asc: lods byte ptr ES:[SI] ; load operand + mov DI,AX ; copy dest register number into DI + cmp byte ptr reg0_pag+[DI],SPECCHAR*2 ; is operand a char? + jne ch_ascer ; if not, error (jump) + mov byte ptr reg0_pag+[DI],SPECFIX*2 ; convert to a fixnum + jmp next ; return to interpreter +ch_ascer: save ; save the incremented location pointer + lea BX,mch_asc ; load address of "char->ascii" text + jmp src_err ; display invalid operand message + +;************************************************************************ +;* Support for list length (length list) * +;************************************************************************ +slength: lods byte ptr ES:[SI] ; load register containing list header + mov BX,AX + save ; save the program counter + lea DI,reg0+[BX] ; load the address of the dest reg + mov BX,[DI].C_page ; load list header from src/dest reg + mov SI,[DI].C_disp + xor AX,AX ; zero the counter + mov CX,SB_CHECK ; load shift-break iteration count +slenloop: cmp BL,NIL_PAGE*2 ; pointer to nil? + je slendone + cmp byte ptr ptype+[BX],LISTTYPE*2 ; list pointer? + jne slendone + inc AX ; increment list cell count + LoadPage ES,BX ; load list cell page para address +; mov ES,pagetabl+[BX] ; load list cell page para address + mov BL,ES:[SI].cdr_page ; load cdr of list cell + mov SI,ES:[SI].cdr + loop slenloop ; cdr down list +; Every so many iterations, check the shift-break key + mov CX,SB_CHECK ; reload the shift-break iteration count + cmp s_break,0 ; has the shift-break key been depressed? + je slenloop ; if no interrupt, continue (jump) +slen_sb: mov AX,2 ; load instruction length = 2 + jmp restart1 ; link to Scheme debugger +slendone: mov byte ptr [DI].C_page,SPECFIX*2 ; return result as a + mov [DI].C_disp,AX ; fixnum (immediate) + jmp next_PC ; return to interpreter + +;************************************************************************ +;* Support for Last-pair (last-pair list) * +;************************************************************************ +lst_pair: lods byte ptr ES:[SI] ; load src/destination register + save ; save the interpreter's program counter + mov DI,AX + mov BX,reg0_pag+[DI] ; load register's page number field + cmp BL,NIL_PAGE*2 ; null pointer? + je lst_exit ; if so, do nothing + cmp byte ptr ptype+[BX],LISTTYPE*2 ; does reg point to list cell? + jne lst_exit ; if not, return it as is + mov SI,reg0_dis+[DI] ; load register's displacement + xor DX,DX + mov CX,SB_CHECK ; load the shift-break iteration count +lst_loop: LoadPage ES,BX ; load page's paragraph address +; mov ES,pagetabl+[BX] ; load page's paragraph address + mov DL,ES:[SI].cdr_page ; load page number of cdr pointer + cmp DL,NIL_PAGE*2 ; cdr nil? + je lst_done ; if so, return current pointer + mov DI,DX ; copy cdr's page number + cmp byte ptr ptype+[DI],LISTTYPE*2 ; cdr points to list cell? + jne lst_done ; if not, we're at the end of our list + mov BL,DL ; follow linked list + mov SI,ES:[SI].cdr + loop lst_loop +; Every so many iterations, check the shift-break key + mov CX,SB_CHECK ; reload the shift-break iteration count + cmp s_break,0 ; has the shift-break key been depressed? + je lst_loop ; if no interrupt, continue (jump) + jmp slen_sb ; link to Scheme debugger +lst_done: mov DI,AX ; re-load destination register number + mov byte ptr reg0_pag+[DI],BL ; store page number + mov reg0_dis+[DI],SI ; store displacement +lst_exit: jmp next_PC ; return to interpreter + +;************************************************************************ +;* (reverse! list) reverse! dest * +;* * +;* Purpose: Scheme interpreter support for the reverse! primitive * +;* * +;* Notes: The following registers are used by this routine: * +;* BL - page number of the current list cell * +;* DI - displacement of the current list cell * +;* ES - paragraph address of the current list cell * +;* Note: ES:[DI] address the current list cell * +;* DL - page number of the previous list cell * +;* AX - displacement of the previous list cell * +;* SI - destination register number * +;************************************************************************ + public reverseb +reverseb: lods byte ptr ES:[SI] ; load operand containing list pointer + save ; preserve the location pointer + mov BL,AL ; copy number of operand register + mov SI,BX ; and put a copy into TIPC register SI + mov BL,byte ptr reg0_pag+[SI] ; load contents of operand register + mov DI,reg0_dis+[SI] ; for initial "current cell" pointer + xor AX,AX ; define previous list cell to be 'nil + xor DX,DX +rev_lp: cmp BL,0 ; end of list (current cell nil)? + je rev_done ; if so, jump + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is current cell a list cell? + jne rev_huh ; if not, error (jump) + LoadPage ES,BX ; load current cell's page address +; mov ES,pagetabl+[BX] ; load current cell's page address + xchg ES:[DI].cdr_page,DL ; swap cdr field with previous cell + xchg ES:[DI].cdr,AX ; pointer + xchg BX,DX ; current cell <-> (cdr current cell) + xchg DI,AX + jmp rev_lp ; continue down list +; list reversal complete-- update destintation register +rev_done: mov byte ptr reg0_pag+[SI],DL ; make destination register point + mov reg0_dis+[SI],AX ; to new head of (reversed) list + jmp next_PC ; return to the interpreter +; ***error-- not a valid linked list*** +rev_huh: mov byte ptr reg0_pag+[SI],DL ; make destination register point + mov reg0_dis+[SI],AX ; to new head of (reversed) list + lea BX,m_revb + jmp src_err ; display error message + + +IFNDEF PROMEM + +; Real mode scheme has graphics linked in with the vm (see graphics.exe), +; and can therefore call it directly. Protected mode scheme must xfer +; to a real mode graphics routine - see PROIO.asm. + +;************************************************************************ +;* Interface to Graphic Primitives (%graphics arg1 ... arg7) * +;************************************************************************ +sgraph: mov CX,7 ; load counter-- seven arguments + xor DX,DX ; set error flag = FALSE + lods byte ptr ES:[SI] ; load first argument + save ; and save as destination register + jmp short sgraph0 +sgraph1: lods byte ptr ES:[SI] ; load next argument +sgraph0: xor AH,AH ; be sure high byte is zero + mov BX,AX ; copy register number to BX + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; is arg a fixnum? + je sgraph2 ; if arg *is* a fixnum, o.k. (jump) + inc DX ; indicate an invalid argument +sgraph2: mov AX,reg0_dis+[BX] ; expand 15-bit signed int to 16-bit signed int + shl AX,1 + sar AX,1 + push AX ; push 16-bit signed integer +;sgraph2: push reg0_dis+[BX] ; push immediate value of argument + loop sgraph1 ; continue 'til all arguments processed + cmp DX,0 ; any argument errors? + jne sgraph3 ; if errors encountered, jump + save ; save the location pointer +;;; the following two lines are comment out +;;; allow graphics mode for unknown PC machine +;;; cmp PC_MAKE,UNKNOWN ; running on a TIPC? +;;; je not_pc ; if not a TI or IBM brand PC, jump + call graphit ; perform the graphics operation + shl AX,1 ; clear high order bit of result + shr AX,1 ; (convert to immediate value) + mov BX,[BP].save_AX ; reload destintation register number + mov reg0_dis+[BX],AX ; store returned result into destination reg +not_pc: jmp next_SP ; return to interpreter +sgraph3: mov BX,offset m_graph ; load addr of "%graphics" text + jmp src_err ; link to Scheme debugger +ENDIF + +;************************************************************************ +;* Interface to XLI external escape * +;* (%xesc length nargs "name" arg1 ... arg16) where argx is optional * +;* length = # args *to %xesc instruction* * +;************************************************************************ + +xesc: lods byte ptr es:[si] ;get xesc length (variable-length inst.); + ;afterwards, bytecode@ (ES:SI) points + ;at name string + xor ah,ah + mov dx,si ;tempsave bytecode@ to name string + add si,ax ;get ptr to next opcode + dec si + save + mov si,dx ;restore bytecode@ to name string + call xli_xesc ;do xesc + restore ;ES:SI is next opcode @ + cmp ax,0 ;any errors? + jne xesc_10 ;yes, jump + jmp next ;return to interpreter +; normal errors - ax=error number, bx=irritant +xesc_10: + xchg bx,ax ;now ax=irritant,bx=error message + shl bx,1 ;make message# into index + mov bx,xli_err[bx] ;bx => error message + mov cx,1 ;cx = 1, error non-restartable + pushm + mov ax,ds + mov es,ax ;Lattice C needs DS=ES + C_call set_erro ;set up error + jmp sch_err ;jump into debugger + + + +;************************************************************************ +;* ******************************************************************** * +;* * * * +;* * Error routines * * +;* * * * +;* ******************************************************************** * +;************************************************************************ + +IFDEF PROMEM +; +; Engine timer support for protected mode +; +set_args struc + dw ? + dw ? +hi dw ? +lo dw ? +set_args ends + + public settimer +; initialize the timer, set up the engine tick vm loop, and begin +settimer proc near + xor ax,ax ;clear ax + cmp tickstat,-1 ;check for normal run mode + jne no_set ;abort if timeout or engine running + push bp + mov bp,sp + mov ax,[bp].hi ;initialize the timer + mov hi_time,ax + mov ax,[bp].lo + mov lo_time,ax + mov ax,word ptr cs:eng_tick ;ax = handle to engine loop + XCHG_WORD_IN_CS PROG,next1,ax ;int loop now jumps to engine loop + STORE_WORD_IN_CS PROG,reset_tim,ax ;save original value in reset_tim + mov al,1 + mov tickstat,al ;denote engine now running + pop bp +no_set: ret +settimer endp + + public rsttimer +; reset vm loop to original vm loop and return whats left in timer +rsttimer proc near + cmp tickstat,1 ;only if timeout or engine running + ja no_reset ;otherwise, forget it + mov ax,cs:reset_tim ;get inst saved at top of vm loop + STORE_WORD_IN_CS PROG,next1,AX ;reset forced branch at top (next1) + mov tickstat,-1 ;no engine running +no_reset: + mov ax,hi_time ;return time left + mov bx,lo_time + ret ;return +rsttimer endp + +ENDIF + +;************************************************************************ +;* Timer Ran Down * +;************************************************************************ +; Note: the "reset_tim" variable must be in the code segment 'cause +; there's no telling where the DS register points when a +; timer interrupt occurs. +reset_tim dw 0 ; save area for resetting a timer int + public timeout +timeout: +IFNDEF PROMEM + mov AX,CS:reset_tim ; for real mode scheme, reset forced + STORE_WORD_IN_CS PROG,next1,AX ; branch at top of vm loop +ENDIF + C_call rsttimer ; turn off the timer support + mov BX,TIMEOUT_CONDITION ; load "timeout" error code +time_1: xor AX,AX ; set code for "restartable" operation +time_2: mov CX,offset nil_reg ; set *irritant* to 'nil +time_3: pushm ; push arguments to call + C_call set_nume,,Load_ES ; call: set_numeric_error(1,13,nil_reg) + restore ; load next instruction's offset + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* Shift-Break Interrupt * +;************************************************************************ +sc_debug: mov AX,CS:reset_sb ; reset forced branch at top + STORE_WORD_IN_CS PROG,next1,AX ; of vm loop + mov s_break,0 ; reset shift-break flag + mov BX,SHIFT_BREAK_CONDITION ; load "shift-break" error code + jmp time_1 ; complete link to Scheme debugger + +;************************************************************************ +;* DOS fatal I/O error process * +;************************************************************************ + public dos_err +dos_err: pop AX ; dump return address + pop AX ; restart/non-restart flag + pop BX ; error code + pop CX ; *irritant* + mov BP,reset_BP ; clean up stack + jmp time_3 ; go invoke Scheme debugger + +;************************************************************************ +;* Error-- Undefined Opcode * +;************************************************************************ +not_op: dec SI ; back up location pointer + save ; and save it + mov BX,offset m_not_op ; load address of error message + mov byte ptr tmp_page,SPECFIX*2 ; convert opcode to a fixnum + mov tmp_disp,AX ; representation for use as "irritant" + mov AX,offset tmp_reg + jmp recom_1 ; jump to common processing point + +;************************************************************************ +;* Error-- Invalid Source Operand * +;************************************************************************ + public src_err +; Note: at this point, BX contains the address for text of failing inst. +src_err: xor AX,AX ; AX <- 0 + pushm ; push string address, 0 + C_call set_src_,,Load_ES ; call: set_src_err(text, 0); + jmp sch_err ; link to Scheme debugger + + +;************************************************************************ +;* Error-- Object Module Not Compatible With Current Revision Level * +;************************************************************************ +recompil: mov AX,offset nil_reg + mov BX,offset m_recomp +recom_1: mov CX,1 + pushm + C_call set_erro ; set the error parameters + restore ; reload the current location pointer + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* Error-- Feature Not Yet Implemented * +;************************************************************************ + public not_yet +not_yet: mov BX,offset m_not_yt ; load address of "not yet implemented" + push BX ; and push as argument to printf + dec SI ; back up location pointer + save ; and save it + +; ***general call to printf for message reporting*** + public printf_c +printf_c: C_call printf,,Load_ES ; call printf + mov SP,BP ; dump arguments off stack + restore ; reload location pointer into SI + jmp debug ; begin debug mode + +;************************************************************************ +;* Force Restart of Current Operation * +;************************************************************************ + public restart +restart: pop AX ; discard the return address + pop AX ; fetch instruction length + mov BP,reset_BP ; clean up the TIPC's stack +restart1: sub [BP].save_SI,AX ; back up the instruction pointer + jmp next_SP ; return to the Scheme interpreter + +;************************************************************************ +;* Link to the Scheme Debugger * +;************************************************************************ + public sch_err +sch_err: push SI ; save address of instruction to retry + call force_ca ; force a new stack frame to be built + mov SP,BP ; drop argument from TIPC's stack + mov BX,SPECCODE*2 ; load code base pointer for debug init + mov byte ptr CB_pag,BL + mov CB_dis,0 + LoadCode ES,BX ; load code base's paragraph address +; mov ES,pagetabl+[BX] ; load code base's paragraph address + save ; and save it off + mov SI,ERR_ent ; load error entry point offset + jmp next ; begin link to debugger + +;************************************************************************ +;* Scheme-Reset/Reset * +;* * +;* Purpose: To re-initialize the VM's environment to correct for * +;* some error condition * +;************************************************************************ + public force_re +force_re: mov BP,reset_BP ; reset TIPC stack to its initial state +; Note: control falls through to the scheme-reset code below + +s_reset: C_call scheme_r,,Load_ES ; Adjust fluid environment +; Note: control falls through the reset code below + +reset: C_call reset_fa,,Load_ES ; reset %fasl input data structures + xor AX,AX ; create a value of zero/nil +; set the "previous stack segment" register to nil + mov PREV_pag,AX + mov PREV_dis,AX +; set the current code base to the loader's code page + mov CB_dis,AX + mov CB_pag,SPECCODE*2 +; reset the current stack base to zero and initialize FP + mov BASE,AX + mov FP,AX + mov TOS,SF_OVHD-PTRSIZE +; set the location pointer and code paragraph address + mov BX,SPECCODE*2 + LoadCode ES,BX +; mov ES,pagetabl+[BX] + save + mov SI,RST_ent ; load the new location pointer +; Note: Control falls through the %clear-registers support below + +;************************************************************************ +;* Clear VM registers clear-regs * +;************************************************************************ +clr_regs: save ; save the current location pointer + mov BX,UN_DISP ; load pointer for "unbound" symbol + mov DX,UN_PAGE*2 + mov CX,NUM_REGS-2 ; load iteration count + mov DI,offset reg0+(SIZE C_ptr)*2 ; load address of VM register 2 + mov AX,DS ; set TIPC register ES to point to the + mov ES,AX ; current data section +clr_loop: mov AX,BX ; copy '**unbound** displacement pointer + stosw ; and store it into next register + mov AX,DX ; do likewise for the page number component + stosw ; for the '**unbound** symbol + loop clr_loop ; iterate through the VM's registers + xor AX,AX + mov DI,offset reg0 ; store #!false into R0 and R1 + mov CX,4 +rep stosw + mov tmp_disp,AX ; clear the VM's temporary register, too + mov tmp_page,AX + mov tm2_disp,AX ; clear the VM's temporary register, too + mov tm2_page,AX + jmp next_PC ; return to the interpreter + +;************************************************************************ +;* Escape to user defined assembly language or C Function %escn * +;************************************************************************ +s_esc1: mov CX,1 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc2: mov CX,2 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc3: mov CX,3 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc4: mov CX,4 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc5: mov CX,5 ; load argument count + jmp short s_escn ; branch to general argument load routine +s_esc6: mov CX,6 ; load argument count + jmp short s_escn ; branch to general argument load routine + public s_esc7 +s_esc7: mov CX,7 ; load argument count + jmp short s_escn ; branch to general argument load routine + +s_escn: mov DX,CX ; copy count of arguments +s_es_10: xor AX,AX + lods byte ptr ES:[SI] ; load next argument register number + add AX,offset reg0 + push AX + loop s_es_10 ; continue 'til all arguments processed + push DX ; push number of arguments + +IFDEF PROMEM +; +; This is pretty kludgy, but there wasn't time to redo all the %esc +; functions into vm codes, and we need software interrupt to work +; as before. Anyway, sw-int is the only %escape function with seven +; arguments, so lets short circuit here and call the protected mode +; software interrupt code. +; + cmp dx,7 ;are there seven arguments? + jne s_es_12 ; no, can't be sw_int + save ;save off instruction pointer + call softint ;and call the pro mode sw_int routine + cmp ax,0 ;any errors? + je s_es_20 ; no, jump +; errors - ax=error number, bx=msg address, cx=irritant + pushm ;push args to error routine + mov ax,ds + mov es,ax ;Lattice C needs DS=ES + C_call set_erro ;call error routine + restore ;restore instruction pointer + jmp sch_err ;and jump to scheme debugger +ENDIF + +s_es_12: + C_call asm_link,,Load_ES +s_es_13: + cmp AX,0 + je s_es_20 + restore ; restore address of next instruction + mov BX,offset m_esc + jmp src_err ; report some sort of operand error +s_es_20: jmp next_SP ; no error reported; return to interpreter + +;************************************************************************ +;* (%str-append str1 start1 end1 {nil,char,str2} str3 start3 end3) * +;************************************************************************ +s_append: jmp str_apnd ; far jump to substring-append support + +;************************************************************************ +;* (%substring-display str start end row-displacement window) * +;************************************************************************ + public s_disply ; ***temporary*** +s_disply: jmp str_disp ; far jump to substring-display support + +;************************************************************************ +;* Invoke garbage collection gc * +;************************************************************************ +gc: mov byte ptr tmp_page,0 ; clear tmp_reg prior to GC + mov tmp_disp,0 + mov byte ptr tm2_page,0 ; clear tm2_reg prior to GC + mov tm2_disp,0 + C_call garbage,,Load_ES ; call garbage collection driver + jmp next_SP + +;************************************************************************ +;* Invoke garbage collection with compaction gc2 * +;************************************************************************ +sgc2: mov byte ptr tmp_page,0 ; clear tmp_reg prior to GC + mov tmp_disp,0 + mov byte ptr tm2_page,0 ; clear tm2_reg prior to GC + mov tm2_disp,0 + C_call garbage,,Load_ES ; call garbage collection driver + C_call gcsquish + jmp next_SP + +;************************************************************************ +;* Begin Debug %begin-debug * +;************************************************************************ + public debug_op +debug_op: mov VM_debug,1 ; enable VM debugger for (%begin-debug) +debug: + mov AX,word ptr CS:trc_go ; modify interpreter to enable instr. + STORE_WORD_IN_CS PROG,next1,AX ; Protected Mode Macro + mov s_break,0 ; reset shift-break flag + mov AX,2 ; set return value = 2 (begin debug) + jmp short exit_010 + +exit_op: dec SI ; back up PC to won't fall past end + mov AX,1 ; set return value = 1 (halt) + jmp short exit_010 + +exit: xor AX,AX ; set return value = 0 (suspend) +exit_010: mov SP,BP + mov BX,[BP].cod_ent + mov [BX],SI + add SP,offset sint_BP + pop BP + mov DX,DGROUP + mov ES,DX + ret +run endp + +prog ends + end + \ No newline at end of file diff --git a/sinterp.mac b/sinterp.mac new file mode 100644 index 0000000..9e0e6cd --- /dev/null +++ b/sinterp.mac @@ -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, + lea BX,txt + push BX + endm + jmp printf_c + endm + \ No newline at end of file diff --git a/sio.asm b/sio.asm new file mode 100644 index 0000000..73a5edb --- /dev/null +++ b/sio.asm @@ -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 + + \ No newline at end of file diff --git a/slink.h b/slink.h new file mode 100644 index 0000000..738e30e --- /dev/null +++ b/slink.h @@ -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);} + \ No newline at end of file diff --git a/slist.h b/slist.h new file mode 100644 index 0000000..0a95927 --- /dev/null +++ b/slist.h @@ -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) + \ No newline at end of file diff --git a/smmu.asm b/smmu.asm new file mode 100644 index 0000000..7a2d8de --- /dev/null +++ b/smmu.asm @@ -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 + \ No newline at end of file diff --git a/smmu.mac b/smmu.mac new file mode 100644 index 0000000..ab84806 --- /dev/null +++ b/smmu.mac @@ -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 , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + mov dst,[SS:pagetabl+src] + ELSE + IFIDN , + 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 , + %OUT *AX as destination of %LoadPage not recommended* + ELSE + IFIDN , + %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 , + %OUT *AX as destination of %LoadPage0 not recommended* + ELSE + IFIDN , + %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 , + %OUT *AX as destination of %LoadPage1 not recommended* + ELSE + IFIDN , + %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 , + %OUT *AX as destination of %LoadPage not recommended* + ELSE + IFIDN , + %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 \ No newline at end of file diff --git a/sobjhash.asm b/sobjhash.asm new file mode 100644 index 0000000..0fc45d0 --- /dev/null +++ b/sobjhash.asm @@ -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 + 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 ; 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 ; 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 + \ No newline at end of file diff --git a/sport.h b/sport.h new file mode 100644 index 0000000..6343536 --- /dev/null +++ b/sport.h @@ -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 */ + \ No newline at end of file diff --git a/squish.asm b/squish.asm new file mode 100644 index 0000000..0a8dc51 --- /dev/null +++ b/squish.asm @@ -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 ; 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 , + mov [SI].car_page,AL ; store a forwarding pointer into the car + mov [SI].car,DI ; field of the source list cell +ELSE +IFIDN , + 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 + \ No newline at end of file diff --git a/srch_str.asm b/srch_str.asm new file mode 100644 index 0000000..7f0d8b4 --- /dev/null +++ b/srch_str.asm @@ -0,0 +1,1359 @@ +; =====> SRCH_STR.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* String Search Capabilities * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 21 July 1985 * +;* Last Modification: 17 October 1985 * +;*************************************** + include scheme.equ + include pcmake.equ + include sinterp.arg +IFDEF PROMEM + include rpc.equ + include xli_pro.mac + include realio.equ + .286c +ENDIF + +DGROUP group data +XGROUP group PROGX +PGROUP group prog + +MSDOS equ 021h +TI_CRT equ 049h +IBM_CRT equ 010h + +; Definitions for control characters +CTL_A equ 1 +CTL_I equ 9 +CTL_Z equ 26 + +data segment word public 'DATA' + assume DS:DGROUP +IFDEF PROMEM +;from pro2real.asm + extrn REAL_BUF_SELECTOR:word,REAL_BUF_TOP:word,RPC_HANDLE:byte +ENDIF +ret_sav1 dw 0 ; return address save area +ret_sav2 dw 0 ; return address save area +m_srch_f db "SUBSTRING-FIND-NEXT-CHAR-IN-SET",0 +m_srch_b db "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET",0 +m_st_ln db "STRING-LENGTH",0 +m_mk_str db "MAKE-STRING",0 +m_stapnd db "%STRING-APPEND",0 +m_reifs db "%REIFY-STACK",0 +m_reifsb db "%REIFY-STACK!",0 +m_st_dsp db "%SUBSTRING-DISPLAY",0 +m_opnd dw INVALID_OPERAND_ERROR ; numeric error code +m_one dw 1 ; a constant "one" (1) +data ends + +prog segment byte public 'PROG' + assume CS:PGROUP + extrn %allocbl:far ; "alloc_block" linkage routine + extrn next:far ; Interpreter's "next instruction" point + extrn next_PC:far ; Interpreter's "next instruction" point + extrn sch_err:far ; Linkage to Scheme debugger +;************************************************************************ +;* Far Linkage to "set_src_err" * +;************************************************************************ + public %set_src +%set_src proc far + pop ret_sav1 + pop ret_sav2 + push DS ; make ES point to the current data segment + pop ES + extrn set_src_:near + call set_src_ + push ret_sav2 + push ret_sav1 + ret +%set_src endp + +;************************************************************************ +;* Far Linkage to "set_numeric_error" * +;************************************************************************ + public %set_num +%set_num proc far + pop ret_sav1 + pop ret_sav2 + push DS ; make ES point to the current data segment + pop ES + extrn set_nume:near + call set_nume + push ret_sav2 + push ret_sav1 + ret +%set_num endp + +;************************************************************************ +;* Far Linkage to "dissamble" * +;************************************************************************ + public %disasse +%disasse proc far + pop ret_sav1 + pop ret_sav2 + push DS ; make ES point to the current data segment + pop ES + extrn disassem:near + call disassem + push ret_sav2 + push ret_sav1 + ret +%disasse endp + +;************************************************************************ +;* Far Linkage to "get_port" * +;************************************************************************ + public %getport +%getport proc far + pop ret_sav1 + pop ret_sav2 + push DS ; make ES point to the current data segment + pop ES + extrn get_port:near + call get_port + push ret_sav2 + push ret_sav1 + ret +%getport endp + +prog ends + +PROGX segment byte public 'PROGX' + assume CS:XGROUP + + extrn CRT_DSR:far + +;************************************************************************ +;* Substring-Find-Next-Char-in-Set * +;************************************************************************ +srch_arg struc +strt_off dw ? ; starting offset (16 bit positive integer) +end_off dw ? ; ending offset (16 bit positive integer) +lngth dw ? ; number of characters in source string +result dw ? ; index of character matched + +; Note: the following two entries are order dependent +str_beg dw ? ; beginning offset of string +str_DS dw ? ; segment register value for string + +srch_BP dw ? ; caller's BP + dw ? ; caller's ES + dd ? ; return address (far) + dw ? ; return address (near) +str_reg dw ? ; register containing string +strt_reg dw ? ; register containing substr starting offset +end_reg dw ? ; register containing substr ending offset +cs_reg dw ? ; register containing charset string +srch_arg ends + +srch_str proc far + +%srchprv label far + mov CX,1 ; set search direction = backward + jmp short srch_go ; go to common processing code + +; Long Branch to Source Error Support +srch_er1: jmp srch_err + +%srchnxt label far + xor CX,CX ; set search direction = forward + +srch_go: push ES ; save caller's ES register + push BP ; save caller's BP register + sub SP,offset srch_BP ; allocate local storage + mov BP,SP ; establish addressability of local data + +; Validate Source String Argument + mov BX,[BP].str_reg ; load address of string register + mov SI,[BX].C_page ; and load string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; is source string a string? + jne srch_er1 ; if not a string, error (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load string's paragraph address + mov SI,[BX].C_disp ; load displacement of string + mov AX,ES:[SI].str_len ; load length of string + cmp AX,0 ;;; check length of string + jge srch_01 + add AX,PTRSIZE + jmp srch_02 +srch_01: sub AX,BLK_OVHD ; and compute number of characters in it +srch_02: mov [BP].lngth,AX ; save string length for further testing + add SI,BLK_OVHD ; advance string start to first character + mov [BP].str_beg,SI ; save starting character offset + mov [BP].str_DS,ES ; and segment register pointer + +; Validate Starting Offset Argument + mov BX,[BP].strt_reg ; load address of starting offset regsiter + call get_num ; obtain the integer value + jc srch_er1 ; if carry set, error + mov [BP].strt_off,AX ; and save it for future use + +; Validate Ending Offset Argument + mov BX,[BP].end_reg ; load address of ending offset register + call get_num ; obtain the integer value + jc srch_er1 ; if carry set, error + cmp [BP].strt_off,AX ; is starting offset greater than ending? + ja srch_er1 ; if so, invalid substring range (jump) + cmp AX,[BP].lngth ; test ending offset against string length + ja srch_er1 ; if ending offset too big, error (jump) + mov [BP].end_off,AX ; save ending offset for future use + +; Validate Charset String Argument + mov BX,[BP].cs_reg ; load number of register holding charset + mov DI,[BX].C_page ; load page number of charset pointer + cmp byte ptr ptype+[DI],STRTYPE*2 ; this is a sting, isn't it? + jne char_p ; if not a string, error (jump) + %LoadPage ES,DI +;;; mov ES,pagetabl+[DI] ; load paragraph address of string + mov DI,[BX].C_disp ; load displacement of string in page + mov DX,ES:[DI].str_len ; load length of string object + cmp DX,0 ;;; check length of string + jge srch_03 + add DX,PTRSIZE + jmp srch_04 +srch_03: sub DX,BLK_OVHD ; compute number of characters in charset +srch_04: add DI,BLK_OVHD ; advance string pointer past block header + jmp short go +char_p: cmp DI,SPECCHAR*2 ; is charset argument a single character? + je char_p0 ; Yes, continue + jmp srch_er1 ; No, error (jump) + +; Single character search-- optimize it +char_p0: mov AL,byte ptr [BX].C_disp + les DI,dword ptr [BP].str_beg + mov DX,CX ; save direction indicator in DX + mov CX,[BP].end_off ; compute length of search string + sub CX,[BP].strt_off + je not_fnd1 ; if search length is zero, return 'nil + cmp DX,0 + jne b_ward ; if backward, jump +; search for single character in forward direction + add DI,[BP].strt_off ; compute address of start of substring +repne scasb ; search for single character + jne not_fnd1 ; character found? If so, jump + dec DI ; fix up ending index + jmp short over +; search for single character in backward direction +b_ward: add DI,[BP].end_off ; compute address of end of substring + dec DI + std ; set search direction to be backwards +repne scasb ; search for single character + cld ; reset "direction" flag to go forwards + jne not_fnd1 ; if search length is zero, return 'nil + inc DI ; fix up ending index +over: mov SI,DI ; copy character address to SI + sub SI,[BP].str_beg ; and compute found character's address + jmp short found ; return index to found character + +; Determine whether string search is forward or backward +go: push DS ; save the data segment address + cmp CX,0 ; in which direction are we to search? + je forward ; if CX=0, forward; else backward + +; Register Usage in Innermost Loop: +; DS:SI - pointer to next character in source string +; ES:DI - pointer to charset string +; AL - search character +; BX - ending offset (source string) +; CX - length of charset string +; DX - length of charset string (used to refresh CX) + +; Search Source String in a Backwards Direction + mov BX,[BP].str_beg ; compute ending offset for string + add BX,[BP].strt_off + lds SI,dword ptr [BP].str_beg ; load addr of string's beginning + add SI,SS:[BP].end_off ; and compute end of substring address + jmp short startb ; jump to initial entry point in loop + +loopb: sub DI,DX ; reset starting offset of charset string +startb: cmp SI,BX ; at beginning of substring? + jbe not_fnd ; if at end, jump + mov CX,DX ; reload charset string length + dec SI ; decrement source string index + mov AL,[SI] ; and load next character to test +repne scasb ; search charset for current character + jne loopb + pop DS ; restore DS to point to data segment + sub SI,[BP].str_beg ; compute index of current character + jmp short found ; current character found in charset + +; no characters found which appear in the charset +not_fnd: pop DS ; restore DS to current data segment +not_fnd1: xor AX,AX ; store #!false in the + mov BX,[BP].str_reg ; destination register + mov byte ptr [BX].C_page,AL + mov [BX].C_disp,AX + jmp short ret ; return to caller + +; Search Source String in a Forward Direction +forward: mov BX,[BP].str_beg ; compute ending offset for string + add BX,[BP].end_off + lds SI,dword ptr [BP].str_beg ; load addr of string's beginning + add SI,SS:[BP].strt_off ; and compute beginning of substring + jmp short start ; jump to initial entry point in loop + +loop: sub DI,DX ; reset starting offset of charset string +start: cmp SI,BX ; at end of source string? + jae not_fnd ; if at end, jump + mov CX,DX ; reload charset string length + lodsb ; load next character to test +repne scasb ; search charset for current character + jne loop + +; current character found in charset-- return offset of current character + pop DS ; restore DS to current data segment + sub SI,[BP].str_beg ; adjust offset of character found + dec SI +found: mov BX,[BP].str_reg ; load address of destination register + call ret_num ; convert offset to Scheme integer + +; return to caller +ret: xor AX,AX ; set completion code for normal return +ret1: add SP,offset srch_BP ; release local storage + pop BP ; restore the caller's BP register + pop ES ; restore the caller's ES register + ret ; return + +; error-- invalid operand to string search primitive +srch_err: pushm <[BP].cs_reg,[BP].end_reg,[BP].strt_reg,[BP].str_reg> + cmp CX,0 ; search forward or backward? + jne backward ; if backward search, jump + mov AX,offset m_srch_f + jmp short common +backward: mov AX,offset m_srch_b +common: mov BX,4 ; load VM argument count + pushm ; push args=4, name of instruction + call %set_src ; call set_src_err(...); + mov AX,-1 ; load "invalid operand" flag + mov SP,BP ; drop arguments off the TIPC's stack + jmp ret1 ; return to interpreter + +srch_str endp + +dumy_arg struc + dw ? ; caller's BP + dd ? ; return address (far linkage) + dw ? ; return address (near linkage) +arg1 dw ? ; register address for argument 1 +arg2 dw ? ; register address for argument 2 +arg3 dw ? ; register address for argument 3 +arg4 dw ? ; register address for argument 4 +dumy_arg ends + +;************************************************************************ +;* AL * +;* (string-length string) string-length d=s1 * +;* * +;* Purpose: Scheme Interpreter support for the "string-lengt" function.* +;************************************************************************ +%st_len proc far + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for arguments +; validate the string argument + mov BX,[BP].arg1 ; load address of argument register + mov SI,[BX].C_page ; load the string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it? + jne st_l_err ; if not a string, error (jump) +; compute string length + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load paragraph address of string's page + mov SI,[BX].C_disp ; load string's displacement + mov SI,ES:[SI].str_len ; load length field from string object + cmp SI,0 ;;; check length of string + jge str_010 + add SI,PTRSIZE + jmp str_020 +str_010: sub SI,BLK_OVHD ; and compute number of characters in it +; return string length as an integer +str_020: call ret_num ; create Scheme representation for integer +; return + xor AX,AX ; set error code for normal return +str_ret: pop BP ; restore the caller's BP register + ret ; return to caller +; ***error-- operand was not a string*** +st_l_err: mov AX,offset m_st_ln ; load text address for "STRING-LENGTH" + mov CX,1 ; indicate one operand + pushm ; push arguments for call + call %set_src ; call: set_src_err("STRING-LENGTH",1,arg1) + mov SP,BP ; drop arguments off stack + mov AX,-1 ; indicate error return + jmp str_ret ; return +%st_len endp + +;************************************************************************ +;* MAKE-STRING (MAKE-STRING LENGTH INIT-VAL) * +;* * +;* Purpose: Scheme Interpreter support for the "MAKE-STRING" function. * +;* * +;* Note: The maximum length of a PCS string is 2^16 - 3 (65,532) * +;* characters. * +;************************************************************************ +%makestr proc far + push BP ; save the caller's BP register + mov BP,SP ; establish addressability for arguments +; validate the length operand + mov BX,[BP].arg1 ; load address of reg containing length + call get_num ; get the value of the integer + jc mk_s_err ; error? if so, jump +; allocate the string object + mov CX,STRTYPE ; load the type code for a string + pushm ; push arguments for the call + call %allocbl ; call: alloc_block(arg1, STRTYPE, length) + mov SP,BP ; drop the arguments off the stack +; validate the initialization value + mov BX,[BP].arg2 ; load address of register with init value + mov SI,[BX].C_page ; load initialization value's page number + cmp SI,0 ; default initialization value (nil)? + jne mk_s_ch ; if not nil, check for character (jump) + mov AL," " ; use blank (" ") as default fill value + jmp short mk_s_in ; initialize the string +mk_s_ch: cmp SI,SPECCHAR*2 ; is initialization value a character? + jne mk_s_err ; if not a character or nil, error (jump) + mov AL,byte ptr [BX].C_disp ; load the value of the character +; initialize the string +mk_s_in: mov BX,[BP].arg1 ; load a pointer to the newly allocated + mov DI,[BX].C_disp + mov BX,[BX].C_page + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov CX,[BP].arg3 ; load length of string object + add DI,BLK_OVHD ; advance string ptr to 1st char position +rep stosb ; propagate initval throughout string +; return to caller + xor AX,AX ; set the return code for a normal return +mk_s_ret: pop BP ; restore the caller's BP register + ret ; return +; ***error-- invalid operand to MAKE-STRING*** +mk_s_err: mov AX,offset m_mk_str ; load addr of "MAKE-STRING" text + mov BX,2 ; load argument count = 2 + pushm <[BP].arg2,[BP].arg1,BX,AX> + call %set_src ; set_src_err("MAKE-STRING",2,arg1,arg2) + mov SP,BP ; drop arguments off TIPC stack + mov AX,-1 ; indicate error return + jmp short mk_s_ret ; return +%makestr endp + +;************************************************************************ +;* (%str-append str1 start1 end1 {nil,char,str2} str3 start3 end3) * +;************************************************************************ +str_arg struc +start1 dw ? ; starting offset of first string +start3 dw ? ; starting offset of third string +len1 dw ? ; length of first string +len2 dw ? ; length of second string +len3 dw ? ; length of third string +str_BP dw ? ; caller's BP + dw ? ; caller's SI + dw ? ; caller's ES +reg7 dw ? ; address of 7th operand register +reg6 dw ? ; address of 6th operand register +reg5 dw ? ; address of 5th operand register +reg4 dw ? ; address of 4th operand register +reg3 dw ? ; address of 3rd operand register +reg2 dw ? ; address of 2nd operand register +reg_1 dw ? ; address of 1st operand register +str_arg ends + + public str_apnd +%strapnd proc far +str_err1: jmp str_err ; indirect jump to error code +; Load operands of this here instruction and compute register addresses +str_apnd: mov CX,7 ; load count of number of operands +str_ld: xor AX,AX ; clear AH + lods byte ptr ES:[SI] ; load register number of this operand + add AX,offset reg0 ; and compute the register's address + push AX ; save the register's address on the stack + loop str_ld ; continue until all operands processed +; Save registers and establish addressability of local storage + push ES ; save caller's ES register + push SI ; save caller's SI register + push BP ; save caller's BP register + sub SP,offset str_BP ; allocate local storage + mov BP,SP ; and establish addressability + +; Validate the First String's Starting Offset + mov BX,[BP].reg2 ; load address of start1 register + call get_num ; fetch value for start1 + jc str_err1 ; if error, jump + add AX,BLK_OVHD ; advance starting offset past block header + mov [BP].start1,AX ; save start1 offset +; Validate the First String's Ending Offset + mov BX,[BP].reg3 ; load address of end1 register + call get_num ; fetch value for end1 + jc str_err1 ; if error, jump + add AX,BLK_OVHD ; advance ending offset past block header +; Validate the First String Operand + mov BX,[BP].reg_1 ; load address of string1 register + mov SI,[BX].C_page ; load string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it? + jne str_err1 ; if not a string, error (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load a pointer to the string + mov SI,[BX].C_disp + mov CX,ES:[SI].str_len ; ending offset past string end? + cmp CX,0 ;;; check length of string + jge str_01 + add CX,BLK_OVHD+PTRSIZE ;;; adjust the string length +str_01: cmp AX,CX + ja str_err1 ; if ending offset too big, error (jump) + sub AX,[BP].start1 ; is ending offset too small? + jb str_err1 ; if ending offset smaller than start, jump + mov [BP].len1,AX ; save length of substring1 + +; Validate the Third String's Starting Offset + mov BX,[BP].reg6 ; load address of start3 register + call get_num ; fetch value for start3 + jc str_err ; if error, jump + add AX,BLK_OVHD ; advance starting offset past block header + mov [BP].start3,AX ; save start3 offset +; Validate the Third String's Ending Offset + mov BX,[BP].reg7 ; load address of end3 register + call get_num ; fetch value for end3 + jc str_err ; if error, jump + add AX,BLK_OVHD ; advance ending offset past block header +; Validate the Third String Operand + mov BX,[BP].reg5 ; load address of string3 register + mov SI,[BX].C_page ; load string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it? + jne str_err ; if not a string, error (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load a pointer to the string + mov SI,[BX].C_disp + mov CX,ES:[SI].str_len ; ending offset past string end? + cmp CX,0 ;;; check length of string + jge str_02 + add CX,BLK_OVHD+PTRSIZE ;;; adjust the string length +str_02: cmp AX,CX + ja str_err ; if ending offset too big, error (jump) + sub AX,[BP].start3 ; is ending offset too small? + jb str_err ; if ending offset smaller than start, jump + mov [BP].len3,AX ; save length of substring3 + +; Validate the "thing" to be inserted between string1 and string3 + mov BX,[BP].reg4 ; load register with said "thing" + mov SI,[BX].C_page ; load page number + cmp SI,NIL_PAGE*2 ; is object nil? + jne str_10 ; if not nil, jump +; The "thing" is nil-- indicate nothing to insert + mov [BP].len2,0 ; indicate zero length "thing" + jmp short str_30 ; continue processing + +; ***We interrupt this routine for some error support code*** +str_err: mov AX,offset m_stapnd + mov CX,7 + pushm <[BP].reg7,[BP].reg6,[BP].reg5,[BP].reg4,[BP].reg3> + pushm <[BP].reg2,[BP].reg_1,CX,AX> + call %set_src + mov SP,BP + add SP,offset str_BP + pop BP + pop SI + pop ES + jmp sch_err + +str_10: cmp SI,SPECCHAR*2 ; is "thing" a character? + jne str_20 ; if not a character, jump +; The "thing" is a character + mov [BP].len2,1 ; indicate length = 1 character + jmp short str_30 +str_20: cmp byte ptr ptype+[SI],STRTYPE*2 ; is "thing" a string? + jne str_err ; if not a string, error (jump) +; The "thing" is a string-- establish string length + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load string page's paragraph address + mov SI,[BX].C_disp + mov AX,ES:[SI].str_len + cmp AX,0 ;;; check length of string + jge str_03 + add AX,PTRSIZE + jmp str_04 +str_03: sub AX,BLK_OVHD ; and compute number of characters in it +str_04: mov [BP].len2,AX ; save string length for further testing + +; All arguments OK, allocate the new string +str_30: mov AX,[BP].len1 ; compute the length of the new string + add AX,[BP].len2 + add AX,[BP].len3 + cmp AX,16383 ; is new string greater than max string size? + jg str_err ; Yes ... error + mov BX,STRTYPE ; load tag=string + mov CX,offset tmp_reg + pushm ; push arguments to call + call %allocbl + mov SP,BP ; drop arguments off the stack + mov DI,tmp_page ; load pointer to newly allocated string + %LoadPage0 ES,DI +;;; mov ES,pagetabl+[DI] + mov DI,tmp_disp ; pointer is now in ES:[DI] + add DI,BLK_OVHD ; advance pointer to 1st character location +; Move in data from all substrings + mov CX,[BP].len1 ; load length of string1 + mov BX,[BP].reg_1 ; load addr of register containing string 1 + mov SI,[BX].C_disp ; load string 1's offset + add SI,[BP].start1 ; add in offset of starting character + mov BX,[BX].C_page ; load page number + push DS ; save the data segment register + %LoadPage1 DS,BX +;;; mov DS,pagetabl+[BX] +;********************************************************************** +;* * * Warning: The data segment register (DS) does not point to * * * +;* * * the data segment in the code which follows * * * +;********************************************************************** +rep movsb ; copy string1 into new string + pop DS ; restore data segment register + + mov CX,[BP].len2 ; load length of string2 + cmp CX,0 ; any characters to move? + je str_60 ; if no characters, jump + mov BX,[BP].reg4 ; load addr of register with "thing" + mov SI,SS:[BX].C_disp ; load a pointer to "thing" + mov BX,SS:[BX].C_page + push DS ; Save data segment register + cmp BL,SPECCHAR*2 ; is "thing" a character? + jne str_40 ; if not a character, then a string (jump) + mov SI,[BP].reg4 ; load addr of register containing character + jmp short str_50 +str_40: %LoadPage1 DS,BX +;;; mov DS,SS:pagetabl+[BX] ; "thing" is a string-- load pointer + add SI,BLK_OVHD ; to it and advance to 1st character +str_50: +rep movsb ; copy string2 into new string + pop DS ; restore data segment register + +str_60: mov CX,[BP].len3 ; load length of string3 + mov BX,[BP].reg5 ; load addr of register containing string 3 + mov SI,SS:[BX].C_disp ; load string offset + add SI,[BP].start3 ; advance starting offset past block header + mov BX,SS:[BX].C_page ; load the string's page number and + push DS + %LoadPage1 DS,BX +;;; mov DS,SS:pagetabl+[BX] ; paragraph address +rep movsb ; copy string3 into new string + pop DS ; restore the data segment register +;********************************************************************** +;* * * Warning: The data segment register (DS) does not point to * * * +;* * * the data segment in the code above * * * +;********************************************************************** + +; Place pointer to new string into the destination register + mov DI,[BP].reg_1 ; load destination register address + mov AL,byte ptr tmp_page + mov byte ptr [DI].C_page,AL + mov AX,tmp_disp + mov [DI].C_disp,AX + +; Return + add SP,offset str_BP ; deallocate local storage + pop BP ; restore caller's BP + pop SI ; restore caller's SI + pop ES ; restore caller's ES + jmp next ; return to Scheme interpreter + +%strapnd endp + +;************************************************************************ +;* Reify(!)-Stack * +;* * +;* Purpose: To provide the ability to manipulate items on the Scheme * +;* runtime stack from Scheme. * +;* * +;* Description: The elements of the stack are referenced by providing * +;* the byte offset of the desired element as an index * +;* to the REIFY-STACK or REIFY-STACK! instruction. An * +;* index of -1 to REIFY-STACK is a request that the current* +;* stack frame pointer be returned. * +;************************************************************************ +r_stk struc +bang dw ? ; fetch/store indicator +r_stk_BP dw ? ; caller's BP + dd ? ; return address (far call) + dw ? ; return address (near call) +r_index dw ? ; register containing index; destination reg +r_value dw ? ; register containing value (for stores) +r_stk ends + +%reifyst proc far +; ***Error-- Invalid Index for REIFY-STACK(!) Instruction*** +reif_err: cmp CX,0 ; is this a fetch or store? + jne reif_e10 ; if store, jump + mov AX,offset m_reifs ; load text address for "REIFY-STACK" + mov BX,1 ; indicate 1 operand to this instruction + jmp short reif_e20 ; jump to common error code +reif_e10: mov AX,offset m_reifsb ; load text address for "REIFY-STACK!" + mov BX,2 ; indicate 2 operands to this instruction + push [BP].r_value ; and push second reigster operand +reif_e20: pushm <[BP].r_index,BX,AX> ; push arguments + call %set_src ; indicate source operand error + mov SP,BP ; drop arguments off the stack + mov AX,-1 ; load an error flag + jmp reif_rt1 ; return with error flag in AX + +; (REIFY-STACK! index value) ; entry point +%reifstb label far + mov CX,1 ; indicate a store operation + jmp short reif_go ; jump to common entry code + +; (REIFY-STACK index) ; entry point +%reifstk label far + xor CX,CX ; indicate a fetch operation + +reif_go: push BP ; save the caller's BP register + sub SP,offset r_stk_BP ; allocate local storage + mov BP,SP ; establish addressability for operands/data + +; Validate index + mov BX,[BP].r_index ; load address of register containing index + cmp CX,0 ; is this a REIFY-STACK operation? + jne reif_no ; if not, skip special check for -1 +; Check for an index of -1 indicating we need to return FP + cmp byte ptr [BX].C_page,SPECFIX*2 ; is index a fixnum? + jne reif_no ; if not a fixnum index, jump + cmp [BX].C_disp,07FFFh ; is index a -1? + jne reif_no ; if not -1, jump + mov AX,FP ; load FP's offset in stack buffer + add AX,BASE ; and add BASE to compute absolute offset + mov SI,AX ; copy quotient to SI + call ret_num ; convert element index to a Scheme integer + jmp reif_ret ; return the element index of FP +; Fetch the index value +reif_no: call get_num ; fetch the integer value + jc reif_err ; if not a valid index, jump + push AX ; save the byte offset + xor DX,DX ; convert to a double word (w/out sign ext) + mov BX,PTRSIZE ; load divisor + div BX ; divide by number of bytes/pointer + pop AX ; restore the byte index + cmp DX,0 ; is remainder zero? + jne reif_err ; if not a multiple of PTRSIZE, error (jump) + mov DX,BASE ; compute the current top of stack (TOS) + add DX,TOS ; offset + cmp AX,DX ; is index larger than TOS? + ja reif_err ; if so, error (jump) + +; Attempt to find the desired element in the stack buffer + cmp AX,BASE ; is BASE < element index? + jb reif_cnt ; if so, element is in previous stack segment + sub AX,BASE ; compute byte offset of desired element + add AX,offset S_stack ; compute offset in stack buffer + mov SI,AX ; and move offset into SI + mov AX,DS ; put data segment address into ES so that + mov ES,AX ; desired element is pointed to by ES:[SI] + jmp reif_do ; fetch/store the element + +; Find the element in a previous stack segment (a continuation object) +reif_cnt: mov BX,PREV_pag ; make ES:[SI] point to the previous + mov SI,PREV_dis ; stack segment continuation object + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] +; Follow stack segment chain until desired offset found +reif_lop: cmp AX,ES:[SI].con_base ; compare element index:continuation base + jae reif_fnd ; if offset > base, element in this segment + mov BL,ES:[SI].con_spag ; load pointer to previous stack segment + mov SI,ES:[SI].con_sdis ; into ES:[SI] + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; + jmp short reif_lop ; loop until desired segment found +; Element found in stack segment (continuation) object +reif_fnd: sub AX,ES:[SI].con_base ; subtrace off continuation's base + add SI,AX ; add entry's byte offset + add SI,offset con_data ; adjust for continuation header + +; Desired stack element address by ES:[SI]-- is this a fetch or store? +reif_do: cmp CX,0 ; test fetch/store flag + jne reif_st ; if a store, jump +; Fetch desired stack element + mov BX,[BP].r_index ; load address of destination register + mov AL,ES:[SI].car_page ; load page number of stack entry + mov byte ptr [BX].C_page,AL ; and store into destination register + mov AX,ES:[SI].car ; load displacement of stack entry + mov [BX].C_disp,AX ; and store into destination register + jmp short reif_ret +; Re-define desired stack element +reif_st: mov BX,[BP].r_value ; load add of register containing new value + mov AL,byte ptr [BX].C_page + mov ES:[SI].car_page,AL + mov AX,[BX].C_disp + mov ES:[SI].car,AX + +; return to caller +reif_ret: xor AX,AX ; indicate no error encountered +reif_rt1: add SP,offset r_stk_BP ; deallocate local storage + pop BP ; restore the caller's BP register + ret ; return to caller +%reifyst endp + +;************************************************************************ +;* AL AL AH AL AH * +;* (%SUBSTRING-DISPLAY string start end row-bias window) * +;* * +;* Purpose: Special support for displaying strings to the CRT for * +;* applications such as text editors. * +;************************************************************************ + +IFDEF PROMEM + +SD_BSIZE equ 100 ; buffer size +sd_args struc +; Warning: the following five (5) items are order dependent +sd_dummy dw ? ; extra for realio +sd_len dw ? ; #chars in following buffer +sd_buff db SD_BSIZE dup (?) ; string buffer +sd_text dw ? ; text attributes for window +sd_cursv dw ? ; cursor coordinate save area +; +sd_char db ? ; "saved" character +sd_streg dw ? ; string register address +sd_start dw ? ; substring's starting offset +sd_end dw ? ; substring's ending offset +sd_bias dw ? ; row bias +sd_cline dw ? ; cursor line number +sd_ccol dw ? ; cursor column number +sd_nline dw ? ; number of lines in the window +sd_ncols dw ? ; number of columns in the window +sd_ullin dw ? ; upper left corner line number +sd_ulcol dw ? ; upper left corner column number +sd_arg45 dw ? ; arguments 4,5 save area +sd_last dw ? ; last write flag +sd_linum db ? ; line number +; Warning: the following two (2) items are order dependent +sd_wn_SI dw ? ; pointer to window object, part 1 +sd_wn_ES dw ? ; pointer to window object, part 2 +; +sd_BP dw ? ; caller's BP +sd_args ends + +ELSE + +sd_args struc +sd_buff db 100 dup (?) ; string buffer +sd_char db ? ; "saved" character +sd_streg dw ? ; string register address +sd_start dw ? ; substring's starting offset +sd_end dw ? ; substring's ending offset +sd_bias dw ? ; row bias +sd_cline dw ? ; cursor line number +sd_ccol dw ? ; cursor column number +sd_nline dw ? ; number of lines in the window +sd_ncols dw ? ; number of columns in the window +sd_ullin dw ? ; upper left corner line number +sd_ulcol dw ? ; upper left corner column number +sd_text dw ? ; text attributes for window +sd_arg45 dw ? ; arguments 4,5 save area +sd_cursv dw ? ; cursor coordinate save area +sd_last dw ? ; last write flag +sd_linum db ? ; line number +; Warning: the following two (2) items are order dependent +sd_wn_SI dw ? ; pointer to window object, part 1 +sd_wn_ES dw ? ; pointer to window object, part 2 +; +sd_BP dw ? ; caller's BP +sd_args ends +SD_BSIZE equ sd_char-sd_buff ; buffer size + +ENDIF + public str_disp +strdisp proc far +sd_err1: jmp sd_err ; indirect branch to error code + +; load all five (5) of this instruction's operands +str_disp: lods byte ptr ES:[SI] + add AX,offset reg0 + mov BX,AX ; save address of string register + lods word ptr ES:[SI] + mov DX,AX + lods word ptr ES:[SI] + save ; save location pointer + +; allocate local storage + push BP + sub SP,offset sd_BP + mov BP,SP + mov [BP].sd_last,0 ; initialize "last write?" flag + mov [BP].sd_linum,0 ; line number + +; save off argument information + mov [BP].sd_streg,BX + mov [BP].sd_arg45,AX + +; validate the string offsets + xor BX,BX ; clear register BX + mov BL,DL ; copy starting offset register number + add BX,offset reg0 ; and compute register's address + call get_num ; obtain starting offset + jc sd_err1 ; valid offset? if not, error (jump) + add AX,BLK_OVHD ; adjust offset for block header + mov [BP].sd_start,AX ; save starting offset + xor BX,BX + mov BL,DH ; copy ending offset register number + add BX,offset reg0 ; and compute register's address + call get_num ; obtain ending offset + jc sd_err1 ; valid offset? if not, error (jump) + add AX,BLK_OVHD ; adjust offset for block header + cmp AX,[BP].sd_start ; is ending offset greater than starting? + jb sd_err1 ; if ending offset smaller, error (jump) + mov [BP].sd_end,AX ; save ending offset + +; validate the row-bias + xor BX,BX + mov BL,byte ptr [BP].sd_arg45 + cmp byte ptr reg0_pag+[BX],SPECFIX*2 + je next$0 + jmp sd_err +next$0: mov AX,reg0_dis+[BX] + shl AX,1 + sar AX,1 + mov [BP].sd_bias,AX + +; Validate the window operand + xor AX,AX + mov AL,byte ptr [BP].sd_arg45+1 + add AX,offset reg0 + pushm ; push mode=output, reg address + call %getport ; map port operand (result in tmp_reg) + cmp AX,0 ; valid port operand? + jne sd_err ; if not a port, error (jump) + mov SI,tmp_page ; load a pointer to the port object + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] + mov SI,tmp_disp + mov AX,ES:[SI].pt_pflgs ; load the port attributes + test AX,WINDOW ; is this port a window? + jz sd_err ; if not a window, error (jump) + test AX,OPEN ; window open for output? + jnz sd_open ; if open, jump + jmp sd_done ; if closed, ignore I/O request (jump) +; Move parameters from the window object to local storage +sd_open: mov AX,ES:[SI].pt_cline ; get cursor line number + mov [BP].sd_cline,AX + mov AX,ES:[SI].pt_ccol ; get cursor column number + mov [BP].sd_ccol,AX + mov AX,ES:[SI].pt_nline ; get number of lines in window + mov [BP].sd_nline,AX + mov AX,ES:[SI].pt_ncols ; get number of columns in window + mov [BP].sd_ncols,AX + mov AX,ES:[SI].pt_ullin ; get upper left corner's line number + mov [BP].sd_ullin,AX + mov AX,ES:[SI].pt_ulcol ; get upper left corner's column number + mov [BP].sd_ulcol,AX + mov AX,ES:[SI].pt_text ; get window's text attributes + mov [BP].sd_text,AX + mov [BP].sd_wn_ES,ES ; save pointer to window object + mov [BP].sd_wn_SI,SI + jmp short sd_more ; branch over error code + +; ***error-- invalid operand*** +sd_err: mov SP,BP ; clean up stack + add SP,offset sd_BP + pop BP + restore ; load address of next instruction and + sub SI,6 ; adjust for 5 operands + opcode + mov AX,offset m_st_dsp ; load address of "SUBSTRING-DISPLAY" + pushm ; push arguments to "disassemble" + call %disasse ; create *irritant* (pointer in tmp_reg) + pushm ; push operands + call %set_num ; indicate source operand error + jmp sch_err ; Link to Scheme debugger + +; validate the string operand +sd_more: mov BX,[BP].sd_streg ; load string register's address + mov SI,[BX].C_page ; load string's page number + cmp byte ptr ptype+[SI],STRTYPE*2 ; type = string? + jne sd_err ; if not a string, error (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load pointer to string + mov SI,[BX].C_disp + mov AX,ES:[SI].str_len ; load string's length + cmp AX,0 ;;; check length of string + jge sd_010 + add AX,BLK_OVHD+PTRSIZE ;;; adjust for small string +sd_010: cmp AX,[BP].sd_end ; is ending offset too big? + jb sd_err ; if too big, error (jump) +; Note: ES:[SI] points to the source string + mov DX,[BP].sd_end ; load ending displacement and + add DX,SI ; compute ending address + add SI,[BP].sd_start ; compute starting address + +; translate the string into the local buffer + mov CX,[BP].sd_ccol ; load current cursor position + mov BX,[BP].sd_ncols ; load line length + mov DI,BP ; load pointer to local data + add DI,sd_buff ; and address buffer + push DS ; save the data segment register + mov AX,ES ; make DS point to the page containing + mov DS,AX ; the source string +;********************************************************************** +;* * * Warning: The data segment register (DS) does not point to * * * +;* * * the data segment in the code which follows * * * +;********************************************************************** + pop ES ; make ES point to the data segment + push ES + +; Register usage: ES:[DI] - next character in output buffer +; DS:[SI] - next character in source string +; BX - number of columns in window +; CX - current column (cursor position) relative to window +; DX - end of source string address + +sd_next: cmp SI,DX ; end of input string? + jae sd_final ; if end of string, jump + lodsb ; fetch next character from string + cmp AL,CTL_Z ; possible control character? + ja sd_norml ; if not control character, jump + cmp AL,CTL_A ; nul character? + jb sd_next ; if nul character, ignore it (jump) + cmp AL,CTL_I ; tab character? + jne sd_notab ; if not a tab, jump +; TAB character-- output a series of blanks + mov AL," " ; load a blank to store one or more times + mov AH,CL ; copy cursor position + sub AH,[BP].sd_linum ; and adjust for line number +sd_tloop: stosb ; store a blank to the output buffer + inc CX ; increment the current column number + inc AH + test AH,07h ; is next column a multiple of eight? + jnz sd_tloop ; if not, loop + jmp sd_test +; "normal" control character-- prefix with "^" +sd_notab: mov AH,AL ; save control character + mov AL,"^" ; load a "^" character and output to buffer + stosb + inc CX + mov AL,AH ; copy control character to AL and + add AL,"A"-CTL_A ; compute alphabetic for said +; non- control character-- just copy to output buffer +sd_norml: stosb ; store character into output buffer + inc CX ; increment the current column number +sd_test: cmp CX,BX ; line full? + jb sd_next ; if more room on current line, loop + +; Full line buffered-- display it on the screen + call flush ; display line + mov AX,[BP].sd_cline ; load the current line number + cmp AX,[BP].sd_nline ; are we at the end of the screen? + jl sd_next ; if more lines in window, jump +; Window full-- set cursor position to last line + 1, column 0 + les SI,dword ptr [BP].sd_wn_SI ; load pointer to window object + mov ES:[SI].pt_ccol,0 ; set next column number to zero + mov CX,[BP].sd_cline ; store next line number into window + mov ES:[SI].pt_cline,CX ; object, too + jmp sd_fin ; window full, jump + +; end of string-- output final line +sd_final: push ES ; save pointer to data segment + les SI,dword ptr [BP].sd_wn_SI ; load pointer to window object + mov AX,CX ; save current column + mov ES:[SI].pt_ccol,CX ; store next column into window object + mov CX,[BP].sd_cline ; store current line number into window + mov ES:[SI].pt_cline,CX ; object, too + pop ES ; restore pointer to data segment + mov CX,SD_BSIZE-1 ; load buffer length + sub CX,AX ; subtract number of columns in buffer + mov AL," " ; load a blank +rep stosb ; blank the remainder of output buffer + mov [BP].sd_last,1 ; indicate last line + call flush ; display to screen +sd_fin: pop DS ; restore DS + +;********************************************************************** +;* * * Warning: The data segment register (DS) does not point to * * * +;* * * the data segment in the code above * * * +;********************************************************************** + +; Operation complete-- return to Scheme interpreter +sd_done: mov SP,BP ; clean up anything pushed on stack + add SP,offset sd_BP ; deallocate local storage + pop BP ; restore Scheme interpreter's BP + jmp next_PC ; return to Schemem interpreter + +strdisp endp + +;************************************************************************ +;* Local Support: Flush Output Buffer to Screen * +;* * +;* Input Parameters: ES - points to data segment * +;************************************************************************ + public flush +flush proc near + pushm ; save valuable registers +; Make DS register point to data segment + mov AX,ES + mov DS,AX + +; Test for negative bias + inc [BP].sd_bias ; increment and test "bias" value + jg fl_no_bs ; if zero or positive, no bias (jump) + jmp fl_bias ; if negative, don't display current line +; Position the cursor in the current column position +fl_no_bs: mov DL,byte ptr [BP].sd_cline ; load the current cursor + mov DH,byte ptr [BP].sd_ccol ; position + add DL,byte ptr [BP].sd_ullin ; adjust cursor positon by + add DH,byte ptr [BP].sd_ulcol ; coordinates of upper left corner + mov [BP].sd_cursv,DX ; save the cursor coordinates +IFNDEF PROMEM + xor BH,BH ; IBMism (page 0 for text-mode) + mov AH,02h ; load "put cursor" code + call CRT_DSR ; put cursor at current position +ENDIF +; Display the line + mov CX,[BP].sd_ncols ; load line length + sub CX,[BP].sd_ccol ; subtract starting column offset +; Replace the "last" character in line with an exclamation mark + cmp [BP].sd_last,0 ; last line to be output? + jnz fl_last ; if last line, leave character alone (jump) + mov SI,CX ; copy character count + mov AL,"!" ; load an exclamation mark + xchg AL,[BP]+sd_buff+[SI]-1 ; swap with final character in line + mov [BP].sd_char,AL ; save character to later viewing + + public fl_last +fl_last label near +IFDEF PROMEM + buffer_is_stack ;treat comm buffer as stack + mov [BP].sd_len,cx ;save character count + REALIO REAL_WRTBLOCK,sd_len,sd_cursv,continue + buffer_is_buffer ;treat comm buffer as buffer +ELSE +; Determine PC make + cmp PC_MAKE,TIPC ; on what flavor PC are we running? + jne fl_ibm ; if an IBM, jump +; Write line to TIPC's screen + mov AL,byte ptr [BP].sd_text ; load text attributes + mov AH,010h ; load "write block w/ attr" code + mov DX,DS ; load segment address + mov BX,BP + add BX,sd_buff ; load buffer offset in segment + int TI_CRT ; write the buffer + jmp fl_back + +; Write line to IBM's screen +fl_ibm: mov DI,BP + add DI,sd_buff ; load buffer offset + mov DX,[BP].sd_cursv ; reverse row/column coordinates + xchg DL,DH + mov [BP].sd_cursv,DX + push CX ; save the character counter + jmp short fl_imidl ; jump into middle of loop + +fl_iloop: push CX ; save the character counter + mov DX,[BP].sd_cursv ; load the previous cursor coordinates, + inc DL ; increment the column number + mov [BP].sd_cursv,DX ; and save new coordinates + xor BH,BH ; page number (0 for graphics mode) IBMism + mov AH,02h ; load "put cursor" code + push DI + int IBM_CRT + pop DI +fl_imidl: mov AH,09h ; Load "write char w/ attributes" code + mov AL,byte ptr [DI] ; load character from buffer + mov BL,byte ptr [BP].sd_text ; load attribute bits + xor BH,BH ; page # for alpha mode + mov CX,1 ; load repeat count = 1 +; test to see if we buy anything by using a repeat count + pop DX ; restore character count +fl_imore: cmp DX,1 ; more characters to display? + jle fl_ibotm ; if no more characters, jump + cmp AL,byte ptr [DI]+1 ; is next character the same as previous? + jne fl_ibotm ; if not same character, jump + inc CX ; increment the repeat count + inc DI ; increment the output buffer index + inc byte ptr [BP].sd_cursv ; increment the cursor position + dec DX ; decrement the character count + jmp fl_imore ; try for another +fl_ibotm: push DX ; save the adjusted character count +; output the character(s) + push DI ; save the output buffer index + int IBM_CRT ; write character with attributes + pop DI ; restore the output buffer index + pop CX ; restore character counter + inc DI ; increment buffer pointer + loop fl_iloop ; continue 'til all characters output +ENDIF + +; Restore last character in line to its rightful value +fl_back: mov SI,[BP].sd_ncols + sub SI,[BP].sd_ccol + mov AL,[BP].sd_char + mov [BP]+sd_buff+[SI]-1,AL + +; Shift buffer to remove the line just displayed + inc [BP].sd_cline ; increment the line number +fl_bias: mov SI,[BP].sd_ncols ; compute number of characters just output + sub SI,[BP].sd_ccol ; (unless bias < 0, in which case we just + dec SI ; branched here) + push SI ; save character count + mov CX,10 ; make up a character count for move + mov DI,BP ; load address of buffer start + add DI,sd_buff + add SI,BP ; load address of leftover characters + add si,sd_buff +rep movsb ; shift any characters left over + mov BX,[BP].sd_ccol ;;; new code for fix + ;;; save the current column for adjust + mov [BP].sd_ccol,0 ; set current column to zero + inc [BP].sd_linum ; increment formatting line number + +; Reset Active Registers to reflect shifted buffer + pop AX ; restore output character count + popm ; restore control registers + sub DI,AX ; adjust buffer index + sub CX,AX ; adjust current column + sub CX,BX ;;; new code for fix + ;;; adjust current column + mov BX,[BP].sd_ncols ; reload line length + pop DS ; restore DS register + ret ; return +flush endp + +;************************************************************************ +;* Local Support: Fetch and Validate Integer Argument * +;* * +;* Input Parameters: BX - address of register containing the integer * +;* argument * +;* * +;* Output Parameters: If CARRY off, normal return: * +;* AX - the 16 bit positive integer value * +;* If CARRY on, error: * +;* AX - the error condition; 0=operand not an * +;* integer; 1=integer operand was negative * +;* or larger than 16 bits. * +;************************************************************************ + public get_num +get_num proc near +; test for a fixnum argument + cmp byte ptr [BX].C_page,SPECFIX*2 ; fixnum? + jne big_p ; if not a fixnum, test for bignum (jump) + mov AX,[BX].C_disp ; load immediate value of fixnum + test AX,04000h ; negative? + jnz get_val ; if negative, error (jump) + ret ; if positive, return with value in AX + +; test for a bignum argument +big_p: mov SI,[BX].C_page ; load page number of argument + cmp byte ptr ptype+[SI],BIGTYPE*2 ; is argument a bignum? + jne get_type ; if not a bignum, invalid type (jump) + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; load paragraph address of bignum's page + mov SI,[BX].C_disp ; load displacement of bignum + cmp ES:[SI].big_sign,0 ; test sign of bignum + jne get_val ; if negative, error (jump) + cmp ES:[SI].big_len,BLK_OVHD+WORDINCR+1 ; test size of bignum + jne get_val ; if too large, error (jump) + mov AX,ES:[SI].big_data ; load 16 bit value of bignum + clc + ret ; return with value in AX +; ***error-- operand is not an integer*** +get_type: mov AX,0 ; indicate operand wrong type + jmp short get_err +; ***error-- integer operand is negative, or too large*** +get_val: mov AX,1 +get_err: stc + ret +get_num endp + +;************************************************************************ +;* Local Support: Return a 16 bit positive integer value * +;* * +;* Input Parameters: BX - address of destination register * +;* SI - 16 bit unsigned integer value to be returned * +;* * +;* Output Parameters: The Scheme representation of the 16 bit unsigned * +;* value is placed into the destination register. * +;************************************************************************ + public ret_num +ret_num proc near + cmp SI,03fffh ; can result be represented as a fixnum? + ja make_big ; if not, create a bignum +; return a fixnum result + mov byte ptr [BX].C_page,SPECFIX*2 ; set tag=fixnum + mov [BX].C_disp,SI ; store value + ret ; return +; return a bignum result +make_big: + push SI ; save value around call + push BX ; save destination reg also + + mov CX,WORDINCR+1 ; load size of bignum desired + mov AX,BIGTYPE ; load type = bignum + pushm ; push arguments to allocate block + call %allocbl ; allocate the bignum + add SP,WORDINCR*3 ; drop arguments off stack + + pop BX ; restore destination reg + mov SI,[BX].C_page ; get page number of new bignum + %LoadPage ES,SI ; and fetch its segment address + mov SI,[BX].C_disp ; load the bignum's displacement + mov ES:[SI].big_sign,0 ; set bignum's sign to '+' + pop AX ; restore value and + mov ES:[SI].big_data,AX ; store it into the bignum + ret ; return +ret_num endp + + +PROGX ends + +prog segment byte public 'PROG' + assume CS:PGROUP +;************************************************************************ +;* Long Linkage to SUBSTRING-FIND-NEXT-CHAR-IN-SET * +;************************************************************************ + public srch_nxt +srch_nxt proc near + call %srchnxt + ret +srch_nxt endp + +;************************************************************************ +;* Long Linkage to SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET * +;************************************************************************ + public srch_prv +srch_prv proc near + call %srchprv + ret +srch_prv endp + +;************************************************************************ +;* Long Linkage to STRING-LENGTH * +;************************************************************************ + public st_len +st_len proc near + call %st_len + ret +st_len endp + +;************************************************************************ +;* Long Linkage to MAKE-STRING * +;************************************************************************ +;;; public make_str +make_str proc near + call %makestr + ret +make_str endp + +;************************************************************************ +;* Long Linkage to REIFY_STACK * +;************************************************************************ + public reif_stk +reif_stk proc near + call %reifstk + ret +reif_stk endp + +;************************************************************************ +;* Long Linkage to REIFY_STACK! * +;************************************************************************ + public reif_stb +reif_stb proc near + call %reifstb + ret +reif_stb endp + +prog ends + end + \ No newline at end of file diff --git a/srelocat.asm b/srelocat.asm new file mode 100644 index 0000000..348c671 --- /dev/null +++ b/srelocat.asm @@ -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 ; 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 ; 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 + \ No newline at end of file diff --git a/sstack.asm b/sstack.asm new file mode 100644 index 0000000..358bc7e --- /dev/null +++ b/sstack.asm @@ -0,0 +1,1807 @@ +; =====> SSTACK.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* Interpreter -- Stack Operations * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 2 May 1984 * +;* Last Modification: 22 October 1985 * +;*************************************** +;* Modification History: +;* 06 Mar 86 - Recoded the C_push and C_pop routines to attemp to +;* (JCJ) improve their performance and memory utilization. +;* + include scheme.equ + include sinterp.mac + + include sinterp.arg + include stackf.equ ; define stack frame format + +XGROUP group PROGX +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public stk_in,stk_out +stk_in dd 0 ; number of bytes moved into the stack +stk_out dd 0 ; number of bytes moved out of the stack +m_%exec db "%EXECUTE",0 +m_stk_un db "[VM INTERNAL ERROR] Stack underflow",LF,0 +m_stk_ov db LF,"[VM ERROR encountered!] Recursion too deep: Stack " + db "overflow",LF,0 +clos_ptr dw 0 ; register number containing closure pointer + +m_APPLY dw APPLY_ARG_LIMIT_ERROR +m_AP1 db "APPLY",0 ; text for "apply" function name +m_AP_adr dw m_AP1 ; address of above text +m_one dw 1 ; a constant "one" (1) + + +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +stk_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 ; All of the above, with "mov SP,BP" first + extrn src_err:near ; "source operand error" message display + extrn sch_err:near ; Link to Scheme Debugger + extrn printf_c:near ; Error message print routine + + extrn %allocbl:far ; Far linkage to "alloc_block" + +;************************************************************************ +;* AL * +;* Push register onto stack PUSH reg * +;* * +;* Purpose: Interpreter support to cause the contents of one of the * +;* VM's general registers to be pushed onto the VM's * +;* runtime stack * +;************************************************************************ + public spush +spush: lods byte ptr ES:[SI] ; load number of register to push +spush1: mov DI,TOS ; load top of stack pointer + cmp DI,STKSIZE-PTRSIZE ; test for overflow + jge spush2 ; jump if overflow will occur + add DI,PTRSIZE ; decrement stack top pointer + mov TOS,DI ; update TOS pointer in memory + mov BX,AX ; copy register number + mov AL,byte ptr reg0_pag+[BX] ; load page number from register + mov S_stack+[DI].car_page,AL ; and move to the stack + mov AX,reg0_dis+[BX] ; same for displacement + mov word ptr S_stack+[DI].car,AX + jmp next +; process stack overflow-- copy contents to heap +spush2: pushm ; preserve "important" regs across call + call stk_ovfl ; handle overflow situation + popm ; restore "important" registers + jmp spush1 ; re-try push + + +;************************************************************************ +;* AL * +;* Pop register from stack POP reg * +;* * +;* Purpose: Interpreter support to cause the contents of one of the * +;* VM's general registers to be replaced by popping the * +;* value off the top of the VM's runtime stack * +;* * +;* Note: There's no need to check for stack underflow on a simple * +;* POP, because the stack is broken into segments only at stack * +;* frame boundaries. Underflow can occur only when stack space * +;* for a stack frame is released (i.e., during an EXIT). * +;************************************************************************ + public spop +spop: lods byte ptr ES:[SI] ; load number of register to pop + mov DI,TOS ; load top of stack pointer + mov BX,AX ; copy register number + mov AL,S_stack+[DI].car_page ; move page no. from stack + mov byte ptr reg0_pag+[BX],AL ; and update in register + mov AX,word ptr S_stack+[DI].car ; same for displacement + mov reg0_dis+[BX],AX + sub DI,PTRSIZE ; decrement TOS pointer + mov TOS,DI ; update TOS pointer in memory + jmp next + + +;************************************************************************ +;* AL * +;* Drop-- remove top elements from stack DROP n * +;* * +;* Purpose: Interpreter support to cause the top "n" elements of the * +;* VM's runtime stack to be discarded. "n" is determined * +;* from the operand of the DROP instruction * +;* * +;* Note: There's no need to check for stack underflow on a DROP * +;* because the stack is broken into segments only at stack * +;* frame boundaries. Underflow can occur only when stack space * +;* for a stack frame is released (i.e., during an EXIT). * +;************************************************************************ + public sdrop +sdrop: lods byte ptr ES:[SI] ; load number of elements to drop + mov DX,AX ; multiply by 3 (size of element) + shl AX,1 + add AX,DX + sub TOS,AX ; update TOS pointer in memory + jmp next ; return to interpreter + + +;************************************************************************ +;* AL AH * +;* Local from local stack frame LDLOCAL dest,entry * +;************************************************************************ + public ld_local +ld_local: lods word ptr ES:[SI] ; load dest reg, entry number operands + mov BL,AL ; copy destination register number + mov DI,BX ; into DI (clear high order byte) + mov BL,AH ; copy the entry number (clear high byte) + mov AX,BX ; BX <- entry * 3 + sal AX,1 + add BX,AX + add BX,FP ; BX <- FP + (entry * 3) + mov AL,S_stack+[BX].sf_dat_p ; move page number of entry to + mov byte ptr reg0_pag+[DI],AL ; destination register + mov AX,word ptr S_stack+[BX].sf_dat_d ; move displacement of + mov reg0_dis+[DI],AX ; entry to destination register + jmp next + +;************************************************************************ +;* AL AH * +;* Store into local stack frame STLOCAL src,entry * +;************************************************************************ + public st_local +st_local: lods word ptr ES:[SI] ; load dest reg, entry number operands + mov BL,AL ; copy destination register number + mov DI,BX ; into DI (clear high order byte) + mov BL,AH ; copy the entry number (clear high byte) + mov AX,BX ; BX <- entry * 3 + sal AX,1 + add BX,AX + add BX,FP ; BX <- FP + (entry * 3) +; cmp BX,TOS ; store out of range? +; jgt st_err ; if so, record error + mov AL,byte ptr reg0_pag+[DI] ; move page number of entry from + mov S_stack+[BX].sf_dat_p,AL ; destination register + mov AX,reg0_dis+[DI] ; move displacement of entry from + mov word ptr S_stack+[BX].sf_dat_d,AX ; destination register + jmp next + + +;************************************************************************ +;* AL AL AH * +;* Load from higher lexical level LDLEX dest,entry,lvl * +;************************************************************************ + public ld_lex +ld_lex: lods byte ptr ES:[SI] ; load destination register operand + push AX ; and save it + lods word ptr ES:[SI] ; load lexical level and entry number + save ; save current location pointer + mov BL,AH ; clear high order byte of the lexical + mov CX,BX ; level number delta and move to CX + mov BL,AL ; align, and save entry number + push BX + call delta_lv ; get pointer to parent's stack frame + pop AX ; get entry number + mov BX,AX ; BX <- entry number * 3 + shl AX,1 + add BX,AX + pop DI ; get destination register number + mov AL,ES:[SI].sf_dat_p+[BX] ; copy lexical entry from stack + mov byte ptr reg0_pag+[DI],AL ; frame to destination register + mov AX,ES:[SI].sf_dat_d+[BX] + mov reg0_dis+[DI],AX + jmp next_PC ; return to the interpreter + + +;************************************************************************ +;* AL AL AH * +;* Store into higher lexical level STLEX src,entry,lvl * +;************************************************************************ + public st_lex +st_lex: lods byte ptr ES:[SI] ; load source register operand + push AX ; and save it + lods word ptr ES:[SI] ; load lexical level and entry number + save ; save current location pointer + mov BL,AH ; clear high order byte of the lexical + mov CX,BX ; level number delta and move to CX + mov BL,AL ; align, and save entry number + push BX + call delta_lv ; get pointer to parent's stack frame + pop AX ; get entry number + mov BX,AX ; BX <- entry number * 3 + shl AX,1 + add BX,AX + pop DI ; get source register number + mov AL,byte ptr reg0_pag+[DI] ; copy contents of register into + mov ES:[SI].sf_dat_p+[BX],AL ; lexical entry of stack + mov AX,reg0_dis+[DI] + mov ES:[SI].sf_dat_d+[BX],AX + jmp next_PC ; return to the interpreter + + +;************************************************************************ +;* AX AL AH * +;* Call local routine CALL lbl,delta-lvl,delta-heap* +;************************************************************************ + public call_lcl +call_lcl: mov AX,offset PGROUP:next_PC ; For a "CALL", make a tail + push AX ; recursive call to following routine + +cl_l_sub: lods word ptr ES:[SI] ; load branch displacement + mov DX,AX ; and save in register DX + + lods word ptr ES:[SI] ; load delta-level,delta-heap numbers + inc AL ; increment releative lexical level + mov BL,AL ; isolate delta-lvl and save it + push BX + mov BL,AH ; isolate delta-heap and save it, too + push BX + + add DX,SI ; compute branch destination address + mov [BP].save_SI,DX ; store updated location counter + + call new_SF ; allocate new stack frame on top of stack + mov SI,BX ; save pointer to new stack frame + + pop CX ; restore the delta-heap argument + call delta_hp ; determine new heap env pointer + mov S_stack+[SI].sf_hpage,BL ; store new heap env pointer into + mov word ptr S_stack+[SI].sf_hdisp,DI ; new stack frame + + pop CX ; restore the delta-lvl argument + push SI ; save new stack frame pointer + call delta_lv ; get static link + pop SI ; retrieve new stack frame pointer + mov word ptr S_stack+[SI].sf_sdisp,BX ; update static link + + mov FP,SI ; update current frame pointer + ret ; return to interpreter, or call/cc support + + +;************************************************************************ +;* AX AL AH * +;* Call local routine tail recursively CALL-TR lbl,delta-lvl,delta-heap* +;************************************************************************ + public call_ltr +call_ltr: mov AX,offset PGROUP:next_PC ; For a "CALL-TR", make a tail + push AX ; recursive call to following routine + +cl_lt_sb: lods word ptr ES:[SI] ; load branch displacement + mov DX,AX ; and save in register DX + + lods word ptr ES:[SI] ; load delta-level,delta-heap numbers + inc AL ; increment releative lexical level + mov BL,AL ; isolate delta-lvl and save it + push BX + mov BL,AH ; isolate delta-heap and save it, too + mov CX,BX + + add DX,SI ; compute branch destination address + mov [BP].save_SI,DX ; store updated location counter + + mov AX,FP ; load pointer to current stack frame + mov SI,AX + add AX,SF_OVHD-PTRSIZE + mov TOS,AX ; drop any local var's off top of stack + + call delta_hp ; determine new heap env pointer + mov S_stack+[SI].sf_hpage,BL ; store new heap env pointer into + mov word ptr S_stack+[SI].sf_hdisp,DI ; new stack frame + + mov S_stack+[SI].sf_cl_pg,NIL_PAGE*2 ; nil out closure pointer + mov word ptr S_stack+[SI].sf_cl_ds,NIL_DISP ; entry in stack frame + + pop CX ; restore the delta-lvl argument + push SI ; save pointer to stack frame + call delta_lv ; get static link + pop SI ; retrieve pointer to stack frame + mov word ptr S_stack+[SI].sf_sdisp,BX ; update static link + + ret ; return to interpreter, or call/cc support + + +;************************************************************************ +;* AL AH * +;* Call closed procedure CALL-CLOSURE ftn,#args * +;* * +;* Purpose: Scheme interpreter support for procedure calls to fully * +;* closed functions * +;************************************************************************ + public call_clo +call_clo: mov AX, offset PGROUP:next_PC ; For a "CALL-CLOSURE" make a tail + push AX ; recursive call to the following routine + + lods word ptr ES:[SI] ; fetch ftn reg, number of args passed +cl_c_sub: mov BL,AH ; isolate the number of arguments + push BX ; passed and save it + mov BL,AL ; copy the procedure object register + mov DI,reg0_pag+[BX] ; load page number of closure pointer + cmp byte ptr ptype+[DI],CLOSTYPE*2 + je call_cok ; if a regular closure, jump + jmp call_cnt ; otherwise, a continuation (probably) +; Procedure call to a closed procedure +call_cok: push BX ; save number of procedure pointer reg + call new_SF ; allocate a new stack frame + pop SI ; restore reg number with closure pointer + +; Load the pointer to the closure object from the operand register +call_xxx: mov clos_ptr,SI ; save number of register containing closure + mov DI,reg0_pag+[SI] + mov SI,reg0_dis+[SI] + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + +; Put the closure pointer into the newly allocated stack frame + mov AX,DI ; copy closure's page number to AL + mov S_stack+[BX].sf_cl_pg,AL ; then copy into stack frame + mov word ptr S_stack+[BX].sf_cl_ds,SI ; put disp into frame, too + +; Copy the pointer to the procedure's heap environment from the closure +; object to the new stack frame + mov AL,ES:[SI].clo_hpag + mov S_stack+[BX].sf_hpage,AL + mov AX,ES:[SI].clo_hdis + mov word ptr S_stack+[BX].sf_hdisp,AX + +; Dummy up the Static Link in the new Stack Frame + mov word ptr S_stack+[BX].sf_sdisp,0 + +; Update the current frame pointer to point to new stack frame + mov FP,BX + +; Obtain the entry point address from the closure object + mov AX,ES:[SI].clo_cb_d ; define the code base register + mov CB_dis,AX + add AX,ES:[SI].clo_edis ; add the entry point offset + mov [BP].save_SI,AX ; and set up for load into location pointer + xor AX,AX + mov AL,ES:[SI].clo_cb_p + mov byte ptr CB_pag,AL + mov DI,AX ; obtain the code block page's paragraph + LoadCode AX,DI +;;; mov AX,pagetabl+[DI] ; address and update in memory + mov [BP].save_ES,AX + +; Determine if the closed function is a mulambda + pop CX ; get number of args passed + mov AX,ES:[SI].clo_narg ; load number of args expected + shl AX,1 ; sign extend the number of + sar AX,1 ; arguments expected + jl call_mu ; if #args negative, then a mulambda (jump) + cmp AX,CX ; verify args passed/expected agree + je call_crt ; if so, jump + +; ***Error-- wrong number of arguments passed to a closed function*** +cl_wrng: mov AX,clos_ptr ; load number of register w/ closure pointer + add AX,offset reg0 + pushm ; push count of args passed, closure ptr +cl_wrng1: C_call wrong_ar,,Load_ES ; print error message and fixup VM regs + restore ; load address of next instruction + jmp sch_err ; link to Scheme error routine + +call_crt: ret ; return to interpreter, or call/cc support + +; Funtion being called is a mulambda-- cons arguments into a list +call_mu: mov SI,CX ; compute the address of the last + sal SI,1 ; register which contains an argument + sal SI,1 ; to be passed to the mulambda + add SI,offset reg0 + + lea DI,[SI]+size C_ptr ; load address of register page last arg + mov [DI].C_page,NIL_PAGE*2 ; put a value of "nil" into the + mov [DI].C_disp,NIL_DISP ; register for end of list + + mov ES,[BP].C_ES ; set up ES for calls to "cons" + + mov DX,CX ; save number of arguments passed + add CX,AX ; adjust number of arguments passed + inc CX ; by number required + je mu_ret ; if #passed = #required, jump + jl mu_wrng ; if too few passed, jump + +mu_loop: push DI ; push addr of "cdr" register + push SI ; push addr of "car" register + push SI ; push addr of dest reg (result of cons) + C_call cons, ; cons together ptrs in regs "n" and "n+1" + add SP,WORDINCR ; drop one copy of SI from the 8088's stack + pop SI ; restore value of SI + pop DI ; restore value of DI + restore ; restore registers destroyed by the call + mov [DI].C_page,UN_PAGE*2 ; set register "n+1" to "***unbound***" + mov [DI].C_disp,UN_DISP + mov DI,SI ; update pointers for next iteration + sub SI,size C_ptr + loop mu_loop ; repeat for all arguments passed + +mu_ret: ret ; return to interpreter, or call/cc support + +; Too few required arguments-- inform user +mu_wrng: mov CX,DX ; restore count of args passed + jmp cl_wrng ; print "wrong number of args" message + +; Function call is invoking a continuation-- unless we've got an error +call_cnt: cmp ptype+[DI],CONTTYPE*2 + je cl_cn_ok +; ***Error-- thing being called isn't a procedure object-- note*** +; Note: at this point, the number of arguments passed has been pushed +; onto the runtime stack + add BX,offset reg0 ; compute address of "functional" register + push BX ; and push as argument + C_call not_proc,,Load_ES ; call: not_procedural_object(obj, #args); + restore ; load address of next instruction + jmp sch_err ; link to Scheme debugger + +; Oh, wow! we've got a continuation to envoke (or is that invoke?) +; +; Note: the contents of the stack is restored by making the VM's +; previous stack segment register point to the continuation +; object and signaling an underflow condition. This restores +; the stack, BASE, TOS, PREV_pag, and PREV_dis. The +; remainder of this code fetches the values of CB_pag, +; CB_dis, FP, and LP from the continuation object. +; +cl_cn_ok: push BX ; save pointer to continuation object + mov AL,byte ptr reg0_pag+[BX] ; copy continuation pointer into + mov byte ptr PREV_pag,AL ; PREV_reg + mov AX,reg0_dis+[BX] + mov PREV_dis,AX + + call stk_unfl ; signal a stack underflow condition + + pop DI ; retrieve ptr to reg with continuation ptr. + mov SI,reg0_pag+[DI] ; make ES:[SI] point to the continuation + LoadPage ES,SI +;;; mov ES,pagetabl+[SI] ; object + mov SI,reg0_dis+[DI] + + xor BX,BX + mov BL,ES:[SI].con_cb_p + mov byte ptr CB_pag,BL + LoadCode AX,BX +;;; mov AX,pagetabl+[BX] ; obtain the code block's paragraph address + mov [BP].save_ES,AX + mov AX,ES:[SI].con_cb_d ; restore code base pointer + mov CB_dis,AX + + add AX,ES:[SI].con_ret ; restore return address displacement + mov [BP].save_SI,AX + + mov AX,ES:[SI].con_ddis ; restore FP from dynamic link + sub AX,BASE ; adjust for current stack buffer base + mov FP,AX + + mov AL,ES:[SI].con_fl_p ; restore fluid environment (FNV_reg) + mov byte ptr FNV_pag,AL + mov AX,ES:[SI].con_fl_d + mov FNV_dis,AX + + mov AL,ES:[SI].con_gl_p ; restore global environment (GNV_reg) + mov byte ptr GNV_pag,AL + mov AX,ES:[SI].con_gl_d + mov GNV_dis,AX + + pop AX ; get number of arguments passed + cmp AX,1 ; one argument passed? + jne cl_cn_er ; if so, good! we can continue (fall thru) +cl_cn_rt: ret ; return to interpreter, or call/cc support + +; ***error-- wrong number of arguments passed to a continuation*** +cl_cn_er: add DI,offset reg0 ; load address of continuation's register + pushm ; push continuation ptr, args passed + jmp cl_wrng1 ; process error condition + + +;************************************************************************ +;* AL AH * +;* Call closed proc tail recursively CALL-CLOSURE-TR ftn,#args * +;* * +;* Purpose: Scheme interpreter support for procedure calls to fully * +;* closed functions tail recursively * +;************************************************************************ + public call_ctr +call_ctr: mov AX,offset PGROUP:next_PC ; For "CALL-CLOSURE-TR" make tail + push AX ; recursive call to the following routine + + lods word ptr ES:[SI] ; fetch ftn reg, number of args passed +cl_ct_sb: mov BL,AH ; isolate the number of arguments + push BX ; passed and save it + mov BL,AL ; copy the procedure object register + mov DI,reg0_pag+[BX] ; load page number of procedure object + cmp ptype+[DI],CLOSTYPE*2 ; is it a closure data object? + je call_cko ; if a regular closure, jump + jmp call_cnt ; otherwise, a continuation (probably) + +; Procedure call (tail recursive) to a closed procedure +call_cko: mov SI,BX ; copy reg number with closure pointer + mov AX,FP ; use current stack frame for this call + mov BX,AX ; drop any local vars from top of stack + add AX,SF_OVHD-PTRSIZE + mov TOS,AX ; update TOS pointer + + jmp call_xxx ; continue processing as non-tr call + + +;************************************************************************ +;* Call/cc local CALL/CC lbl,delta-lvl,delta-heap* +;* * +;* Purpose: Interpreter support for a local call with current * +;* continuation * +;* * +;* Description: * +;* 1. The local CALL support is called to create a new * +;* stack frame and to establish the VM's registers * +;* for the branch to the called routine. * +;* 2. A stack overflow condition is signaled to cause * +;* the contents of the stack to be saved on the heap * +;* in a continuation object format. * +;* 3. Fields in the continuation object are updated to * +;* cause control to return to the correct place when * +;* the continuation is invoked. * +;* 4. Control returns to the Scheme interpreter. * +;************************************************************************ + public call_cc +call_cc: call cl_l_sub ; call CALL's alternate entry point + +call_cc1: call stk_ovfl ; signal stack overflow + + mov BX,PREV_pag ; move pointer to continuation into R1 + mov DI,PREV_dis + mov reg1_pag,BX + mov reg1_dis,DI + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov SI,FP ; create a pointer to the current stack + add SI,offset S_stack ; frame (the new one) + + mov AL,[SI].sf_cb_pag ; copy the value of the VM's code base + mov ES:[DI].con_cb_p,AL ; into the continuation object + mov AX,[SI].sf_cb_dis + mov ES:[DI].con_cb_d,AX + + mov AX,[SI].sf_ret ; copy the return address displacement + mov ES:[DI].con_ret,AX ; into the continuation object + + mov AX,[SI].sf_ddisp ; copy the dynamic link into the + mov ES:[DI].con_ddis,AX ; continuation object + + jmp next_PC ; return to the interpreter + +;************************************************************************ +;* Call/cc tail recursively CALL/CC-TR lbl,delta-lvl,delta-heap* +;* * +;* Purpose: Interpreter support for a tail recursive local call with * +;* current continuation * +;* * +;* Description: * +;* 1. The local CALL-TR support is called to update the * +;* current stack frame and to establish the VM's * +;* registers for the branch to the called routine. * +;* 2. Control transfers to the CALL/CC support to create * +;* the continuation object. * +;************************************************************************ + public cl_cctr +cl_cctr: mov AX,offset PGROUP:call_cc1 ; define return address + push AX + jmp cl_lt_sb ; tail recursive call to CALL-TR's + ; secondary entry point + + +;************************************************************************ +;* AL * +;* Call/cc with of procedure object CALL/CC-CLOSURE ftn * +;* * +;* Purpose: Interpreter support for a call with current continuation * +;* of a fully closed function * +;* * +;************************************************************************ + public clcc_c +clcc_c: lods byte ptr ES:[SI] ; load register number pointing to closure + mov AH,1 ; indicate one argument being passed + push AX ; and save "operands" + + mov AX,FP ; save current stack frame pointer + add AX,BASE + push AX + + mov AX,TOS ; update FP to where it will be after + add AX,PTRSIZE ; the new stack frame is built + mov FP,AX + + call stk_ovfl ; signal stack overflow to create + ; continuation data object + + mov BX,PREV_pag ; load pointer to continuation + mov DI,PREV_dis + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov AL,byte ptr CB_pag ; copy the value of the VM's code base + mov ES:[DI].con_cb_p,AL ; into the continuation object + mov AX,CB_dis + mov ES:[DI].con_cb_d,AX + + sub SI,AX + mov ES:[DI].con_ret,SI ; place return addr in continuation object + add SI,AX + + pop AX ; define dynamic link in continuation + mov ES:[DI].con_ddis,AX ; object + sub AX,BASE ; put FP back to where it should be + mov FP,AX ; Note: FP's now negative (TOS is 0) + +; Perform the Call-Closure-Tail-Recursive + mov AL,byte ptr PREV_pag ; save the pointer to the new + mov byte ptr tm2_page,AL ; continuation + mov AX,PREV_dis + mov tm2_disp,AX + pop AX ; recover "operands" to call-closure + call cl_c_sub ; call CALL-CLOSURE + mov AL,byte ptr tm2_page ; move continuation pointer into + mov byte ptr reg1_pag,AL ; VM register R1 + mov AX,tm2_disp + mov reg1_dis,AX + jmp next_PC ; return to interpreter + + + +;************************************************************************ +;* AL * +;* Call/cc with of procedure object CALL/CC-CLOSURE-TR ftn * +;* * +;* Purpose: Interpreter support for a tail recursive call with current * +;* continuation of a fully closed function * +;* * +;* Description: * +;* 1. The CALL/CC-CLOSURE argument is fetched. * +;* 2. The current continuation is formed using the * +;* caller's return address (since there's no way to * +;* return here from the tail recursive call). * +;* The pointer to the continuation is placed into * +;* VM register 1. * +;* 3. The CALL-CLOSURE-TR code is called to complete the * +;* call sequence. * +;************************************************************************ + public clcc_ctr +clcc_ctr: lods byte ptr ES:[SI] ; load register number pointing to closure + mov AH,1 ; indicate one argument being passed + push AX ; and save "operands" + + call stk_ovfl ; signal stack overflow to create + ; continuation data object + + mov BX,PREV_pag ; load pointer to continuation + mov DI,PREV_dis + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov SI,FP ; create a pointer to the current stack + add SI,offset S_stack ; frame (the new one) + + mov AL,[SI].sf_cb_pag ; copy the value of the VM's code base + mov ES:[DI].con_cb_p,AL ; into the continuation object + mov AX,[SI].sf_cb_dis + mov ES:[DI].con_cb_d,AX + + mov AX,[SI].sf_ret ; copy the return address displacement + mov ES:[DI].con_ret,AX ; into the continuation object + + mov AX,[SI].sf_ddisp ; copy the dynamic link into the + mov ES:[DI].con_ddis,AX ; continuation object + +; Perform the Call-Closure-Tail-Recursive + mov AL,byte ptr PREV_pag ; save the pointer to the new + mov byte ptr tm2_page,AL ; continuation + mov AX,PREV_dis + mov tm2_disp,AX + pop AX ; recover "operands" to call-closure-tr + call cl_ct_sb ; call CALL-CLOSURE-TR + mov AL,byte ptr tm2_page ; move continuation pointer into + mov byte ptr reg1_pag,AL ; VM register R1 + mov AX,tm2_disp + mov reg1_dis,AX + jmp next_PC ; return to interpreter + + +;************************************************************************ +;* AL AH * +;* Apply closure APPLY-CLOSURE ftn,args * +;* * +;* Purpose: Interpreter support for the "apply" primitive. The * +;* argument list (in register "args") are to be passed * +;* to the closure pointed to by the "ftn" register. * +;* * +;* Note: The argument registers may be anything that the compiler * +;* decides on, so the "ftn" pointer could be destroyed * +;* in the process of loading the arguments of the argument * +;* list ("args") into the VM general registers R1-Rn. * +;* So that the ftn pointer is not lost during this process,* +;* this pointer is pushed onto the 8088 stack before the * +;* call to process the arguments, and it is restored into * +;* the last available register to complete the call * +;* sequence. * +;* * +;* Garbage collection will not occur during the argument loading * +;* process (arguments are copied, but no cons-ing occurs), * +;* so it's safe to save the "ftn" pointer on the 8088 * +;* stack temporarily. * +;************************************************************************ +last_pag equ reg0_pag + (NUM_REGS - 1) * size C_ptr +last_dis equ reg0_dis + (NUM_REGS - 1) * size C_ptr + public apply +apply: lods word ptr ES:[SI] ; load apply's arguments + mov BL,AL ; copy closure pointer register number + push reg0_pag+[BX] ; save value of register containing + push reg0_dis+[BX] ; the closure pointer + save ; save registers across call + call aply_arg ; expand arguments into R1-Rn + restore ; restore saved registers + pop last_dis ; put "ftn" pointer into last VM register + pop last_pag + mov AH,CL ; copy the argument count to AH, AL<="Rlast" + mov AL,(NUM_REGS - 1) * size C_ptr + call cl_c_sub ; process the call + jmp next_PC ; return to the interpreter + + +;************************************************************************ +;* AL AH * +;* Apply closure, tail recursively APPLY-CLOSURE-TR ftn,args * +;* * +;* Purpose: Interpreter support for the "apply" primitive. The * +;* argument list (in register "args") are to be passed * +;* to the closure pointed to by the "ftn" register. * +;* * +;* Note: See notes in "APPLY-CLOSURE" support, above. * +;************************************************************************ + public apply_tr +apply_tr: lods word ptr ES:[SI] ; load apply-tr's arguments + mov BL,AL ; copy closure pointer register number + push reg0_pag+[BX] ; save value of register containing + push reg0_dis+[BX] ; the closure pointer + save ; save registers across call + call aply_arg ; expand arguments into R1-Rn + restore ; restore saved registers + pop last_dis ; put "ftn" pointer into last VM register + pop last_pag + mov AH,CL ; copy the argument count to AH, AL<="Rlast" + mov AL,(NUM_REGS - 1) * size C_ptr + call cl_ct_sb ; process the call, tail recursively + jmp next_PC ; return to the interpreter + +;************************************************************************ +;* Execute code block EXECUTE CODE * +;* * +;* Purpose: Interpreter support for the "execute" primitive operation. * +;* * +;* Description: The execute primitive causes a code block to be * +;* executed in a new environment. This is accomplished * +;* by executing a procedure call to the code block with * +;* no static environment information available. The * +;* new stack frame has a nil heap environment pointer, and * +;* the static link is set to point to itself to prevent * +;* access to any higher lexical levels. When the code * +;* block exits, control will return to the place where the * +;* execute instruction was executed. * +;************************************************************************ + public execute +execute: lods byte ptr ES:[SI] ; fetch register number with code pointer + mov BX,AX +execute1 label far + mov DI,reg0_pag+[BX] + cmp byte ptr ptype+[DI],CODETYPE*2 ; pointer to code block? + jne load_ex1 ; if not, we've got to load before execute + push BX ; save the code pointer's register number + call new_SF ; create a new stack frame for the "call" + mov word ptr S_stack+[BX].sf_sdisp,0 ; make "nil" static link + mov AL,byte ptr GNV_pag ; default environment to global env + mov S_stack+[BX].sf_hpage,AL + mov AX,GNV_dis + mov word ptr S_stack+[BX].sf_hdisp,AX + mov FP,BX + pop BX ; retrieve the code pointer's reg number + mov SI,reg0_dis+[BX] ; define the code base register + mov CB_dis,SI + mov BL,byte ptr reg0_pag+[BX] + mov byte ptr CB_pag,BL + LoadCode ES,BX +;;; mov ES,pagetabl+[BX] ; load the code base page's para address + save ; and save it off + add SI,ES:[SI].cod_entr ; adjust location ptr for entry offset + jmp next ; return to the interpreter + +load_ex1: jmp far ptr load_ex ; long jump to loader +; +; Object to be executed is not a code block, so we've got to create +; one for a compiled program before executing it. The format of an +; object program is: +; +; (tag #-constants #-codebytes (constant ...) (codebyte ...)) +; +; ***Error-- Invalid Object Module Format*** +bad_obj2 label far + mov AX,offset m_%exec ; load addr of "%EXECUTE" + restore ; load number of register containing + add BX,offset reg0 ; the "code" pointer and compute its addr + mov CX,1 ; load argument count = 1 + pushm ; push arguments to set_src_err + C_call set_src_ ; call: set_src_err("%EXECUTE", 1, code) + restore ; load next instruction's location + jmp sch_err ; link to Scheme debugger + +;************************************************************************ +;* Exit from current procedure EXIT * +;* * +;* Description: The internal registers of the VM are reset from * +;* information stored in the current frame pointer to * +;* restore the environment at the point where the current * +;* procedure was called (i.e., control returns to the * +;* calling routine). * +;************************************************************************ + public s_exit +s_exit: mov AX,FP ; load the current frame pointer + mov BX,AX + add BX,offset S_stack ; compute address of current stack frame + + sub AX,PTRSIZE ; reset the current TOS to previous + mov TOS,AX ; value [FP - sizeof(pointer)] + + xor AX,AX ; clear AX + mov AL,[BX].sf_cb_pag ; load CB's page number + mov byte ptr CB_pag,AL + mov DI,AX ; save code block's page number + LoadCode ES,DI +;;; mov ES,pagetabl+[DI] ; set paragraph address of page containing + save ; calling routine's code block + mov AX,[BX].sf_cb_dis ; update the current code base (CB) + mov CB_dis,AX + + add AX,[BX].sf_ret ; load return address' location pointer + mov SI,AX ; and add in starting offset of code block + + mov AX,[BX].sf_ddisp ; compute pointer to caller's stack frame + cmp AX,BASE ; is new FP outside stack buffer? + jae s_exit_1 ; if in bounds, jump + pushm ; save new FP, new location pointer + call stk_unfl ; process stack underflow + popm ; restore saved new FP, new location pointer +s_exit_1: sub AX,BASE ; FP <- dynamic link - Base + mov FP,AX + jmp next ; return to interpreter + +stk_int endp + +;************************************************************************ +;* AL AL AH * +;* Create Closure CR-CLOSE dest,label,nargs * +;* * +;* Purpose: Scheme interpreter support for the creation of closure * +;* objects. * +;************************************************************************ + public cr_close +cr_close: lods byte ptr ES:[SI] ; load destination register number + mov DI,AX ; and save it for now + lods word ptr ES:[SI] ; load address of entry label + mov CX,AX ; and save it, too + lods byte ptr ES:[SI] ; load number of arguments and + cbw ; convert it to a fullword integer + shl AX,1 ; clear high order bit of immediate value + shr AX,1 + add CX,SI ; add in current location pointer + sub CX,CB_dis ; and adjust for code block offset + save ; save nargs, entry point, location pointer + mov DX,CLOSTYPE ; load tag=closure + mov AX,CLO_OVHD-PTRSIZE ; load size of closure object + pushm ; push arguments + C_call alloc_bl,,Load_ES ; call: alloc_block(®, type, size) + mov SP,BP ; drop arguments off TIPC's stack + + mov BX,tmp_page ; load pointer to closure object + mov DI,tmp_disp + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + + mov SI,[BP].save_DI ; copy contents of destination register + xchg BL,byte ptr reg0_pag+[SI] ; into the information operand of + mov ES:[DI].clo_ipag,BL ; the newly allocated closure object. + mov AX,DI ; Make the destination register point + xchg AX,reg0_dis+[SI] ; to the closure object. + mov ES:[DI].clo_idis,AX + + mov AL,SPECFIX*2 ; set tags for constant fields + mov ES:[DI].clo_etag,AL ; entry point tag=fixnum + mov ES:[DI].clo_atag,AL ; nargs tag=fixnum + + mov AL,byte ptr CB_pag ; copy in pointer to current code base + mov ES:[DI].clo_cb_p,AL + mov AX,CB_dis + mov ES:[DI].clo_cb_d,AX + + restore ; define entry point offset + mov ES:[DI].clo_edis,CX + + restore ; define number of arguments + mov ES:[DI].clo_narg,AX + + mov SI,FP ; load pointer to current stack frame + mov AL,S_stack+[SI].sf_hpage ; define heap environment + mov ES:[DI].clo_hpag,AL + mov AX,word ptr S_stack+[SI].sf_hdisp + mov ES:[DI].clo_hdis,AX + + jmp next_PC ; return to interpreter + + +;************************************************************************ +;* Local support - stack overflow handler * +;* * +;* Purpose: To move part of Scheme's runtime stack to the heap when * +;* stack overflow occurs. * +;* * +;* Description: The contents of the stack which precede the current * +;* stack frame are moved to the heap (in a continuation * +;* object) and the current stack frame is moved to the * +;* top of the stack buffer. * +;* * +;* Input Parameters: * +;* TIPC register SI - the value to be placed in the * +;* "return address displacement" field of the * +;* continuation (needed only for call/cc) * +;* FNV_reg - the current fluid environment (saved by * +;* call/cc) * +;* GNV_reg - the current global environment (saved by * +;* call/cc) +;* FP - the current stack frame pointer * +;* BASE - the stack buffer base value * +;* TOS - the current top-of-stack pointer * +;* CB - the VM register which points to the current * +;* code block * +;* PREV_pag,PREV_dis - the VM's previous stack segment * +;* register * +;* * +;* Output Parameters: * +;* PREV_pag,PREV_dis - a pointer to the continuation * +;* object which was created * +;* BASE - updated to the new base value (stack offset) * +;* due to movement of some of the stack contents * +;* to the heap * +;* * +;* Variables Modified: (but logically unchanged) * +;* FP - the current stack frame pointer * +;* TOS - the current top of stack pointer * +;* * +;* Example: Stack Overflow Condition * +;* * +;* Before * +;* * +;* +--------+-----------------+ * +;* | prev stk seg -> = nil | * +;* +--------+-----------------+ * +;* Stack Buffer (BASE = 0) * +;* +--------+-----------------+ * +;* | Contents | * +;* : of : * +;* : Stack : * +;* | (m bytes) | * +;* |--------+-----------------| * +;* | Current |<-FP * +;* : Stack : * +;* | Frame |<-TOS * +;* +--------+-----------------+ * +;* * +;* AFTER * +;* * +;* "Continuation" in Heap * +;* +--------+-----------------+ +--------+-----------------+ * +;* | prev stk seg -> |------->| cont | length (m+24) | * +;* +--------+-----------------+ |--------+-----------------| * +;* Stack Buffer (BASE = m) | segment's stack base = 0 | * +;* +--------+-----------------+ |--------+-----------------| * +;* | Current |<-FP | code base -> = n/a | * +;* : Stack : |--------+-----------------| * +;* | Frame |<-TOS | return addr disp = n/a | * +;* |--------+-----------------| |--------+-----------------| * +;* | unused stack | | caller dynamic link = n/a| * +;* : : |--------+-----------------| * +;* : : | fluid env -> = FNV_reg | * +;* | | |--------------------------| * +;* +--------+-----------------+ | prev stk seg -> = nil | * +;* |--------+-----------------| * +;* | global env -> = GNV_reg | * +;* |--------+-----------------| * +;* | Contents | * +;* : of : * +;* : Stack : * +;* | (m bytes) | * +;* +--------+-----------------+ * +;* * +;* Notes: This routine handles both routine stack overflow, and stack * +;* overflow which is signaled during the creation of a * +;* full continuation because of a call/cc. All of the * +;* fields of the continuation object are filled in by this * +;* routine, but they are meaningless and will never be * +;* used in the case of simple stack overflow. * +;************************************************************************ +stk_arg struc +stk_temp dd ? ; temporary register +stk_SI dw ? ; caller's SI (for continuation, rtn addr) +stk_BP dw ? ; caller's BP + dw ? ; return address +stk_arg ends + +stk_ovfl proc near + push BP ; save caller's BP + sub SP,offset stk_BP + mov BP,SP + mov [BP].stk_SI,SI ; save return address disp, if meaningful + +; test to see how to create continuation object + mov CX,FP ; load current frame pointer, + cmp CX,0 ; length of stack contents zero? + jg stk_nz ; if not, create new continuation (jump) + +; copy previous continuation + mov AX,PREV_pag ; tmp_reg <- PREV_reg + mov tmp_page,AX + mov AX,PREV_dis + mov tmp_disp,AX + mov AX,offset PREV_reg ; load address of PREV_reg, tmp_reg + pushm ; push as arguments + C_call copy_blk ; call: copy_blk(&PREV_reg, &tmp_reg) + mov SP,BP ; drop arguments from stack + jmp stk_rtn ; return copy of previous continuation + +; print warning concerning impending stack overflow +s_toobig: pushm ; save active registers + lea BX,m_stk_ov ; load error message text address + push BX ; and push as argument to printf + C_call printf,,Load_ES ; call: printf("***error... "); + pop BX ; drop argument from TIPC's stack + C_call force_de ; call: force_debug(); + popm ; restore active registers + jmp stk_go ; continue executing where we left off + +; allocate a continuation object on the heap +stk_nz: add CX,offset con_data-PTRSIZE ; and compute continuation's size + mov DX,CONTTYPE ; load tag=CONTTYPE + lea BX,[BP].stk_temp ; load address of temporary result reg + pushm ; push arguments, and call + mov BX,DS ; set up ES segment register for C_call + mov ES,BX + C_call alloc_bl ; "alloc_block(®,CONTTYPE,len)" + mov SP,BP ; remove arguments from 8088's stack + +; load pointer to the continuation object just allocated + mov CX,FP ; reload length of continuations stack data + mov BX,[BP].stk_temp.C_page ; load returned pointer to + mov DI,[BP].stk_temp.C_disp ; continuation object + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; ES->continuation object's page + +; define continuation object fields + mov AL,SPECFIX*2 + mov ES:[DI].con_btag,AL ; stack base tag=fixnum + mov ES:[DI].con_rtag,AL ; return address tag=fixnum + mov ES:[DI].con_dtag,AL ; dynamic link tag=fixnum + + mov AL,byte ptr CB_pag ; define code base pointer + mov ES:[DI].con_cb_p,AL + mov AX,CB_dis + mov ES:[DI].con_cb_d,AX + + neg AX ; subtract CB_dis from SI + add AX,[BP].stk_SI ; use contents of SI for return addr disp + mov ES:[DI].con_ret,AX + + mov AX,FP ; define dynamic link + mov ES:[DI].con_ddis,AX + + mov AX,BASE ; set continuation's stack base + mov ES:[DI].con_base,AX + add AX,CX ; compute new stack buffer base + mov BASE,AX ; [BASE <- BASE + FP] + +; Test for impending stack overflow + cmp AX,-STKSIZE ; over stack buffer threshold? + jae s_toobig ; if so, print warning (jump) + +stk_go: mov AL,byte ptr FNV_pag ; set fluild environment pointer + mov ES:[DI].con_fl_p,AL + mov AX,FNV_dis + mov ES:[DI].con_fl_d,AX + + mov AL,byte ptr GNV_pag ; set global environment pointer + mov ES:[DI].con_gl_p,AL + mov AX,GNV_dis + mov ES:[DI].con_gl_d,AX + + mov AX,PREV_pag ; set previous stack segment pointer + mov ES:[DI].con_spag,AL + mov AX,PREV_dis + mov ES:[DI].con_sdis,AX + + mov PREV_pag,BX ; make previous stack segment register + mov PREV_dis,DI ; point to the new continuation object + +; update the counter of bytes transfered to the heap + add word ptr stk_out,CX ; record number of bytes transfered + adc word ptr stk_out+2,0 ; fix up high order part of sum + +; move stack data to continuation object in the heap + lea SI,S_stack ; load stack address + add DI,offset con_data ; adjust for continuation header info + mov DX,CX ; copy length (in bytes) and + and DX,1 ; isolate lsb for fixup + shr CX,1 ; convert bytes to words + cld ; clear direction flag (forward move) +rep movsw ; move stack contents to heap (cont obj) + mov CX,DX ; copy fixup length (0 or 1 bytes) +rep movsb ; copy remaining byte, if needed + +; move data in current stack frame to top of stack buffer + lea SI,S_stack ; load address of top of stack buffer + mov DI,SI ; DI <- top of stack buffer (0) + add SI,FP ; SI <- current stack frame + mov CX,DS + mov ES,CX ; ES->data segment + mov CX,TOS ; load current top of stack, + sub CX,FP ; subtract bytes moved to heap, + mov TOS,CX ; and define new TOS + add CX,PTRSIZE ; compute bytes of stack to move up + mov DX,CX ; copy length (in bytes) and + and DX,1 ; isolate lsb for fixup + shr CX,1 ; convert bytes to words +rep movsw ; move stack contents to top of stack buffer + mov CX,DX ; copy fixup length (0 or 1 bytes) +rep movsb ; copy remaining byte, if needed + + mov FP,0 ; current frame now at top of stack buffer + +; return to caller +stk_rtn: mov SI,[BP].stk_SI ; restore return address disp, if meaningful + add SP,offset stk_BP ; drop local variable storage + pop BP ; restore caller's BP + ret ; return +stk_ovfl endp + +;************************************************************************ +;* Local support - stack underflow handler * +;* * +;* Purpose: To restore segments of the stack, which previously have * +;* been moved to the heap, back into the stack buffer. * +;* * +;* Description: Previously saved stack segments (moved to the heap * +;* as the result of a stack overflow or a call/cc) are * +;* represented as continuation data objects. When this * +;* routine is called, a "stack underflow" has occurred * +;* as an "EXIT" operation needs to access a stack frame * +;* higher in the stack, so data fields with a call/cc * +;* continuation are ignored. * +;************************************************************************ +stk_unfl proc near + push BP ; save caller's BP + mov BP,SP + mov BX,PREV_pag ; fetch previous stack segment's page number + cmp BX,0 ; stack link nil? + je unfl_nil ; if so, jump (real stack underflow) + mov SI,PREV_dis ; load previous stack segment displacement + + push DS ; save caller's DS register + mov CX,DS + mov ES,CX ; ES->stack's data group + LoadPage DS,BX +;;; mov DS,pagetabl+[BX] ; DS->continuation object's page + + mov AX,[SI].con_base ; update stack buffer's base + mov ES:BASE,AX + + mov AL,[SI].con_spag ; update previous stack segment register + mov ES:byte ptr PREV_pag,AL + mov AX,[SI].con_sdis + mov ES:PREV_dis,AX + + mov CX,[SI].con_len ; load length of saved stack data + sub CX,offset con_data ; adjust length for continuation header + add SI,offset con_data ; adjust offset for continuation header + lea DI,S_stack ; load address of bottom of stack + mov DX,CX ; compute new top of stack + sub DX,PTRSIZE + mov ES:TOS,DX ; in memory (temporarily covered by ES) + + add word ptr ES:stk_in,CX ; update count of bytes transfered + adc word ptr ES:stk_in+2,0 ; fix up high order part of counter + + mov DX,CX ; copy the length (in bytes) + and DX,1 ; and determine fixup (0 or 1 bytes) + shr CX,1 ; convert length from bytes to words + cld ; set direction flag = forward +rep movsw ; restore the stack's contents + mov CX,DX ; copy fixup length and +rep movsb ; move the odd byte, if needed + pop DS ; restore DS + pop BP + ret ; return to caller +; Error-- stack underflow +unfl_nil: lea BX,m_stk_un + push BX + C_call printf,,Load_ES + C_call exit +stk_unfl endp + + +;************************************************************************ +;* Local support - Create new stack frame * +;* * +;* Purpose: To create and partially define a new stack frame prior * +;* to a procedure call * +;* * +;* Description: This routine allocates space on the top of the stack * +;* for a new stack frame and defines the following fields: * +;* * +;* code base pointer <- CB * +;* return addr disp <- SI (contents of reg) * +;* dynamic link <- FP * +;* static link's tag <- fixnum * +;* heap env <- current heap env * +;* static link <- current static link * +;* closure pointer <- nil (implies an open call) * +;* * +;* Input Parameters: * +;* TIPC register SI - the VM's location pointer * +;* CB_pag,CB_dis - the VM's code base register * +;* FP - the VM's current frame pointer * +;* TOS - the VM's top of stack pointer * +;* * +;* Output Parameters: * +;* TIPC register BX - pointer to new stack frame * +;* (displacement in stack) * +;* TOS - top of stack pointer updated for new stack length * +;* * +;* Variables Modified: The following variables will be modified if * +;* a stack overflow occurs during the push operation for * +;* the new stack frame: * +;* * +;* FP - the VM's current frame pointer(logically unchanged)* +;* BASE - the VM's stack buffer base * +;* PREV_pag,PREV_dis - the VM's previous stack segment reg * +;************************************************************************ +new_SF proc near + mov AX,TOS ; load current top of stack pointer + mov BX,AX ; and make a copy + add AX,SF_OVHD ; increment TOS by size of stack frame + cmp AX,STKSIZE-PTRSIZE ; is there room on stack for new frame? + jg new_FP_1 ; if not, process stack overflow (jump) + mov TOS,AX ; update top of stack pointer + add BX,PTRSIZE ; compute pointer to new stack frame + + mov AL,SPECFIX*2 ; load tag for fixnum's + mov S_stack+[BX].sf_rtag,AL ; return address tag=fixnum + mov S_stack+[BX].sf_dtag,AL ; dynamic link tag=fixnum + mov S_stack+[BX].sf_stag,AL ; static link tag=fixnum + + xor AX,AX ; store '() into closure pointer + mov S_stack+[BX].sf_cl_pg,AL + mov word ptr S_stack+[BX].sf_cl_ds,AX + + mov AL,byte ptr CB_pag ; move current code base pointer + mov S_stack+[BX].sf_cb_pag,AL ; into the new stack frame + mov AX,CB_dis + mov word ptr S_stack+[BX].sf_cb_dis,AX + + sub SI,AX ; compute ret addr relative to code block + mov word ptr S_stack+[BX].sf_ret,SI ; record the return address + add SI,AX ; restore SI + +; copy the current heap environment pointer to the new stack frame + mov DI,FP ; load the current stack frame pointer + mov AL,S_stack+[DI].sf_hpage + mov S_stack+[BX].sf_hpage,AL + mov AX,word ptr S_stack+[DI].sf_hdisp + mov word ptr S_stack+[BX].sf_hdisp,AX + +; copy the static link from the current frame to the new one + mov AX,word ptr S_stack+[DI].sf_sdisp + mov word ptr S_stack+[BX].sf_sdisp,AX + +; define the dynamic link field + add DI,BASE + mov word ptr S_stack+[BX].sf_ddisp,DI + + ret ; return to the caller + +; Process stack overflow +new_FP_1: push SI ; save current location pointer + call stk_ovfl ; process the overflow + pop SI ; restore location pointer + jmp new_SF ; try again to allocate new stack frame +new_SF endp + + +;************************************************************************ +;* Local support - drop items from the heap environment * +;* * +;* Purpose: To drop "n" items off the local heap environment * +;* * +;* Input Parameters: * +;* TIPC register CX - the number of items to drop * +;* FP - the current stack frame pointer * +;* * +;* Output Parameters: * +;* TIPC register BX - page number for the remaining * +;* heap environment list * +;* TIPC register DI - displacement pointer for the * +;* remaining heap environment * +;* * +;* Registers/Variables Modified: * +;* CX - decremented to zero * +;* TIPC register ES - contents undefined * +;************************************************************************ +delta_hp proc near + mov DI,FP ; load the current stack frame pointer + xor BX,BX ; clear register BX + mov BL,S_stack+[DI].sf_hpage ; load the current heap environment + mov DI,word ptr S_stack+[DI].sf_hdisp ; pointer + cmp CX,0 ; drop zero elements? + jle del_h_rt ; if drop zero, jump +del_h_lp: LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load para addr of page holding list cell + mov BL,ES:[DI].cdr_page ; load link pointer (cdr field) + mov DI,ES:[DI].cdr + loop del_h_lp ; cdr through list for "n" elements +del_h_rt: ret ; return updated heap env ptr in BX,DI +delta_hp endp + + +;************************************************************************ +;* Local support - Obtain Frame Pointer for given lexical level * +;* * +;* Input Parameters: * +;* TIPC register CX - desired lexical level number * +;* 0=current lexical level, * +;* 1=lexical parent's level, etc. * +;* FP - current frame pointer * +;* BASE - current stack buffer base * +;* * +;* Output Parameters: * +;* TIPC register BX - frame pointer for desired level * +;* (absolute location in stack) * +;* ES:[SI] - pointer to desired stack frame * +;* (either in stack buffer, or in the heap) * +;* * +;* Notes: Register usage: * +;* AX - zeroed, so page numbers can be loaded into AL * +;* prior to copying to DI * +;* BX - frame pointer for current level * +;* CX - lexical level counter. decremented at each level * +;* DX - base offset of the stack segment currently being * +;* examined * +;* SI - stack segment's (continuation's) displacement * +;* DI - temporarily hold page number of next stack segment * +;************************************************************************ +delta_lv proc near + mov BX,FP ; load current frame pointer + mov DX,BASE ; and the stack buffer base + cmp CX,0 ; reference to current stack frame? + jg dlt_nt_0 ; if not, jump + +; current lexical level desired-- return active stack frame pointer + lea SI,S_stack+[BX] ; compute addr of current frame pointer + add BX,DX ; adjust for base of stack buffer + mov ES,[BP].C_ES ; load pointer to data segment + ret ; return BX, ES:[SI] to caller + +; find pointer to higher lexical level in stack buffer +dlt_loop: sub BX,DX ; adjust absolute frame ptr by base + jb dlt_in_h ; still in stack buffer? if not, jump +dlt_nt_0: mov BX,word ptr S_stack+[BX].sf_sdisp ; fetch static link + loop dlt_loop ; iterate until desired level found + +; pointer to desired level found in stack buffer + mov SI,BX ; copy absolute frame pointer + sub SI,DX ; adjust for current stack buffer base + jb dlt_nstk ; still within stack buffer? if not, jump + add SI,offset S_stack ; compute address of frame in stack buffer + mov ES,[BP].C_ES ; ES<-data segment + ret ; return BX, ES:[SI] + +; Frame pointer found, but frame's not in stack buffer +dlt_nstk: mov DI,PREV_pag ; load pointer to previous stack segment + mov SI,PREV_dis + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov DX,ES:[SI].con_base + xor AX,AX +dlt_nb: cmp BX,DX ; is frame within this segment? + jae dlt_here ; if so, jump + mov AL,ES:[SI].con_spag ; load pointer to its previous segment + mov DI,AX + mov SI,ES:[SI].con_sdis + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov DX,ES:[SI].con_base ; load stack segment's base offset + jmp dlt_nb ; search 'til segment containing frame found +dlt_here: mov AX,BX ; copy absolute frame pointer for level + sub AX,DX ; subtract this stack segment's base + add SI,AX ; add to continuation offset + add SI,offset con_data ; add fudge factor for continuation header + ret ; return BX, ES:[SI] to caller + +; Desired level not found, but current reference not in stack buffer +dlt_in_h: add BX,DX ; compute absolute location in stack + mov DI,PREV_pag ; load previous stack segment pointer + mov SI,PREV_dis + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov DX,ES:[SI].con_base + xor AX,AX +dlt_in_n: cmp BX,DX ; is frame in this stack segment? + jae dlt_fnd ; if so, jump + mov AL,ES:[SI].con_spag ; fetch pointer to next previous segment + mov DI,AX + mov SI,ES:[SI].con_sdis + LoadPage ES,DI +;;; mov ES,pagetabl+[DI] + mov DX,ES:[SI].con_base ; load this segment's base offset + jmp dlt_in_n ; keep searching stack segments +; Segment containing stack frame found-- fetch static link +dlt_fnd: sub BX,DX ; adjust frame displacement for seg base + mov BX,ES:[SI].con_data.sf_sdisp+[BX] ; load static link + loop dlt_in_n ; follow chain to desired lexical level + jmp dlt_nb ; found-- return pointer to stack frame + +delta_lv endp + + +;************************************************************************ +;* Local support - Expand "apply's" argument list into registers R1-Rn * +;* * +;* Purpose: To expand the argument list of an "apply" so that the * +;* operands are in the proper operand registers (R1-Rn) * +;* for a call to a closed procedure. * +;* * +;* Input Parameters: TIPC register AH - the number of the VM's * +;* general register which contains the pointer to * +;* the linked list of arguments. * +;* * +;* Output Parameters: TIPC register CX - a count of the arguments. * +;* * +;* Note: The "apply" operation expects two operands which are a * +;* function and a 'list' of arguments. In the event that * +;* the second argument is not a list, this routine simply * +;* substitutes that value as if it were an argument. This * +;* means that the "LIST" function is not actually needed * +;* for an argument list containing only one value. * +;* For example, the following are handled equivalently: * +;* * +;* "correct" code "not-correct" code * +;* (apply ftn (list 1)) (apply ftn 1) * +;* (apply ftn (list a b)) (apply ftn (cons a b)) * +;* * +;* Although this could be viewed as an optimization, in * +;* that it saves one list cell each time the argument list * +;* is created, the real reason it is done is to provide * +;* a fixup action when an error condition is detected. * +;************************************************************************ +aply_arg proc near +; Count the number of arguments to make sure there aren't too many + xor BX,BX ; copy the register number of the + mov BL,AH ; argument list to BX + mov SI,reg0_dis+[BX] ; load the argument list pointer + mov BX,reg0_pag+[BX] + xor CX,CX ; zero the argument counter +aply_lp1: cmp BL,0 ; is pointer nil? + je aply_ok ; if so, the last argument has been moved + inc CX ; increment the argument count + cmp CX,NUM_REGS-2 ; (can't use R0 or R63) + jg aply_err + cmp byte ptr ptype+[BX],LISTTYPE*2 ; pointer to a list cell? + jne aply_ok ; if not, assume last argument + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load para addr for list cell's page + mov BL,ES:[SI].cdr_page ; load the "cdr" pointer (next cell) + mov SI,ES:[SI].cdr + jmp aply_lp1 ; process 'til end of argument list + +; copy arguments into the registers +aply_ok: mov BL,AH ; copy arg list register back into BX + mov SI,reg0_dis+[BX] ; load the argument list pointer + mov BX,reg0_pag+[BX] + lea DI,reg1 ; load the address of VM register R1 + +aply_lp: cmp BL,0 ; is pointer nil? + je aply_don ; if so, the last argument has been moved + cmp byte ptr ptype+[BX],LISTTYPE*2 ; pointer to a list cell? + jne aply_huh ; if not, we've got a problem (jump) + LoadPage ES,BX +;;; mov ES,pagetabl+[BX] ; load para addr for list cell's page + mov AL,ES:[SI].car_page ; move the "car" portion of the list + mov byte ptr [DI].C_page,AL ; cell into the next available + mov AX,ES:[SI].car ; general register of the VM + mov [DI].C_disp,AX + mov BL,ES:[SI].cdr_page ; load the "cdr" pointer (next cell) + mov SI,ES:[SI].cdr + add DI,size C_ptr ; increment next register's address + jmp aply_lp ; process 'til end of argument list + +; If an element in the argument list is not a list cell, simply place +; that pointer into the next register. +aply_huh: mov [DI].C_page,BX + mov [DI].C_disp,SI + +aply_don: ret ; return to caller + +; ***Error-- too many arguments to expand into register*** +aply_err: restore ; reload the current location pointer and + sub SI,3 ; back it up to start of "apply" instruction + pushm ; push function name, offset + C_call disassem,,Load_ES ; call: disassemble("APPLY",offset); + pushm ; push arguments + C_call set_nume ; call: set_numeric_error(1,code,tmp_reg) + restore ; reload the location pointer + jmp sch_err ; Link to Scheme debugger +aply_arg endp + + +;************************************************************************ +; Lattice C callable routine to push a register onto Scheme's stack * +; Calling Sequence: C_push(reg) * +; where: int reg[2] - register (pointer/value) to push * +;************************************************************************ +C_args struc +C_BP dw ? ; Caller's BP + dw ? ; Return address +C_reg dw ? ; Pointer to register +C_args ends + + public C_push +C_push1 proc near +; Process overflow-- copy contents of stack to the heap +C_push2: push ES ; save ES across the call + call stk_ovfl ; copy the stack contents + pop ES ; restore ES + ; retry the push (fall through) +C_push: mov AX,TOS ; load the top of stack pointer + cmp AX,STKSIZE-PTRSIZE ; test for overflow + jge C_push2 ; jump, if overflow is going to occur + add AX,PTRSIZE ; decrement stop of stack pointer + mov TOS,AX ; and update it in memory + add AX,offset S_stack ; load the address of the new TOS + mov DI,AX ; copy TOS address into DI + pop DX ; unload the return address + pop BX ; load address of register to push + mov AL,byte ptr [BX].C_page ; load the page number, + mov [DI].car_page,AL ; pointer displacement, + mov AX,[BX].C_disp ; and move onto the top of + mov [DI].car,AX ; Scheme's stack + jmp DX ; return to caller +C_push1 endp + +;************************************************************************ +; Lattice C callable routine to pop a register from Scheme's stack * +; Calling Sequence: C_pop(reg) * +; where: int reg[2] - register to hold the value popped * +;************************************************************************ + public C_pop +C_pop proc near + mov AX,TOS ; load the top of stack pointer + sub AX,PTRSIZE ; increment stop of stack pointer + mov TOS,AX ; and update it in memory + add AX,offset S_stack+PTRSIZE ; load the address of the old TOS + mov SI,AX ; copy top of stack address into SI + pop DX ; unload the return address + pop BX ; fetch address of destination register + mov AL,[SI].car_page ; load page number, + mov byte ptr [BX].C_page,AL ; pointer displacement, + mov AX,[SI].car ; and update into + mov [BX].C_disp,AX ; receiving register + jmp DX ; return to caller +C_pop endp + +;************************************************************************ +;* Lattice C callable routine to force a Scheme VM call * +;* Calling Sequence: force_call(ret) * +;* where: int ret - the return address (relative to the * +;* current code block) * +;************************************************************************ +fc_args struc + dw ? ; caller's BP + dw ? ; return address +fc_ret dw ? ; Scheme return address +fc_args ends + + public force_ca +force_ca proc near + push BP ; save the caller's BP register + mov BP,SP ; establish local addressability + mov SI,[BP].fc_ret ; load the Scheme program return address + call new_SF ; create a new stack frame + mov FP,BX ; update the current frame pointer + pop BP ; restore the caller's BP + ret ; return to caller +force_ca endp + +prog ends + +PROGX segment byte public 'PROGX' + assume CS:XGROUP +bad_obj1: jmp bad_obj2 +load_ex label far + save ; save dest register, location pointer + cmp byte ptr ptype+[DI],LISTTYPE*2 ; is "code" pointer a list? + jne bad_obj1 ; if not, error (jump) + %LoadPage ES,DI +;;; mov ES,pagetabl+[DI] ; load pointer to "compiled program" + mov SI,reg0_dis+[BX] +; skip over "tag" portion of object program + mov BL,ES:[SI].cdr_page + mov SI,ES:[SI].cdr +; fetch the number of constants and multiply by three bytes/constant + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is this a list cell? + jne bad_obj1 ; if not, error (jump) + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp ES:[SI].car_page,SPECFIX*2 ; is car's entry a fixnum? + jne bad_obj1 ; if not, error (jump) + mov AX,ES:[SI].car ; fetch immediate value of fixnum + shl AX,1 ; sign extend immediate value + sar AX,1 + inc AX ; add a constant for entry point address + mov DX,AX ; DX <- AX * 3 + shl AX,1 + add DX,AX + mov BL,ES:[SI].cdr_page ; follow cdr field of linked list + mov SI,ES:[SI].cdr +; fetch the number of code bytes + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is this a list cell? + jne bad_obj1 ; if not, error (jump) + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp ES:[SI].car_page,SPECFIX*2 ; is car's entry a fixnum? + jne bad_obj1 ; if not, error (jump) + mov AX,ES:[SI].car ; fetch immediate value of fixnum + shl AX,1 ; sign extend immediate value + sar AX,1 +; compute number of bytes needed and allocate a new code block + add AX,DX ; add constants*3 + codebytes + mov BX,CODETYPE + pushm ; push arguments onto TIPC's stack + save ; preserve register DX across call + mov AX,DS ; make ES point to the data segment + mov ES,AX + call %allocbl ; allocate the code block + mov SP,BP ; drop arguments from stack +; load pointer to newly allocated code block + mov DI,tmp_page + %LoadPage ES,DI +;;; mov ES,pagetabl+[DI] +;;;; mov DX,ES ; save code block's paragraph address in DX + mov DX,DI ; save code block's page number in DX + mov DI,tmp_disp + add DI,PTRSIZE ; advance DI past block header +; store entry point address into code block + mov AL,SPECFIX*2 ; store tag=fixnum for entry point address + stosb + mov AX,[BP].save_DX ; store entry point address + add AX,PTRSIZE ; adjust entry point for block header + stosw +; reload pointer to object program [Note: garbage collection may have +; copied the linked list representation of the program, so pointers +; held in TIPC registers may not be valid.] + restore + mov SI,reg0_pag+[BX] ; load pointer to "object program" + %LoadPage ES,SI +;;; mov ES,pagetabl+[SI] + mov SI,reg0_dis+[BX] + mov BL,ES:[SI].cdr_page ; skip over "tag" + mov SI,ES:[SI].cdr + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov CX,ES:[SI].car ; load number of constants + shl CX,1 ; sign extend immediate value + sar CX,1 + mov BL,ES:[SI].cdr_page ; skip over number of constants + mov SI,ES:[SI].cdr + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + mov AX,ES:[SI].car ; load number of code bytes + shl AX,1 ; sign extend immediate value + sar AX,1 + mov BL,ES:[SI].cdr_page ; skip over number of codebytes + mov SI,ES:[SI].cdr + cmp byte ptr ptype+[BX],LISTTYPE*2 + je ok_obj + +; ***error-- invalid object format*** +bad_obj: jmp bad_obj2 + +ok_obj: %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + pushm ; save # codebytes, ptr to const's list cell + mov BL,ES:[SI].car_page ; load constant list header + mov SI,ES:[SI].car +;;;; mov ES,DX + %LoadPage0 ES,DX + cmp CX,0 ; zero length constants list? + je c_end ; if no constants, skip loop +c_loop: cmp BL,0 ; end of constants list? + je bad_obj ; if so, premature end of constant list + cmp byte ptr SS:ptype+[BX],LISTTYPE*2 ; is entry a list cell? + jne bad_obj ; if not, error (jump) + %LoadPage1 DS,BX +;;; mov DS,SS:pagetabl+[BX] ; fetch page's address + movsb ; copy car field to code block constants + movsw ; area + lodsb ; load cdr field to follow linked list + mov BL,AL + mov SI,[SI] + loop c_loop ; continue through constants list +; end of constants list-- process byte codes +c_end: + pop DS ; restore previously saved regs + pop SI + mov CX,BX ; tempsave current bx reg + pop BX ; bx = page number + %LoadPage ES,BX ; load segment register + mov BX,CX ; restore bx register + pop CX + + cmp BL,0 ; end of list found? + jne bad_obj ; if not, too many constants (jump) +; fetch pointer to codebyte list + mov BL,ES:[SI].cdr_page + mov SI,ES:[SI].cdr + cmp byte ptr ptype+[BX],LISTTYPE*2 ; is next entry a list cell? + jne bad_obj ; if not, error (jump) + %LoadPage ES,BX +;;; mov ES,pagetabl+[BX] + cmp ES:[SI].cdr_page,0 ; last entry in object program list? + je next$0 + jmp bad_obj ; if not, error (jump) +next$0: mov BL,ES:[SI].car_page ; load header to bytecode list + mov SI,ES:[SI].car + %LoadPage0 ES,DX ; Restore code block's paragraph address +;;; mov ES,DX + push DS +d_loop: cmp BL,0 ; end of constants list? + jne d_l$0 + jmp bad_obj ; if so, premature end of constant list +d_l$0: + cmp byte ptr SS:ptype+[BX],LISTTYPE*2 ; is entry a list cell? + je d_l$1 + jmp bad_obj ; if not, error (jump) +d_l$1: + %LoadPage1 DS,BX +;;; mov DS,SS:pagetabl+[BX] ; fetch page's address + lodsb ; load car's page number + cmp AL,SPECFIX*2 ; is codebyte entry a fixnum? + je d_lp_nxt ; Yes, continue + jmp bad_obj ; No, error +d_lp_nxt: + lodsw ; load immediate value + stosb ; store low order byte into code block + lodsb ; load cdr field to follow linked list + mov BL,AL + mov SI,[SI] + loop d_loop ; continue through codebyte list +; end of codebyte list-- move code block pointer to destination register + pop DS ; restore TIPC register DS + cmp BL,0 ; extraneous codebytes in list? + jne bad_obj3 ; if so, error (jump) + restore ; re-fetch dest reg, location pointer + mov AL,byte ptr tmp_page ; copy code block pointer into + mov byte ptr reg0_pag+[BX],AL ; destination register + mov AX,tmp_disp + mov reg0_dis+[BX],AX + jmp far ptr execute1 ; execute the code block +bad_obj3: jmp bad_obj +PROGX ends + + end + \ No newline at end of file diff --git a/sstring.asm b/sstring.asm new file mode 100644 index 0000000..1333e80 --- /dev/null +++ b/sstring.asm @@ -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","?" + + 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 , + 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 , +error_2: add BX,offset reg0 ; compute address of source 2 + pushm ; push source 2, source 1, operation name + C_call set_src_,,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-, + mov BX,offset hicases +ELSE +IFIDN , + 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 , +error_1: pushm ; push operand, operand count, instr. name + C_call set_src_,,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 ; 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 ; 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 ; 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 ; 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 , + lods byte ptr ES:[SI] ; load source operand register number + mov DL,AL ; and save it in TIPC register DL +ENDIF + save ; 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 , + 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 , + 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 , + mov DX,3 ; STRING-REF is 3 bytes long +s_out_bn: restore ; load location pointer and + sub SI,DX ; back up to start of instruction in error + pushm ; push instruction's offset, name + C_call disassem,,Load_ES ; disassemble instruction for *irritant* + pushm ; push args to "set_numeric_error" + C_call set_nume ; set_numeric_error(1,ST_OFF_ERR,tmp_reg); + restore ; 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 + \ No newline at end of file diff --git a/stackf.equ b/stackf.equ new file mode 100644 index 0000000..1293e1f --- /dev/null +++ b/stackf.equ @@ -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 + \ No newline at end of file diff --git a/stdio.h b/stdio.h new file mode 100644 index 0000000..0697e2f --- /dev/null +++ b/stdio.h @@ -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 + + diff --git a/stimer.asm b/stimer.asm new file mode 100644 index 0000000..8b0a204 --- /dev/null +++ b/stimer.asm @@ -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 + + \ No newline at end of file diff --git a/strmlnrs.asm b/strmlnrs.asm new file mode 100644 index 0000000..ae5e1b3 --- /dev/null +++ b/strmlnrs.asm @@ -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 + \ No newline at end of file diff --git a/sutil.asm b/sutil.asm new file mode 100644 index 0000000..7a0c64b --- /dev/null +++ b/sutil.asm @@ -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(®, 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 + \ No newline at end of file diff --git a/svars.asm b/svars.asm new file mode 100644 index 0000000..241fd96 --- /dev/null +++ b/svars.asm @@ -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 ; 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 , + 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 ; 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 ; 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 ; 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 ; push arguments for error call + C_call not_flui,,Load_ES ; call error routine + restore ; 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 ; 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 ; push arguments to "cons" + C_call cons,,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 ; 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 ; 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 ; push arguments + C_call alloc_bl,,Load_ES ; call: alloc_block(®, 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 + sub SI,2 + pushm + C_call disassem,,Load_ES + pushm + 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 ; 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 ; 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 ; 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 ; 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 ; save our state around C call + pushm ; list elt, key, operation + C_call arith2,,Load_ES ; do = + popm ; get C args off stack + popm ; 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 ; 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 ; 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 ; 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 ; 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 ; 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 ; 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 ; save our state around C call + pushm ; list elt, key, operation + C_call arith2,,Load_ES ; do = + popm ; get C args off stack + popm ; 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 ; 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 ;****** 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 ; 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 ; 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(®) * +;* where ® - 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 + \ No newline at end of file diff --git a/sw_int.asm b/sw_int.asm new file mode 100644 index 0000000..d685d0a --- /dev/null +++ b/sw_int.asm @@ -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 + \ No newline at end of file diff --git a/version.h b/version.h new file mode 100644 index 0000000..96ee114 --- /dev/null +++ b/version.h @@ -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 + \ No newline at end of file diff --git a/xli.asm b/xli.asm new file mode 100644 index 0000000..3b69433 --- /dev/null +++ b/xli.asm @@ -0,0 +1,1371 @@ +; =====> XLI.ASM +; PC Scheme External Language Interface (XLI) +; (c) 1987,1988 by Texas Instruments Incorporated -- all rights reserved +; Author: Bob Beal +; History: +; rb 3/20/87 - original +; rb 2/ 2/88 - check XLI ID; +; added external-program error return +; + + + page 84,120 + name PCSXLI + title PC Scheme External Language Interface + + include scheme.equ + include xli.equ + include xli.ref + include xli.mac + + subttl Group and Constant definitions + page +pgroup group prog +xgroup group progx +dgroup group data + + subttl Data segment definitions + page + +data segment para public 'DATA' + assume ds:dgroup + + public load_table,work_area,active_exe ;??? for debugging + +; Various tables +load_table dw N_EXE dup (0) ;PSP addresses (segment) +fb_table dd N_EXE dup (0) ;file block addresses (offset,segment) +pb_table dd N_EXE dup (0) ;parm block addresses (offset,segment) +state_table state N_EXE dup (<>) ;child's regs at point it called us +status_table label word ;records .EXE state (MSBy) and index (LSBy) +x = 0 + rept N_EXE + dw x +x = x+1 + endm + +; Parameter block for EXEC function request +zero equ $ ;a constant zero +exec_pblock dw 0 ;env@ (use Scheme's) + dw zero,seg zero ;cmd line@ (don't care) + dd -1 ;FCB@'s (don't care) + dd -1 + +; Working storage (during a given call to the external routine) + align 16,data +work_area label word ;for dealing with PCS data values +exe_name label byte ;a filename from XLI's control file + db PAD_SIZE*N_ARGS dup (0) ;during xesc, non-strings go here +; other information required during an xesc call +work_info xesc_struc <> ;general info +swap_table swap_struc N_ARGS dup (<>) ;records swap state for each XCALL arg +exe_name1 dw offset exe_name ;pointer into exe_name to filename.extension + ;(i.e. points past directory prefix) +bid_name dw 0 ;pointer into exe_name; used for bidding child +; the child currently active or being loaded +active_exe dw 0 ;(same format as status table) +; system .EXE information +sysflag db 0 ;0=user .EXE; 1=system .EXE + ;look for system .EXE's only in pcs-sysdir +pcs_exe db 'newtrig.exe',0 ;PCS system .EXE files +pcs_exe_len equ $-pcs_exe + +; State (context) information +; child's registers upon calling PCS +save_ax dw 0 ;actually, we ignore ax..di entries +save_bx dw 0 +save_cx dw 0 +save_dx dw 0 +save_si dw 0 +save_di dw 0 +save_ds dw 0 +save_es dw 0 +save_ss dw 0 +save_sp dw 0 +save_bp dw 0 +; our registers upon calling child +pcs_state state <> ;our state at point of calling child +; the SP just after the indirect call through "gate"; +; error recovery is done with: +; mov SP,gate_SP +; ret +; which returns to the instruction following the indirect call +gate_SP dw 0 + + +data ends + + + subttl Code segment: load_all + page + +; external variables + extrn ctl_file:word,pcs_sysd:word + extrn regs:word +; external routines + extrn alloc_fl:near,int2long:near,long2int:near,alloc_bl:near + extrn getbase:near + +progx segment para public 'PROGX' + assume cs:xgroup,ds:dgroup,es:dgroup,ss:dgroup + + public %xli_gate + public load_all,load_exe,bid_child,c2p_handler,c2p_terminate + public xesc1,unload_all,find_open_spot,table_search + public do_floarg,do_fixarg,do_bigarg,do_strarg + public do_floval,do_intval,do_TFval,do_strval + public unload_exe,unload_all,update_swap_table + + +; This routine is called when PCS first comes up. External programs are +; loaded first (by this file) and then the Scheme heap is allocated (initmem). +; Any errors encountered are ignored. If we run of memory, initmem +; should see it too and notify smain to abort. + +load_all proc +; First copy into exe_name buffer the pcs-sysdir name. + cld + push ds ;make ES=DS + pop es + mov di,pcs_sysd + mov cx,64 ;max length of pathname + mov al,0 + repne scasb ;look for eos character (=0) + jcxz la_5 ;jump if none + dec di +la_5: mov cx,di + sub cx,pcs_sysd ;get length of pcs-sysdir + ;without eos character + mov si,pcs_sysd + mov di,offset exe_name + rep movsb ;copy pcs-sysdir name (- eos) + ;into exe_name buffer + mov al,'\' ;append \ onto pcs-sysdir name + dec di + cmp [di],al ;is '\' last char of pcs-sysdir? + je la_7 ;yes; write it over itself + inc di ;no; move past end, then write +la_7: stosb + mov exe_name1,di ;exe_name1 points to next + ;open position in exe_name +; load system .EXE files + mov bx,ctl_file + cmp byte ptr [bx],'-' ;suppress loading system .EXE's? + jne sysload ;no + inc ctl_file ;yes, move past marker + jmp short userload ;and skip loading system .EXE's +sysload: mov si,offset pcs_exe ;get first system .EXE name + mov di,exe_name1 + mov cx,pcs_exe_len + rep movsb ;copy into buffer after + ;pcs-sysdir name + mov sysflag,1 ;set sysflag + call load_exe ;load the file +; open XLI control file +userload: mov sysflag,0 + dos_fr FR_OPEN,,,ctl_file,ds + mov bx,ax ;put handle in BX + jnc next_file ;jump if no open errors + jmp close1 ;can't open file, exit +; read in next filename off the control file and append it to +; the pcs-sysdir name +next_file: mov dx,exe_name1 ;init buffer @ +next_char: dos_fr FR_READ,bx,1,dx,ds ;read 1 character + jnc la_10 ;jump if no error, else + ;suddenly can't read control + ;file, close it and exit +close: dos_fr FR_CLOSE,bx +close1: ret + +la_10: cmp ax,0 ;at eof? + jz close ;yes, jump +; we've read a character + mov si,dx + cmp byte ptr [si],' ' ;blank? + je next_char ;yes, skip it + cmp byte ptr [si],0Dh ;carriage return? + je got_file ;yes, jump + cmp byte ptr [si],' ' ;control char? + jl next_char ;yes, skip it + inc dx ;point to next buffer position + jmp next_char +; we've read a complete filename, go load it +got_file: mov byte ptr [si],0 ;form ASCIIZ string + call load_exe ;bid it + jnc next_file ;jump if no errors + cmp ax,0 ;any open slots? + je close ;no, jump + cmp ax,2 ;file found? + je next_file ;no, jump + cmp ax,8 ;ran out of memory? + jne next_file ;no, jump; ignorable error + jmp close ;yes + +load_all endp + +; Given exe_name, this routine loads the child into any available open slot. +; On exit: +; success: carry clear +; failure: carry set +; AX = 0 : no open slots +; AX <> 0 : EXEC failure code +load_exe proc + push ax + push bx +; if we succeed, state=EXE_NONE + call find_open_spot ;this sets active_exe + mov ax,0 + jc le_exit ;no open slots +; set state=EXE_TSR for time between EXEC and TSR + load_index itself + mov bh,EXE_TSR + mov active_exe,bx + cmp sysflag,1 ;loading system .EXE? + je le_5 ;yes, look only in pcs-sysdir + mov ax,exe_name1 ;try current directory first + mov bid_name,ax + call bid_child + jnc le_10 ;bid succeeded, jump +le_5: mov ax,offset exe_name ;try again with pcs-sysdir prefix + mov bid_name,ax + call bid_child + jc le_exit ;bid failed, jump +; child is ready, set state=EXE_NORM +le_10: load_index itself + mov bh,EXE_NORM + mov ax,bx + load_index status_table + mov status_table[bx],ax + clc +le_exit: pop bx + pop ax + ret +load_exe endp + +;le_err: cmp ax,0 +; je le_exit ;it's not up, just exit +; cmp ax,8 +; jne fail1 +; mov ax,XLI_ERR_NO_MEMORY +; jmp xli_err_exit +;fail1: cmp ax,2 +; jne fail2 +; mov ax,XLI_ERR_NO_SUCH_FILE +; jmp xli_err_exit +;fail2: mov ax,XLI_ERR_BAD_EXEC +; jmp xli_err_exit +;le_err1: cmp xli_up,0 ;can't do usual error handling if +; ;system's not up yet +; je le_exit ;it's not up, just exit +; mov ax,XLI_ERR_NO_AVAILABLE_SLOTS +; jmp xli_err_exit + +; Given a filename in "exe_name", initialize it under XLI. +; The EXEC status is returned. +; Assume AX..DI,ES are destroyed; DS,SS,SP,BP are preserved. +bid_child proc + push ds ;save parent's state + push bp + save_parent + mov cs:stk_seg,ss + mov cs:stk_offset,sp + dos_fr FR_EXEC,,,bid_name,ds,ds + +; The following are external entry points accessible by the child. +biddbg: jmp tsr_done ; --- THE BIG 4 --- (not for child's use) + jmp c2p_handler ; --- THE BIG 4 --- for XCALL's + jmp c2p_terminate ; --- THE BIG 4 --- for child termination + +tsr_done: cli + mov ss,cs:stk_seg + mov sp,cs:stk_offset + sti + pop bp + pop ds + ret + +stk_seg dw 0 ;bootstrap parent's state after EXEC +stk_offset dw 0 ;from here + +bid_child endp + + subttl Code segment: Child->parent handler + page + +; On entry to this routine PCS is executing in the child's environment. +; The relevant stack entries at this point are: +; SS:SP (top) -> IP ;child's far return address +; CS +; length ;child's length; for TSR +; PSP@ ;child's PSP@ +; //// ;(the rest of the stack) + +c2p_handler label near + resume_parent + load_index itself + cmp bh,EXE_NORM ;normal call from child? + jne c2_10 ;no, jump; could be TSR + jmp normal ;yes, jump--rejoin xesc +c2_err: mov ax,XLI_ERR_SYNC_ERR + jmp xli_err_exit +c2_10: cmp bh,EXE_TSR ;first call from child? (before TSR) + jne c2_err ;no, jump + load_index state_table + lea bx,state_table[bx] + mov es,[bx].st_ss + mov bp,[bx].st_sp ;ES:BP is child's SS:SP + mov ax,es:[bp].cs_psp ;get child's PSP off its stack + load_index load_table + mov load_table[bx],ax ;save it + push ds ;-----> DS set to child's PSP + mov ds,ax + mov ax,ds:fb_ptr ;get file block @ + mov cx,ds:fb_ptr+2 + mov dx,ds:env_ptr ;get env block @ (seg addr) + pop ds ;<----- + load_index fb_table + mov word ptr fb_table[bx],ax ;save it + mov word ptr fb_table+2[bx],cx + push es ;tempsave child's SS:SP on stack + push bp + mov bp,ax + mov es,cx ;ES:BP is file block @ + mov ax,es:[bp].fb_pb + mov cx,es:[bp].fb_pb+2 ;get parm block @ + load_index pb_table + mov word ptr pb_table[bx],ax ;save it + mov word ptr pb_table+2[bx],cx + test word ptr es:[bp].fb_flags,FB_KEEPENV + ;keep child's env block? + jnz c2_20 ;yes, jump + dos_fr FR_RELMEM,,,,,dx ;no, release it for child +c2_20: pop bp + pop es + mov dx,es:[bp].cs_len ;get child's length off its stack +; we're ready to TSR the child + dos_fr FR_TSR,,,dx +; we don't drop through ----------------------------------------- + + + subttl Code segment: Child termination + page + +; After the child has performed its wrapup, it calls this routine +; to deallocate its memory and make its spot in the load table available. +c2p_terminate label near + mov ax,dgroup ;we needn't save child's context now + mov ds,ax + restore_parent + load_index load_table ;release the child + dos_fr FR_RELMEM,,,,,load_table[bx] + jc ct_err + load_index itself ;mark its spot as available + xor bh,bh + mov ax,bx + load_index status_table + mov status_table[bx],ax + jmp normal1 ;rejoin unload_exe +ct_err: mov ax,XLI_ERR_RELMEM + jmp xli_err_exit + + subttl Code segment: xesc + page + +; This is the handler for the "%xesc" opcode. +; +; On entry: +; AX = length of xesc call (= inst length - 1) +; ES:SI = pointer to bytecode containing the (reg# x 4) of +; the %xesc name string +; On exit: +; normal: the VM reg that contained the name string on entry +; will contain the page:offset of the return value; +; there may be side effects in strings that were arguments to %xesc +; BX = 0 (no errors) +; error: BX = error# + +xesc proc near +xesc1: cld + sub ax,2 ;adjust to #args *to %xesc* + ;(len, name are not args) + mov work_info.xs_nargs,ax ;save actual #args +; Get from register# (actually, reg x 4) to lookup string. + lods byte ptr es:[si] + mov bl,al + xor bh,bh ;BX is reg# x 4 of name string + mov work_info.xs_pc,si ;save bytecode@ + mov work_info.xs_pc+2,es + mov work_info.xs_rvreg,bx ;save reg# x 4; + ;return value goes here + lea bx,regs[bx] ;reg# x 4 -> VM reg @ + mov si,[bx].C_page + cmp ptype[si],STRTYPE*2 ;is it a string? + je xesc_5 ;yes, jump + cmp ptype[si],SYMTYPE*2 ;is it a symbol? + je xesc_3 ;yes, jump + mov ax,XLI_ERR_NAME_BAD_TYPE ;error: name not string, symbol + jmp xesc_err_exit +xesc_3: %LoadPage es,si ;page# in SI -> para# in ES + mov bp,[bx].C_disp ;ES:BP is symbol object @ + mov ax,es:[bp].sym_len ;get symbol object length + sub ax,sym_ovhd ;subtract symbol's overhead + add bp,sym_ovhd ;skip past overhead + jmp short xesc_9 +xesc_5: %LoadPage es,si ;page# in SI -> para# in ES + mov bp,[bx].C_disp ;ES:BP is string object @ + mov ax,es:[bp].str_len ;get string object length + cmp ax,0 ;is it positive? + jge xesc_8 ;yes, jump; normal string + add ax,str_ovhd*2 ;no, assume short string + ;rather than really long string + ;and make positive +xesc_8: sub ax,str_ovhd ;subtract string's overhead + add bp,str_ovhd ;skip past overhead +xesc_9: mov work_area.srch_slen,ax ;save length of string data + mov work_area.srch_sptr,bp ;save address of string data + mov work_area.srch_sptr+2,es +; Look for a match. + call table_search ;is there a match? + ;(sets active_exe if so) + jnc xesc_10 ;yes, jump + mov bx,work_info.xs_rvreg ;get the name + lea bx,regs[bx] + mov ax,XLI_ERR_NO_SUCH_NAME ;error: no such name loaded + jmp xesc_ext_err_exit ;use alternate error point + ;so name gets printed with + ;error message +xesc_10: mov dx,ax ;tempsave selector +; There was a match. +; Collect the info we'll need to guide us thru xesc call. + load_index fb_table + mov bp,word ptr fb_table[bx] + mov es,word ptr fb_table+2[bx] ;ES:BP is file block @ + mov ax,es:[bp].fb_id ;XLI ID + cmp ax,XLI_ID + je xesc_15 + mov ax,XLI_ERR_BAD_VERSION + jmp xesc_err_exit +xesc_15: mov ax,es:[bp].fb_flags ;flags + mov work_info.xs_flags,ax + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @ + mov work_info.xs_pb_segment,es ;parm block's segment address + lea ax,es:[bp].pb_rv + mov work_info.xs_rvptr,ax + mov work_info.xs_rvptr+2,es ;return value's address + mov es:[bp].pb_rv,0 ;zero out return value + mov es:[bp].pb_rv+2,0 + mov es:[bp].pb_rv+4,0 + mov es:[bp].pb_rv+6,0 + mov es:[bp].pb_rvtype,SWI_TF ;set ret value's type to T/F + mov es:[bp].pb_ss,0 ;zero out special service + add ax,8 + mov work_info.xs_args,ax ;first arg's address + mov work_info.xs_args+2,es + mov work_info.xs_local,offset work_area ;work area address + mov work_info.xs_local+2,seg work_area +; Begin initializing child's parameter block. + mov es:[bp].pb_select,dx ;store selector into parm block + mov work_info.xs_select,dx +; Move the xesc arguments to their places for the xesc call. +; mov cx,work_info.xs_nargs ;CX is #args +;xesc_20: cmp cx,0 ;any left? +; jcxz xesc_50 ;no, jump + mov cx,0 ;CX is current arg# +xesc_20: cmp cx,work_info.xs_nargs ;any left? + je xesc_50 ;no, jump + push cx ;tempsave current arg# + mov si,work_info.xs_pc + mov es,work_info.xs_pc+2 ;ES:SI is bytecode@ + lods byte ptr es:[si] + mov work_info.xs_pc,si ;save next bytecode @ + mov bl,al + xor bh,bh ;BX is reg# x 4 +; Put the reg# and current arg @ into swap table + mov ax,bx + xchg bx,cx ;BX is current arg# + shl bx,1 + shl bx,1 ;make index into swap table + mov word ptr swap_table[bx].sw_reg,ax ;save VM reg# x 4 + mov ax,work_info.xs_args + mov word ptr swap_table[bx].sw_offset,ax ;save arg@ + mov bx,cx ;restore reg# x 4 +; Dispatch on argument type + lea bx,regs[bx] ;BX is VM reg @ + mov di,[bx].C_page ;get its page# + mov di,ptype[di] ;and its type +; push cx + call cs:word ptr do_arg[di] ;handle one type of object + add work_info.xs_local,PAD_SIZE ;incr XLI-local ptr + ;(maintain alignment) + pop cx ;restore current arg# +; dec cx + inc cx + jmp xesc_20 + +; Everything's ready. Call the child. +xesc_50: call update_swap_table + call_child 1 + +; We're back with a return value--unless it's a special service call. +normal: cld + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @ + cmp es:[bp].pb_ss,0 ;any special services? + je xesc_60 ;no, jump + call ssr ;do special service and + jmp xesc_50 ;return immediately back + ;across the interface +; Now we're really back with the return value +xesc_60: mov di,es:[bp].pb_rvtype + mov work_area.xs_rvtype,di ;return value's type + cmp di,RV_ERR ;external-pgm error return? + jne xesc_65 ;no, jump + mov bp,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:BP points to return value + ;(external-pgm error message) + call cs:word ptr do_val[SWI_STR*2] ;build string + mov bx,work_info.xs_rvreg + lea bx,regs[bx] ;BX=addr of reg with error string + mov ax,XLI_ERR_EXTERNAL_ERROR ;AX=XLI error code + jmp short xesc_ext_err_exit + +xesc_65: cmp di,N_RV ;return value out of range? + jb xesc_70 ;no, jump + mov ax,XLI_ERR_VALUE_BAD_TYPE + jmp xesc_err_exit +xesc_70: shl di,1 + mov bp,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:BP point to return value + call cs:word ptr do_val[di] ;handle one type of return value + lea bx,nil_reg ;CX says "nil irritant" + mov ax,0 ;BX=0 says no errors + ret + +; This file's error exit processing. Reset the stack so that we return +; immediately to the gate. BX should be set with an error code before +; jumping here. +xli_err_exit: +xesc_err_exit: ;AX contains error# + lea bx,nil_reg ;BX is "nil irritant" +; Another exit label. This allows both AX (XLI error code) and BX +; (the address of the VM register with the "irritant") to be set beforehand. +xli_ext_err_exit: +xesc_ext_err_exit: + mov sp,gate_sp ;return to gate + ret + + +;; Jump tables +; indexed by argument type (standard PCS type tag) +do_arg dw do_lstarg ;0=list (#f only) + dw do_fixarg ;1=fixnum + dw do_floarg ;2=flonum + dw do_bigarg ;3=bignum + dw do_symarg ;4=symbol (#t only) + dw do_strarg ;5=string + dw do_errarg ;6 the rest we don't care about + dw do_errarg ;7 + dw do_errarg ;8 + dw do_errarg ;9 + dw do_errarg ;10 + dw do_errarg ;11 + dw do_errarg ;12 + dw do_errarg ;13 + dw do_errarg ;14 + dw do_errarg ;15 + +; indexed by value type (SW-INT return types) +do_val dw do_intval ;0=integer + dw do_TFval ;1=true/false + dw do_strval ;2=string + dw do_floval ;3=flonum + +xesc endp + + subttl Code segment: Copy arguments into place for child + page + +; On entry to all the argument handler routines: +; BX = pointer to VM reg with page:offset of Scheme object + +do_floarg proc near + mov si,[bx].C_page ;get object's page# + %LoadPage es,si ;swap it in + mov si,[bx].C_disp ;ES:SI is Scheme object @ + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_flo10 ;no, jump +; Set up destination address + ; near + mov cx,work_info.xs_args ;dest is in child + mov dx,work_info.xs_args+2 + mov work_info.xs_dest,cx + mov work_info.xs_dest+2,dx + jmp short do_flo20 + ; far +do_flo10: mov cx,work_info.xs_local ;dest is in XLI-local area + mov dx,work_info.xs_local+2 + mov work_info.xs_dest,cx + mov work_info.xs_dest+2,dx +; Copy the flonum data +do_flo20: inc si ;incr past tag + mov di,work_info.xs_dest + push ds ;tempsave DS around copy + push es + mov es,work_info.xs_dest+2 ;ES:DI points to dest + pop ds ;DS:SI is Scheme object @ + mov cx,8 + rep movsb + pop ds ;restore our DS + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_flo30 ;no, jump +; Copy pointer to data + ; near (no copy needed--data is in child's space) + mov cx,8 ;incr arg@ past copied data + jmp short do_flo32 + ; far (pointer in child points to data in XLI space) +do_flo30: sub di,8 ;back up dest @ + mov cx,di + mov dx,es + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to arg position + mov es:[bp],cx + mov es:[bp]+2,dx ;copy pointer there +; Increment arg pointer by an appropriate amount. + mov cx,4 ;incr arg@ past copied ptr +do_flo32: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_flo35 ;no, skip + mov cx,PAD_SIZE +do_flo35: add work_info.xs_args,cx +do_flo40: ret +do_floarg endp + +do_bigarg proc near + mov si,[bx].C_page ;get object's page# + %LoadPage es,si ;swap it in + mov si,[bx].C_disp ;ES:SI is Scheme object @ +; Stage the conversion to longint in XLI space. + mov bp,sp + push bx ;push VM reg@ + push work_info.xs_local ;push local buffer@ + mov work_info.C_fn,offset pgroup:int2long + call far ptr far_C + mov sp,bp + cmp ax,0 ;did bignum convert OK? + je do_big5 ;yes, jump + mov ax,XLI_ERR_BIG_TO_32_BITS ;error: bignum too big + ;to become longint + jmp xesc_err_exit +do_big5: test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_big20 ;no, jump + ; near (copy longint to child's space) + mov bp,work_info.xs_local + mov es,work_info.xs_local+2 ;ES:BP points to XLI-local longint + mov ax,es:[bp] ;move longint to regs + mov dx,es:[bp]+2 + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + mov es:[bp],ax ;copy LSBy to child + mov cx,2 + test work_info.xs_flags,FB_INT ;is 16-bit integer flag on? + jz do_big15 ;no, jump + ; is the longint small enough for an int? + cmp dx,0 ;DX should be either + ;all 0's or all 1's + je do_big32 ;we can safely truncate + xor dx,0FFFFh ;complement DX + cmp dx,0 ;try again + je do_big32 ;we can safely truncate + mov ax,XLI_ERR_BIG_TO_16_BITS ;error: bignum too big + ;to become int + jmp xesc_err_exit +do_big15: mov es:[bp]+2,dx ;copy MSBy to child + mov cx,4 + jmp short do_big32 + ; far (pointer in child points to data in XLI-local space) +do_big20: mov ax,work_info.xs_local ;move ptr to longint to regs + mov dx,work_info.xs_local+2 +; Copy either the longint or a pointer to it. + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + mov es:[bp],ax ;copy to child + mov es:[bp]+2,dx + mov cx,4 ;incr arg@ past longint + ;or pointer to longint +; Increment arg pointer by an appropriate amount. +do_big32: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_big35 ;no, skip + mov cx,PAD_SIZE +do_big35: add work_info.xs_args,cx +do_big40: ret +do_bigarg endp + +do_fixarg proc near +; Stage the conversion to int in XLI space + mov ax,[bx].C_disp ;get the fixnum data + shl ax,1 ;deal with sign bit + sar ax,1 ;AX is 16-bit signed int +; True and false are treated as the numbers 1 and 0, respectively. +; Boolean-argument processing merges into integer processing at this point. +do_log: cwd ;DX:AX is 32-bit signed int +; Copy the int data to the proper place + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP points to dest + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_fix20 ;no, jump + ; near (copy int to child's space) + mov es:[bp],ax ;copy int to child + mov cx,2 ;incr arg@ past int + test work_info.xs_flags,FB_INT ;is 16-bit integer flag on? + jnz do_fix30 ;yes, jump + mov es:[bp]+2,dx ;no, copy high order 16 bits + mov cx,4 ;incr arg@ past longint + jmp short do_fix30 + ; far (pointer in child points to data in XLI-local space) +do_fix20: mov bx,work_info.xs_local + mov [bx],ax + mov [bx]+2,dx + mov ax,work_info.xs_local ;move far ptr to int + ;or longint to child + mov cx,work_info.xs_local+2 + mov es:[bp],ax + mov es:[bp]+2,cx + mov cx,4 ;incr arg@ past ptr to int +; Increment arg pointer by an appropriate amount +do_fix30: test work_info.xs_flags,FB_PAD ;pad flag on? + jz do_fix35 ;no, skip + mov cx,PAD_SIZE +do_fix35: add work_info.xs_args,cx +do_fix40: ret +do_fixarg endp + +do_lstarg proc near ;looking for false only + cmp [bx].C_page,NIL_PAGE*2 + jne do_xxerr + mov ax,0 + jmp do_log +do_lstarg endp + +do_xxerr: jmp do_errarg ;conditional jumps + ;are too short + +do_symarg proc near ;looking for true only + cmp [bx].C_page,T_PAGE*2 + jne do_xxerr + cmp [bx].C_disp,T_DISP + jne do_xxerr + mov ax,1 + jmp do_log +do_symarg endp + +do_strarg proc near + mov si,[bx].C_page + %LoadPage es,si ;load string into memory + mov si,[bx].C_disp ;ES:SI is Scheme object @ + test work_info.xs_flags,FB_NEAR ;near flag on? + jz do_str10 ;no, jump + ; near (can't copy string because we don't have its address-- + ; put nil address into parm block) + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP is arg @ + mov word ptr es:[bp],0 + mov cx,2 + jmp short do_str60 + ; far (we can copy the string's address, but need to check + ; on earlier strings' swap status) +do_str10: + mov ax,si + add ax,STR_OVHD + mov dx,es ;DX:AX is string data @ + mov bp,work_info.xs_args + mov es,work_info.xs_args+2 ;ES:BP is arg @ + mov es:[bp],ax + mov es:[bp]+2,dx + mov cx,4 +; Increment arg pointer by an appropriate amount +do_str60: test work_info.xs_flags,FB_PAD ;padding on? + jz do_str65 ;no, jump + mov cx,PAD_SIZE +do_str65: add work_info.xs_args,cx + ret +do_strarg endp + +do_errarg proc near + mov ax,XLI_ERR_ARGN_BAD_TYPE + jmp xesc_err_exit +do_errarg endp + + subttl Code segment: Copy return value back into Scheme + page + +; On entry to all the value handler routines: +; ES:BP = pointer to return value + +do_floval proc near + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz do_flv10 ;yes, jump + ; far + mov ax,es:[bp] ;get ptr to number + mov dx,es:[bp]+2 + mov bp,ax + mov es,dx ;ES:BP points to number + ; near +do_flv10: mov dx,es:[bp]+6 ;get double in registers + mov cx,es:[bp]+4 + mov bx,es:[bp]+2 + mov ax,es:[bp] + mov bp,sp ;get BP set for C call + push dx ;push double + push cx + push bx + push ax + mov bx,work_info.xs_rvreg ;push return value VM reg@ + lea bx,regs[bx] +; lea bx,reg1 ;temporary + push bx + mov work_info.C_fn,offset pgroup:alloc_fl + call far ptr far_C ;C double -> PCS flonum + mov sp,bp ;pop C args + ret +do_floval endp + +do_TFval proc near + mov cx,0 + mov ax,es:[bp] ;get value + or ax,es:[bp]+2 ;all bytes must = 0 to be nil + or ax,es:[bp]+4 + or ax,es:[bp]+6 + jz do_TF10 ;yes (false object) + mov ax,T_DISP ;no (true object) + mov cx,T_PAGE*2 +do_TF10: + mov bx,work_info.xs_rvreg ;push return value VM reg@ + lea bx,regs[bx] +; lea bx,reg1 ;temporary + mov [bx].C_disp,ax + mov [bx].C_page,cx + ret +do_TFval endp + +do_intval proc near + test work_info.xs_flags,FB_NEAR ;near flag on? + jnz do_int10 ;yes, jump + ; far + mov ax,es:[bp] ;get ptr to number + mov dx,es:[bp]+2 + mov bp,ax + mov es,dx ;ES:BP points to number + ; near +do_int10: mov ax,es:[bp] ;get number + mov dx,es:[bp]+2 + test work_info.xs_flags,FB_INT ;16-bit integer flag on? + jz do_int20 ;no, jump + cwd ;yes, propagate sign +do_int20: mov bp,sp ;get BP set for C call + push dx ;push longint + push ax + mov bx,work_info.xs_rvreg ;push return value VM reg@ + lea bx,regs[bx] +; lea bx,reg1 ;temporary + push bx + mov work_info.C_fn,offset pgroup:long2int + call far ptr far_C ;C longint -> PCS integer + ;(bignum or fixnum) + mov sp,bp ;pop C args + ret +do_intval endp + +do_strval proc near +; allocate the space for the return value string object + mov di,2 ;DI=offset of length in + ;return value field (near) + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz do_stv10 ;yes, jump + mov di,4 ;different offset for far +do_stv10: mov cx,es:[bp][di] ;get string's length + mov bx,16380 ;BX is max string length + cmp cx,bx ;is CX short enough? + jbe do_stv15 ;yes, jump + mov cx,bx ;no, truncate at max +do_stv15: push cx ;tempsave length + mov bp,sp ;get BP set for C call + push cx ;push length + mov ax,STRTYPE + push ax ;push type + mov bx,work_info.xs_rvreg + lea bx,regs[bx] + push bx ;push return value VM reg @ + mov work_info.C_fn,offset pgroup:alloc_bl + call far ptr far_C ;allocate string object; + ;"alloc_block" takes care + ;of overhead matters + mov sp,bp ;pop C args + pop cx ;restore length + mov bx,work_info.xs_rvreg + lea bx,regs[bx] ;BX is return value VM reg @ + mov di,[bx].C_disp + mov es,[bx].C_page + %LoadPage es,es ;ES:DI is dest object @ + add di,3 ;skip past string's overhead +; copy string data into string object + push es ;tempsave ES + mov si,work_info.xs_rvptr + mov es,work_info.xs_rvptr+2 ;ES:SI points to return value + ;field in parameter block + mov ax,es:[si] + mov dx,work_info.xs_pb_segment ;DX:AX is src string @ (near) + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz do_stv50 ;yes, jump + mov dx,es:[si]+2 ;DX:AX is src string @ (far) +do_stv50: pop es ;restore ES + push ds ;tempsave our DS + mov si,ax ;ES:DI is dest string @ + mov ds,dx ;DS:SI is src string @ + rep movsb ;copy string + pop ds ;restore our DS + ret +do_strval endp + +do_errval proc near + mov ax,XLI_ERR_VALUE_BAD_TYPE + jmp xesc_err_exit +do_errval endp + + subttl Code segment: Special Services + page + +; On entry, ES:BP is parm block pointer. + +ssr proc near + mov bx,es:[bp].pb_ss ;get dispatch number + cmp bx,SS_SWAP + je ss1 + jne ss_exit ;note we don't fall thru + +ss_normal_exit: + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table[bx]+2 + mov es:[bp].pb_ss,0 ;clear ss field for normal exit +ss_exit: ret + +; the conditional jumps can't jump far enough, hence this table +ss1: jmp ssr_swap + +; "Swap" special service + +ssr_swap: mov bx,es:[bp].pb_ss_args ;get arg# + mov cx,es:[bp].pb_ss_args+2 ;get dest. length + shl bx,1 + shl bx,1 + push bx ;tempsave index into swap table + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz ss_10 ;yes, jump + ; + ; Far ------------------- + ; + ; ss_args+0: swap table index corr. to arg# (already in BX) + ; + ; ss returns: + ; in ss_args+0: true length of string + ; in pb args: far @ to string + ; + mov bx,word ptr swap_table[bx].sw_reg ;BX is reg# x 4 + lea bx,regs[bx] ;BX is reg@ + mov si,[bx].C_page ;get object's page# + %LoadPage es,si ;load object into memory + mov si,[bx].C_disp ;ES:SI is string object @ + inc si ;skip over tag + mov ax,es:[si] ;get string's length + inc si ;skip over length + inc si + cmp ax,0 ;a short string? + jge ss_5 ;no, jump + add ax,str_ovhd*2 ;yes +ss_5: sub ax,str_ovhd ;subtract off overhead + mov di,es ;DI:SI is string data @ + mov es,work_info.xs_pb_segment ;ES:BP is parameter block @ + mov es:[bp].pb_ss_args,ax ;put string length in ss_args + pop bx ;restore swap table index + mov bp,word ptr swap_table[bx].sw_offset ;ES:BP points to this arg's + ;location in parameter block + mov es:[bp],si ;put far @ in parm block + mov es:[bp]+2,di + jmp ss_normal_exit + ; + ; Near ------------------- + ; + ; ss_args+0: swap table index corr. to arg# (already in BX) + ; +2: length (already in CX) + ; +4: near ptr + ; + ; ss returns: + ; in ss_args+0: length used in copying + ; in pb args: near @ to string + ; +ss_10: mov ax,es:[bp].pb_ss_args+4 ;get dest @ + mov work_info.xs_dest,ax + mov ax,work_info.xs_pb_segment + mov work_info.xs_dest+2,ax + mov bx,word ptr swap_table[bx].sw_reg ;get reg# x 4 corr. to arg + lea bx,regs[bx] ;BX is reg@ + mov si,[bx].C_page + %LoadPage es,si ;load object into memory + mov si,[bx].C_disp ;ES:SI is string object @ + inc si ;skip over tag + mov ax,es:[si] ;get string's length + inc si ;skip over length + inc si + cmp ax,0 ;a short string? + jge ss_15 ;no, jump + add ax,str_ovhd*2 ;yes +ss_15: sub ax,str_ovhd ;subtract off overhead + cmp ax,cx ;string len >= buffer len? + jae ss_20 ;yes, jump + mov cx,ax ;CX is #chars to copy +ss_20: push ds ;tempsave our DS + push es + mov di,work_info.xs_dest + mov es,work_info.xs_dest+2 ;ES:DI is dest @ + pop ds ;DS:SI is src @ + rep movsb ;copy string + pop ds ;restore our DS + load_index pb_table + mov bp,word ptr pb_table[bx] + mov es,word ptr pb_table[bx]+2 ;ES:BP is parm block @ + mov es:[bp].pb_ss_args,ax ;put #chars copied in ss_args + pop bx ;restore swap table index + mov bp,word ptr swap_table[bx].sw_offset ;ES:BP points to this arg's + ;location in parameter block + mov ax,work_info.xs_dest + mov es:[bp],ax ;put near @ in parm block + jmp ss_normal_exit + +ssr endp + + subttl Code segment: update_swap_table + page + +update_swap_table proc near +; for small models, PCS may indeed be swapping, but we don't care, as data +; is copied to the external program on its first reference and +; remains always available to the program since the pointer in the parm block +; points into the program's own space, not PCS's + test work_info.xs_flags,FB_NEAR ;is near flag on? + jnz ust_exit ;yes, exit + mov cx,0 ;CX is argument counter +ust_10: cmp cx,work_info.xs_nargs + jge ust_exit + mov bx,cx + shl bx,1 + shl bx,1 ;BX is swap table index + push bx ;tempsave index + mov bx,word ptr swap_table[bx].sw_reg ;get reg# x 4 of argument + lea bx,regs[bx] ;BX is reg@ + mov di,[bx].C_page ;get object's page# + mov di,ptype[di] ;then its type + cmp di,STRTYPE*2 ;is it a string? + je ust_40 ;yes, jump + pop bx ;no, discard index +ust_30: inc cx ;incr to next argument + jmp ust_10 +ust_40: mov ax,[bx].C_page ;get page# + mov bp,sp ;set up BP for calling C + push ax ;push page# + mov work_info.C_fn,offset pgroup:getbase ;this routine's not in + ;C but does use its calling + ;conventions + call far ptr far_C + mov sp,bp ;pop C args + pop bx ;restore swap table index + ; If carry is clear, the argument is in memory already. + ; The address in the parm block should be OK since an object + ; coming into memory has its address updated at the time of the + ; swap. Swapping does not cause a GC, so GC's shouldn't relocate + ; an address. That leaves zeroing the addresses of objects + ; that were swapped out. + jnc ust_30 ;object's in memory, jump + ; Carry set means object is swapped out. Zero the argument's + ; pointer in the parm block. + mov bp,word ptr swap_table[bx].sw_offset + mov es,work_info.xs_pb_segment ;ES:BP points to this arg's + ;location in the parm block + mov word ptr es:[bp],0 ;zero offset part of pointer + mov word ptr es:[bp]+2,0 ;zero segment part of pointer + jmp ust_30 +; +ust_exit: ret + +update_swap_table endp + + + subttl Code segment: unload_exe + page + +; Given active_exe, release it from memory and make its spot available again. +unload_exe proc near + load_index state_table + mov es,word ptr state_table[bx].st_ss + mov bp,word ptr state_table[bx].st_sp ;ES:BP is child's SS:SP + mov es:[bp].cs_psp,0 ;set PSP@ to 0, our signal + ;to child to wrap things up + call_child 2 ;call child one last time +normal1: ret +unload_exe endp + + + subttl Code segment: unload_all + page + +; This routine is called during PCS termination. It notifies each +; child to do any wrapup, then the child will do its final call to us, +; where we release it. + +unload_all proc near + mov active_exe,0 +ua_10: cmp active_exe,N_EXE ;looked at all entries? + je ua_exit ;yes, jump + load_index status_table + mov bx,status_table[bx] + cmp bh,EXE_NONE ;is slot empty? + jne ua_20 ;no, jump +ua_15: inc active_exe ;incr to next entry + jmp ua_10 +ua_20: call unload_exe ;deallocate entry + jmp ua_15 +ua_exit: ret +unload_all endp + + subttl Code segment: table_search + page + +; We need to find a matching string. From it we'll know +; which child has it and what value it maps to. +; On entrance: +; work_area.srch_sptr is the seg:offset of the Scheme string (data proper) +; work_area.slen is the string's length +; On exit: +; if success: AX = selector value +; active_exe = xxnnh, where n is the child +; carry clear +; if fail: carry set +; AX..DI,ES,BP are destroyed. + +table_search proc near + cld ;to be safe + mov work_area.srch_exe,0 +ts_10: cmp work_area.srch_exe,N_EXE ;looked at them all? + jne ts_15 ;no, jump +; No child had a match. Return with carry set. + stc + jmp ts_exit +ts_15: mov bx,work_area.srch_exe + mov active_exe,bx + load_index status_table + mov ax,status_table[bx] + cmp ah,0 ;is this an open spot? + jne ts_20 ;no, jump +ts_next: inc work_area.srch_exe ;increment to next spot + jmp short ts_10 +; We have a loaded file. Figure out where its lookup table is. +ts_20: load_index fb_table + mov bp,word ptr fb_table[bx] + mov es,word ptr fb_table+2[bx] ;ES:BP is file block @ + mov ax,es:[bp].fb_lut + mov dx,es:[bp].fb_lut+2 + mov di,ax + mov es,dx ;ES:DI is lookup table @ + mov ah,0 ;AH will be selector value + mov al,'/' ;AL is name delimiter +; Find the next name in the lookup table. +ts_30: cmp byte ptr es:[di],al ;looking at last delimiter? + je ts_next ;yes, jump + mov si,di ;SI points at current name + mov cx,0FFh + repne scasb ;look for name delimiter + jcxz ts_next ;jump, should've found it by now + mov dx,di ;DI, DX point at next name + mov cx,di + sub cx,si + dec cx ;CX is length of name in table + cmp work_area.srch_slen,cx ;are lengths equal? + jne ts_40 ;no, jump +; We matched lengths. See if the strings themselves match. + mov di,si ;get current name @ back in DI + push ds ;tempsave our DS + mov si,work_area.srch_sptr + mov ds,work_area.srch_sptr+2 ;DS:SI is Scheme string @ + repe cmpsb + pop ds ;restore our DS + je ts_match ;jump if match +; The current table name didn't match. +ts_40: inc ah ;increment selector value + mov di,dx ;restore next name @ to DI + jmp ts_30 +; We matched. Active_exe has child#, replace it with the corr. status value. +; Calculate the selector value (0-based) of the name and return it in AX. +; Clear carry. +ts_match: mov al,ah + xor ah,ah + load_index status_table + mov bx,status_table[bx] + mov active_exe,bx + clc +ts_exit: ret +table_search endp + + subttl Code segment: find_open_spot + page + +; Find an open spot in the load_table. Clear carry and set the LSBy of +; active_exe with the child# if we succeeded, else set carry. +find_open_spot proc near + push bx + push cx + mov cx,N_EXE + mov bx,0 +fi_loop: cmp byte ptr status_table[bx]+1,EXE_NONE + je fi_found + inc bx + inc bx + dec cx + cmp cx,0 + jne fi_loop + stc ;set carry if no available entries + jmp short fi_exit +fi_found: mov bx,N_EXE + sub bx,cx + mov active_exe,bx + clc ;an open entry: clear carry, set active_exe +fi_exit: pop cx + pop bx + ret +find_open_spot endp + + subttl Far/near linkage to XLI + page + +; Near linkage + +; All other routines in this file are accessed through this one. +; On entry, BX contains an index into a jump table of routines to execute. +%xli_gate proc far + shl bx,1 ;get index on word boundary + mov gate_sp,sp + sub gate_sp,2 +; We adjusted the SP for the return address which the call in the next +; instruction will put on the stack. +; Error recovery by nested routines is done by restoring this SP value and +; then returning, which will bring them back to just after the call. + call cs:gate[bx] + ret + +; jump table +gate dw load_all,xesc,unload_all + +%xli_gate endp + + subttl Debugging XLI from PCS + page + +; If PCS is run under DEBUG, executing (%xli-debug <0 or 1>) will +; execute the following code, which either installs an INT 3 (=1) or NOPs (=0). +; When INT 3 is executed, DEBUG is called. This provides a way for +; writers of external routines to get a hook at execution time into +; their code for debugging. Also, the value returned in AX is the PROGX offset +; of the jumps accessed from the external program. + +; Registers destroyed: AX + +%xlidbg proc far + or ax,ax + jz dbgoff + mov al,cs:dbgint ;install INT 3 instruction + mov xlidbg1,al + mov al,cs:dbgint+1 + mov xlidbg1+1,al + jmp short dbgexit +dbgoff: mov al,cs:dbgnop ;install 2 NOP instructions + mov xlidbg1,al + mov xlidbg1+1,al +dbgexit: mov ax,offset biddbg ;return address of jump table + ;following EXEC of child + ret + +; data for above routine +dbgint label byte + int 3 ;INT 3 instruction +dbgnop label byte + nop ;NOP instruction + +%xlidbg endp + +progx ends + + +; Far linkage *to* XLI + +prog segment byte public 'PROG' + assume cs:pgroup + + public xli_init,xli_xesc,xli_term + +; We preserve DS,ES,BP. AX..DI are destroyed. +xli_init proc near + mov bx,0 +xli_10: push bp ;we use ES:BP a lot + push es + call %xli_gate ;cross over into PROGX segment + pop es + pop bp + ret +xli_xesc: mov bx,1 + jmp xli_10 +xli_term: mov bx,2 + jmp xli_10 +xli_init endp + +; Far linkage *from* XLI +; (all the memory allocation routines are written in C). +; The caller of this should have set BP from SP before pushing the C args, +; then restore SP from BP afterwards to remove them from the stack. +; We don't preserve ES across the call. + +far_C proc far + push ds ;C likes ES=DS + pop es + pop work_info.C_retadr ;get far @ off stack so C sees its args + pop work_info.C_retadr+2 + call [work_info.C_fn] + push work_info.C_retadr+2 + push work_info.C_retadr + ret ;C returns with return value in AX..DX +far_C endp + +; Far linkage to XLI debug hook + +; stack: +; saved BP +; return address (near call) +; arg (0=turn off, 1=turn on debug) + +; AX,BX returns PROGX offset of the jump table following the EXEC of the child. +; This should be the same offset value as in the DOS terminate address vector +; in the child's PSP. + + public xlidbg + +xlidbg proc near + push bp + mov bp,sp ;after this instruction, stack matches comments + mov ax,[bp]+4 + call %xlidbg + pop bp + ret +xlidbg endp + +prog ends + end + \ No newline at end of file diff --git a/xli.equ b/xli.equ new file mode 100644 index 0000000..cab7cdf --- /dev/null +++ b/xli.equ @@ -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 + + + \ No newline at end of file diff --git a/xli.mac b/xli.mac new file mode 100644 index 0000000..1f57ab3 --- /dev/null +++ b/xli.mac @@ -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 ;;ax + ifidn , + else + mov ax,rax + endif + endif + ifnb ;;bx + ifidn , + else + mov bx,rbx + endif + endif + ifnb ;;cx + ifidn , + else + mov cx,rcx + endif + endif + ifnb ;;dx + ifidn , + else + mov dx,rdx + endif + endif + ifnb ;;es + ifidn , + push ds + pop es + else + ifidn , + else + mov es,res + endif + endif + endif + ifnb ;;ds + ifidn , + push es + pop ds + else + ifidn , + 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 , + xor bh,bh + endif + ifidn ,
+ shl bx,1 ;; 2 bytes/entry + endif + ifidn ,
+ shl bx,1 ;; 4 + shl bx,1 + endif + ifidn ,
+ shl bx,1 ;; 4 + shl bx,1 + endif + ifidn ,
+ 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 ,
+ 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 + \ No newline at end of file diff --git a/xli_pro.mac b/xli_pro.mac new file mode 100644 index 0000000..720d451 --- /dev/null +++ b/xli_pro.mac @@ -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, + numbytes = numbytes + 2 + push x + endm +IFNB + 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 +IFE direction + add di,cx +ELSE + sub di,cx +ENDIF +ENDIF +IFNB + 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 + 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 +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, + numbytes = numbytes + 2 + endm +IFNB + les di,dword ptr ss:&realaddr +ENDIF + mov cx,numbytes + sub sp,cx + mov si,sp + move_from_real_buf + irp x, + 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 + 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 + 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 \ No newline at end of file diff --git a/zio.asm b/zio.asm new file mode 100644 index 0000000..024557e --- /dev/null +++ b/zio.asm @@ -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 + \ No newline at end of file