Return-Path: ogicse!mntgfx!dad.MENTOR.COM!lisch Received: by jove.pa.dec.com; id AA25422; Thu, 19 Jul 90 21:59:16 -0700 Received: by decwrl.dec.com; id AA27373; Wed, 18 Jul 90 21:07:19 -0700 Received: by cse.ogi.edu (5.61+eap+OGI_1.1.named/IDA-1.2.8+OGI_1.12) id AA25902; Wed, 18 Jul 90 20:34:57 -0700 Received: by pdx.MENTOR.COM ( 5.52 (84)/smail2.5/09-24-87/Mentor) id AA22639; Wed, 18 Jul 90 14:39:43 PDT Received: by dad.MENTOR.COM ( 5.52 (84)/smail2.5/09-24-87/Mentor) id AA07093; Wed, 18 Jul 90 12:52:37 PDT Date: Wed, 18 Jul 90 12:52:37 PDT From: ogicse!dad.MENTOR.COM!lisch (Ray Lischner) Message-Id: <9007181952.AA07093@dad.MENTOR.COM> To: ogicse!decwrl.dec.com!bartlett Subject: Scheme->C diffs for Apollo Here are the final diffs for the Apollo port of Scheme->C. We are using Domain/OS SR10.2 on Apollo 3x00 and 4x00 series workstations, and on Apollo Prisms (DN10000). The [34]x00 series are called "APOLLO" and the 10000 is called "PRISM" in the top level makefile. Arithmetic is fully supported for APOLLO and for PRISM. I tried to keep the changes generally useful, especially the big endian vs. little endian changes. The Apollo-specific changes are all surrounded by #ifdef-#endif; some of the APOLLO and PRISM changes are identical, so they are demarcated by "#if defined(APOLLO) || defined(PRISM)". An assembler is needed for APOLLO and for PRISM, but an assembler is not part of the standard Apollo release. Therefore, I include compressed, uuencoded object files, apollo.o and prism.o, in the shell archive, below. Thank you for making Scheme->C available, and for making it so easy to port, even to difficult systems like the Apollo. Ray Lischner UUCP: {uunet,apollo,decwrl}!mntgfx!lisch ---- Cut Here and unpack ---- #!/bin/sh # This is a shell archive (shar 3.32) # made 07/18/1990 19:49 UTC by lisch@mntgfx.uucp # Source directory //jelliott/local_user/gnu.src.proj/dec-scheme # # existing files WILL be overwritten # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 61965 -rwxr-xr-x apollo.diffs # 2958 -rwxr-xr-x apollo.o # 3554 -rwxr-xr-x prism.o # if touch 2>&1 | fgrep 'amc' > /dev/null then TOUCH=touch else TOUCH=true fi # ============= apollo.diffs ============== echo "x - extracting apollo.diffs (Text)" sed 's/^X//' << 'SHAR_EOF' > apollo.diffs && X*** ./APOLLO.orig Fri Mar 16 10:50:31 1990 X--- ./APOLLO Thu Apr 26 11:55:40 1990 X*************** X*** 0 **** X--- 1,37 ---- X+ # X+ # This is the header file for constructing make files for Apollo 3000 X+ # series processors (DN3000, DN3500, DN4000, DN4500). X+ # X+ X+ .SUFFIXES: X+ .SUFFIXES: .o .c .sc .s .asm .bin X+ X+ # Processor name: X+ X+ cpu = APOLLO X+ X+ # Default flags to use when invoking the C compiler. X+ X+ OPT = -O X+ CFLAGS = $(OPT) -A cpu,3000 -A sys,bsd4.3 X+ CC = cc X+ X+ # Assembly language object files. X+ X+ Aruntime = apollo.o X+ X+ # This is the assembler we have at Mentor Graphics. If you have a different X+ # one, then put its name here. If you don't have an assembler, then you X+ # must use the supplied apollo.o file. X+ ASM = /user/mentor/com/asm X+ AFLAGS = -nl -dba X+ X+ # Profiled library X+ X+ Plib = libsc_p.a X+ X+ # Heap size in megabytes for the compiler. X+ X+ scheapmb = 8 -scl 40 X+ X+ # End of APOLLO header. X*** ./PRISM.orig Tue May 1 14:32:14 1990 X--- ./PRISM Tue May 1 12:48:36 1990 X*************** X*** 0 **** X--- 1,37 ---- X+ # X+ # This is the header file for constructing make files for Apollo 10000 X+ # series processors. X+ # X+ X+ .SUFFIXES: X+ .SUFFIXES: .o .c .sc .s .asm .bin X+ X+ # Processor name: X+ X+ cpu = PRISM X+ X+ # Default flags to use when invoking the C compiler. X+ X+ OPT = -O X+ CFLAGS = $(OPT) -A cpu,a88k -A sys,bsd4.3 X+ CC = cc X+ X+ # Assembly language object files. X+ X+ Aruntime = prism.o X+ X+ # This is the assembler we have at Mentor Graphics. If you have a different X+ # one, then put its name here. If you don't have an assembler, then you X+ # must use the supplied prism.o file. X+ ASM = /user/mentor/com/prasm X+ AFLAGS = -dba X+ X+ # Profiled library X+ X+ Plib = X+ X+ # Heap size in megabytes for the compiler. X+ X+ scheapmb = 8 -scl 40 X+ X+ # End of PRISM header. X*** ./makefile.orig Thu Sep 14 19:44:47 1989 X--- ./makefile Fri Mar 2 10:20:41 1990 X*************** X*** 3,8 **** X--- 3,9 ---- X # X X SRCDIR = /wrl/Gen/src/schemetoc X+ SRCDIR = /user/gnu/src/dec-scheme X X MIPSDIR = /wrl/pmax/src/schemetoc X MIPSBIN = /wrl/pmax/bin X*************** X*** 16,25 **** X--- 17,37 ---- X VAXBIN = /wrl/vax/bin X VAXLIB = /wrl/vax/lib X X+ APOLLODIR = $(SRCDIR)/obj.m68k X+ APOLLOBIN = /user/gnu/bin.m68k X+ APOLLOLIB = /user/gnu/lib.m68k X X+ PRISMDIR = $(SRCDIR)/obj.a88k X+ PRISMBIN = /user/gnu/bin.a88k X+ PRISMLIB = /user/gnu/lib.a88k X+ X # Architecture specific directories and links to the source files are X # constructed by the following commands which follow: X X+ no-target: X+ @echo 'Use "make for", where is one of:' X+ @echo ' APOLLO, PRISM, MIPS, VAX' X+ X forCPU: X -mkdir ${CPUDIR} X cp ${CPU} ${CPUDIR} X*************** X*** 64,141 **** X -cd ${CPUDIR}/test; make srclinks X X forMIPS: X! make "CPU = MIPS" "CPUDIR = ${MIPSDIR}" \ X "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU X X forTITAN: X! make "CPU = TITAN" "CPUDIR = ${TITANDIR}" \ X "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU X X forVAX: X! make "CPU = VAX" "CPUDIR = ${VAXDIR}" \ X "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU X X # The Scheme->C system is initially compiled from the C sources by the X # following: X X port: X! cd scrt; make port X! cd scsc; make port X X # A "private" working copy of the current compiler, libary, and interpreter X # is installed in a directory by the following command: X X install-private: X! cd scrt; make "destdir = ${destdir}" install-private X! cd scsc; make "destdir = ${destdir}" install-private X X # Clean out working files. X X clean: X rm -f *.BAK *.CKP SC-TO-C* X! cd doc; make clean X! cd scrt; make clean X! cd scsc; make clean X! cd test; make clean X X # Clean up C source files generated from Scheme source. X X clean-sc-to-c: X! cd scrt; make clean-sc-to-c X! cd scsc; make clean-sc-to-c X! cd test; make clean-sc-to-c X X # Delete programs and libraries. X X noprogs: X! cd scrt; make noprogs X! cd scsc; make noprogs X! cd test; make noprogs X X # All binaries and documentation files are installed by the following command X # for access by all users. X X install: X! cd doc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install X! cd scrt; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install X! cd scsc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install X X # All files which must be constructed are made by the following command: X X all: X! cd scrt; make all X! cd scsc; make all X X # Distribute "source" files required to make the Scheme->C system. X X srcdist: X rdist -c MIPS README TITAN VAX makefile ${destdir} X! cd doc; make "destdir = ${destdir}/doc" srcdist X! -cd scbenchmark; make "destdir = ${destdir}/scbenchmark" srcdist X! cd scrt; make "destdir = ${destdir}/scrt" srcdist X! cd scsc; make "destdir = ${destdir}/scsc" srcdist X! -cd test; make "destdir = ${destdir}/test" srcdist X! -cd tools; make "destdir = ${destdir}/tools" srcdist X X # Distribute "binary" files so that they may be installed on some other X # system. X--- 76,162 ---- X -cd ${CPUDIR}/test; make srclinks X X forMIPS: X! $(MAKE) "CPU = MIPS" "CPUDIR = ${MIPSDIR}" \ X "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU X X forTITAN: X! $(MAKE) "CPU = TITAN" "CPUDIR = ${TITANDIR}" \ X "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU X X forVAX: X! $(MAKE) "CPU = VAX" "CPUDIR = ${VAXDIR}" \ X "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU X X+ forAPOLLO: X+ $(MAKE) "CPU = APOLLO" "CPUDIR = ${APOLLODIR}" \ X+ "BINDIR = ${APOLLOBIN}" "LIBDIR = ${a68KLIB}" forCPU X+ cd $(APOLLODIR)/scrt; ln -s $(SRCDIR)/mul-fix.perl mul-fix.perl X+ X+ forPRISM: X+ $(MAKE) "CPU = PRISM" "CPUDIR = ${PRISMDIR}" \ X+ "BINDIR = ${PRISMBIN}" "LIBDIR = ${PRISMLIB}" forCPU X+ X # The Scheme->C system is initially compiled from the C sources by the X # following: X X port: X! cd scrt; $(MAKE) port X! cd scsc; $(MAKE) port X X # A "private" working copy of the current compiler, libary, and interpreter X # is installed in a directory by the following command: X X install-private: X! cd scrt; $(MAKE) "destdir = ${destdir}" install-private X! cd scsc; $(MAKE) "destdir = ${destdir}" install-private X X # Clean out working files. X X clean: X rm -f *.BAK *.CKP SC-TO-C* X! cd doc; $(MAKE) clean X! cd scrt; $(MAKE) clean X! cd scsc; $(MAKE) clean X! cd test; $(MAKE) clean X X # Clean up C source files generated from Scheme source. X X clean-sc-to-c: X! cd scrt; $(MAKE) clean-sc-to-c X! cd scsc; $(MAKE) clean-sc-to-c X! cd test; $(MAKE) clean-sc-to-c X X # Delete programs and libraries. X X noprogs: X! cd scrt; $(MAKE) noprogs X! cd scsc; $(MAKE) noprogs X! cd test; $(MAKE) noprogs X X # All binaries and documentation files are installed by the following command X # for access by all users. X X install: X! cd doc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install X! cd scrt; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install X! cd scsc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install X X # All files which must be constructed are made by the following command: X X all: X! cd scrt; $(MAKE) all X! cd scsc; $(MAKE) all X X # Distribute "source" files required to make the Scheme->C system. X X srcdist: X rdist -c MIPS README TITAN VAX makefile ${destdir} X! cd doc; $(MAKE) "destdir = ${destdir}/doc" srcdist X! -cd scbenchmark; $(MAKE) "destdir = ${destdir}/scbenchmark" srcdist X! cd scrt; $(MAKE) "destdir = ${destdir}/scrt" srcdist X! cd scsc; $(MAKE) "destdir = ${destdir}/scsc" srcdist X! -cd test; $(MAKE) "destdir = ${destdir}/test" srcdist X! -cd tools; $(MAKE) "destdir = ${destdir}/tools" srcdist X X # Distribute "binary" files so that they may be installed on some other X # system. X*************** X*** 142,150 **** X X bindist: X rdist -c MIPS README TITAN VAX makefile ${destdir} X! cd doc; make "destdir = ${destdir}/doc" bindist X! cd scrt; make "destdir = ${destdir}/scrt" bindist X! cd scsc; make "destdir = ${destdir}/scsc" bindist X X # Write the tar tape for distribution. X X--- 163,171 ---- X X bindist: X rdist -c MIPS README TITAN VAX makefile ${destdir} X! cd doc; $(MAKE) "destdir = ${destdir}/doc" bindist X! cd scrt; $(MAKE) "destdir = ${destdir}/scrt" bindist X! cd scsc; $(MAKE) "destdir = ${destdir}/scsc" bindist X X # Write the tar tape for distribution. X X*** ./scrt/apollo.asm.orig Fri Mar 2 09:18:15 1990 X--- ./scrt/apollo.asm Thu Apr 26 17:32:48 1990 X*************** X*** 0 **** X--- 1,229 ---- X+ * apollo.asm - Apollo specific module for DEC's Scheme->C X+ * X+ * This file implements the assembly language part of the Apollo port, X+ * specifically for the DN3000 and DN4000 series, that is, depending on X+ * the M68020 CPU and M68881 FPP. X+ * X+ * Included are all the necessary math routines to catch integer overflow. X+ * X+ * This file is written for PIC (Position Independent Code), to build X+ * a shared library. X+ * X+ * Ray Lischner (uunet!mntgfx!lisch) X+ * 26 April 1990 X+ X+ module sc_apollo X+ cpu 68020,68881 X+ sri 68020 X+ X+ entry sc_setregs X+ entry sc_regs X+ entry sc_iplus X+ entry sc_idifference X+ entry sc_inegate X+ entry sc_itimes X+ X+ data X+ X+ * set up jump tables for calling PIC routines X+ data_start equ * X+ X+ sc_iplus lea data_start,a0 X+ jmp.l sc$iplus X+ sc_idifference lea data_start,a0 X+ jmp.l sc$idifference X+ sc_inegate lea data_start,a0 X+ jmp.l sc$inegate X+ sc_itimes lea data_start,a0 X+ jmp.l sc$itimes X+ X+ * set up transfer address for external PIC routines X+ extern sc_makefloat64 X+ sc$makefloat64 ac sc_makefloat64 X+ X+ text X+ X+ *********************************************************************** X+ * void sc_setregs(int* a6, int* a7) X+ * Apollo's longjmp() checks to see if the jump is backwards in the stack. X+ * If not, it assumes that something is wrong and ungracefully terminates X+ * the program. Since we don't want this to happen, we need to fake X+ * out Domain/OS. This is done by setting the stack pointer (a7) and X+ * frame pointer (a6) to the destination frame, thus circumventing X+ * longjmp's checks. X+ * X+ * To accomplish this takes some clever tricks. First, we need to know X+ * how the stack is layed out: X+ * X+ * (lower addresses) X+ * +----------------------------+ X+ * A7 | local storage ... | X+ * +----------------------------+ X+ * A6 | link to previous frame | X+ * +----------------------------+ X+ * | return address | X+ * +----------------------------+ X+ * | arguments pushed by caller | X+ * +----------------------------+ X+ * (higher addresses) X+ * Note that we are ignoring floating point control blocks. X+ * X+ * The caller pushes the desired values for A7 and A6. On entry to sc_setregs(), X+ * A6 points to the caller's frame, and A7 points to the return address. X+ * We can retrieve the caller's arguments by dereferencing a7: the second X+ * argument is in 8(a7), and the first is in 4(a7). We can just copy X+ * them into the registers we want, but first we need to save the return X+ * address before we lose the pointer to it. It is saved in A0, at the X+ * same time we load A6 and A7. Clever, isn't it? After getting the new X+ * register values, we know that the caller will try to pop the X+ * arguments off the stack by adding 8 to A7. We circumvent this by X+ * subtracting 8 now. X+ X+ sc_setregs procedure "sc_setregs",nocode X+ movem.l (a7),a0/a6-a7 X+ subq.l #8,a7 X+ jmp (a0) X+ X+ *********************************************************************** X+ * void sc_regs(int regs[12]) X+ * sc_regs returns the values of a1-a4, d0-d7 in the caller supplied buffer. X+ * These are the "callee" save registers that need to be examined during X+ * garbage collection. X+ X+ sc_regs procedure "sc_regs",#-4 X+ move.l 8(a6),a0 * a0 := ®s[0] X+ movem.l d0-d7/a1-a4,(a0) * save the interesting registers X+ return sc_regs X+ X+ *********************************************************************** X+ * The following routines are for doing arithmetic on tagged numbers. X+ * The input arguments are tagged integers, that is, integers shifted X+ * left by two bits. (Except for sc_itimes, where only the second X+ * argument, b, is shifted.) This makes it easier to check for overflow, X+ * but we must unshift the values before calling sc_makefloat64(). X+ * X+ * When the result of any operation overflows, the operands are converted X+ * to floating point, and the operation is repeated. The floating point X+ * result is then passed to sc_makefloat64() to produce a float object X+ * to return. X+ X+ * int sc_iplus(int a, int b) X+ * returns the integer sum, a + b, where a and b are the two X+ * integer arguments, unless integer overflow occurs, then returns X+ * (unsigned int) sc_makefloat64( (double)a + (double)b ) instead. X+ X+ sc$iplus procedure "sc_iplus",#0,a5 X+ move.l a0,a5 X+ * add the arguments X+ move.l 8(a6),d0 X+ move.l 12(a6),d1 X+ add.l d1,d0 X+ * if the operation overflows, we know to use floating point X+ bvc 1$ X+ X+ * otherwise, convert to floating point and add X+ move.l 8(a6),d0 X+ asr.l #2,d0 X+ fmove.l d0,fp0 X+ * note that d1 still contains "b" X+ asr.l #2,d1 X+ fmove.l d1,fp1 X+ fadd fp1,fp0 X+ * pass the floating point sum to sc_makefloat64 X+ fmove.d fp0,-(sp) X+ move.l sc$makefloat64,a0 X+ jsr (a0) X+ addq.l #8,sp X+ X+ 1$ return sc$iplus X+ X+ X+ * int sc_idifference(int a, int b) X+ * returns integer difference, a - b, where a and b are the two X+ * integer arguments, unless integer overflow occurs, then returns X+ * (unsigned int) sc_makefloat64( (double)a - (double)b ) instead. X+ * X+ X+ sc$idifference procedure "sc_idifference",#0,a5 X+ move.l a0,a5 X+ * subtract the arguments X+ move.l 8(a6),d0 X+ move.l 12(a6),d1 X+ sub.l d1,d0 X+ * if the operation overflows, we know to use floating point X+ bvc 1$ X+ X+ * otherwise, convert to floating point and subtract X+ move.l 8(a6),d0 X+ asr.l #2,d0 X+ fmove.l d0,fp0 X+ * note that d1 still contains "b" X+ asr.l #2,d1 X+ fmove.l d1,fp1 X+ fsub fp1,fp0 X+ * pass the floating point sum to sc_makefloat64 X+ fmove.d fp0,-(sp) X+ move.l sc$makefloat64,a0 X+ jsr (a0) X+ addq.l #8,sp X+ X+ 1$ return sc$idifference X+ X+ * int sc_inegate(int a) X+ * returns integer negation, -a, where a is the integer X+ * argument, unless integer overflow occurs, then returns X+ * (unsigned int) sc_makefloat64( -(double)a) instead. X+ * X+ X+ sc$inegate procedure "sc_inegate",#0,a5 X+ move.l a0,a5 X+ * negate the argument X+ move.l 8(a6),d0 X+ move.l d0,d1 X+ neg.l d0 X+ * if the operation overflows, we know to use floating point X+ bvc 1$ X+ X+ * otherwise, convert to floating point and negate X+ asr.l #2,d1 X+ fmove.l d1,fp1 X+ fneg fp1,fp0 X+ * pass the floating point sum to sc_makefloat64 X+ fmove.d fp0,-(sp) X+ move.l sc$makefloat64,a0 X+ jsr (a0) X+ addq.l #8,sp X+ X+ 1$ return sc$inegate X+ X+ * sc_itimes(int a, int b) X+ * returns integer procuct, a * b, where a and b are the two X+ * integer arguments, unless integer overflow occurs, then returns X+ * (unsigned int) sc_makefloat64( (double)a * (double)b ) instead. X+ * Unlike the previous arithmetic functions, only "b" has been shifted. X+ X+ sc$itimes procedure "sc_itimes",#0,a5 X+ move.l a0,a5 X+ * multiply the arguments X+ move.l 8(a6),d0 X+ move.l 12(a6),d1 X+ muls.l d1,d0 X+ X+ * if the operation overflows, we know to use floating point X+ bvc 1$ X+ X+ * otherwise, convert to floating point and multiply X+ fmove.l 8(a6),fp0 X+ * note that d1 still contains "b" X+ asr.l #2,d1 X+ fmove.l d1,fp1 X+ fmul fp1,fp0 X+ * pass the floating point sum to sc_makefloat64 X+ fmove.d fp0,-(sp) X+ move.l sc$makefloat64,a0 X+ jsr (a0) X+ addq.l #8,sp X+ X+ 1$ return sc$itimes X+ X+ end X*** ./scrt/apply.h.orig Thu Feb 22 17:46:36 1990 X--- ./scrt/apply.h Fri Mar 2 08:57:25 1990 X*************** X*** 68,73 **** X--- 68,89 ---- X of one's C compiler. */ X #endif X X+ #ifdef APOLLO X+ #define MAXARGS 25 /* Maximum number of required arguments permitted. X+ Note that this does not preclude an optional X+ argument list as an additional argument. This X+ number is typically determined by the ability X+ of one's C compiler. */ X+ #endif X+ X+ #ifdef PRISM X+ #define MAXARGS 25 /* Maximum number of required arguments permitted. X+ Note that this does not preclude an optional X+ argument list as an additional argument. This X+ number is typically determined by the ability X+ of one's C compiler. */ X+ #endif X+ X extern int sc_unknownargc; /* Data structures for sc_unknowncall */ X X extern TSCP sc_unknownproc[ 4 ]; X*** ./scrt/callcc.c.orig Thu Feb 22 17:46:51 1990 X--- ./scrt/callcc.c Tue May 1 11:47:38 1990 X*************** X*** 66,71 **** X--- 66,80 ---- X #define setjmp( x ) sc_setjmp( x ) X #endif X X+ #ifdef APOLLO X+ extern sc_setregs(int a6, int a7); X+ #endif X+ X+ #ifdef PRISM X+ #define longjmp(x, y) sc_longjmp(x, y) X+ #define setjmp(x) sc_setjmp(x) X+ #endif X+ X TSCP sc_clink; /* Pointer to inner most continuation on stack. */ X X /* Static declarations for data structures internal to the module. These X*************** X*** 97,102 **** X--- 106,115 ---- X it will restore the stack. */ X #ifdef MIPS X sc_setsp( (T_U(callcccp))->continuation.address ); X+ #endif X+ #ifdef APOLLO X+ sc_setregs( (T_U(callcccp))->continuation.savedstate[3], X+ (T_U(callcccp))->continuation.savedstate[2]); X #endif X longjmp( (T_U(callcccp))->continuation.savedstate, 1 ); X } X*** ./scrt/heap.c.orig Thu Feb 22 17:47:13 1990 X--- ./scrt/heap.c Tue May 1 14:55:28 1990 X*************** X*** 58,63 **** X--- 58,66 ---- X #ifdef VAX X extern sc_r2tor11(); X #endif X+ #ifdef APOLLO X+ extern sc_regs(); X+ #endif X X /* Forward declarations */ X X*************** X*** 326,332 **** X pp = STACKPTR; X while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); X } X! #endif TITAN X X #ifdef VAX X /* The following code is used to read the stack pointer. The register X--- 329,335 ---- X pp = STACKPTR; X while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); X } X! #endif /* TITAN */ X X #ifdef VAX X /* The following code is used to read the stack pointer. The register X*************** X*** 352,358 **** X pp = STACKPTR; X while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); X } X! #endif VAX X X #ifdef MIPS X /* The following code is used to read the stack pointer. The register X--- 355,361 ---- X pp = STACKPTR; X while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); X } X! #endif /* VAX */ X X #ifdef MIPS X /* The following code is used to read the stack pointer. The register X*************** X*** 378,384 **** X pp = STACKPTR; X while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); X } X! #endif MIPS X X X /* The size of an extended object in words is returned by the following X--- 381,428 ---- X pp = STACKPTR; X while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); X } X! #endif /* MIPS */ X! X! #ifdef APOLLO X! /* The following code is used to read the stack pointer. The register X! number is passed in to force an argument to be on the stack, which in X! turn can be used to find the address of the top of stack. X! */ X! X! int *sc_processor_register( reg ) X! int reg; X! { X! return( ® ); X! } X! X! /* All processor registers that might contain pointers are traced by the X! following procedure. X! */ X! X! static trace_stack_and_registers() X! { X! int i, a1toa4_d0tod7[12], *pp; X! X! sc_regs( a1toa4_d0tod7 ); X! pp = STACKPTR; X! while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); X! } X! #endif /* APOLLO */ X! X! #ifdef PRISM X! /* All processor registers that might contain pointers are traced by the X! following procedure. X! */ X! X! static trace_stack_and_registers() X! { X! int i, regs[12], *pp; X! X! sc_regs( regs ); X! pp = STACKPTR; X! while (pp != sc_stackbase) move_continuation_ptr( *pp++ ); X! } X! #endif /* PRISM */ X X X /* The size of an extended object in words is returned by the following X*************** X*** 1504,1511 **** X--- 1548,1559 ---- X the Scheme object with that value. X */ X X+ #ifdef PRISM X+ TSCP sc_makefloat32( float value ) X+ #else X TSCP sc_makefloat32( value ) X float value; X+ #endif X { X SCP pp; X X*************** X*** 1514,1520 **** X pp = sc_extobjp; X sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE); X sc_extobjwords = sc_extobjwords-FLOAT32SIZE; X! pp->unsi.gned = FLOAT32TAG; X } X else X pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 ); X--- 1562,1569 ---- X pp = sc_extobjp; X sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE); X sc_extobjwords = sc_extobjwords-FLOAT32SIZE; X! pp->float32.tag = FLOAT32TAG; X! pp->float32.rest = 0; X } X else X pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 ); X*************** X*** 1526,1535 **** X--- 1575,1594 ---- X /* 64-bit floating point numbers are constructed by the following function. It X is called with a 64-bit floating point value and it returns a pointer to X the Scheme object with that value. X+ X+ On the Apollo Prism, it is vital that we use a function prototype, X+ so the compiler knows that the function's argument is being passed X+ in a register. Without the prototype, the argument is read from X+ the stack. See prism.asm for examples where it is simpler to pass X+ the argument in a register. Also see objects.h for the declaration. X */ X X+ #ifdef PRISM X+ TSCP sc_makefloat64( double value ) X+ #else X TSCP sc_makefloat64( value ) X double value; X+ #endif X { X SCP pp; X X*************** X*** 1539,1545 **** X pp = sc_extobjp; X sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE); X sc_extobjwords = sc_extobjwords-FLOAT64SIZE; X! pp->unsi.gned = FLOAT64TAG; X } X else X pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 ); X--- 1598,1605 ---- X pp = sc_extobjp; X sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE); X sc_extobjwords = sc_extobjwords-FLOAT64SIZE; X! pp->float64.tag = FLOAT64TAG; X! pp->float64.rest = 0; X } X else X pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 ); X*** ./scrt/heap.h.orig Thu Feb 22 17:47:07 1990 X--- ./scrt/heap.h Thu Apr 26 12:42:36 1990 X*************** X*** 42,48 **** X--- 42,52 ---- X /* Import definitions */ X X #ifndef rusage X+ #ifdef apollo X+ #include X+ #else X #include X+ #endif X #include X #endif X X*************** X*** 318,323 **** X--- 322,336 ---- X X #ifdef VAX X #define STACKPTR sc_processor_register( 14 ) X+ #endif X+ X+ #ifdef APOLLO X+ #define STACKPTR sc_processor_register( 7 ) X+ #endif X+ X+ #ifdef PRISM X+ extern int* prism_stack_frame(void); X+ #define STACKPTR prism_stack_frame() X #endif X X /* Some objects require cleanup actions when they are freed. For example, X*** ./scrt/makefile-tail.orig Wed Apr 19 17:47:01 1989 X--- ./scrt/makefile-tail Thu Apr 26 12:05:30 1990 X*************** X*** 34,40 **** X scqquote.sc screp.sc \ X scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc X X! Smisc = GGC.c GGC.h GGCprivate.h mips.s predef.sc repdef.sc sci.sc sci.c vax.s X X ${Sruntimec} sci.c: ${predef.sc} ${objects.h} X X--- 34,40 ---- X scqquote.sc screp.sc \ X scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc X X! Smisc = GGC.c GGC.h GGCprivate.h apollo.asm prism.asm mips.s predef.sc repdef.sc sci.sc sci.c vax.s X X ${Sruntimec} sci.c: ${predef.sc} ${objects.h} X X*************** X*** 49,54 **** X--- 49,59 ---- X .c.u: X ${CC} -j -D${cpu} -I. $*.c X X+ # Apollo assembler X+ .asm.o: X+ $(ASM) $* $(AFLAGS) X+ -mv $*.bin $*.o X+ X .s.o: X ${CC} -c $*.s X X*************** X*** 69,75 **** X -lm X X GGCi: ${Sruntimec} ${Sruntime} ${Aruntime} GGC.o sci.c sci.o X! make "CFLAGS = -DGGC ${CFLAGS}" GGCheap.o GGCscinit.o X ${CC} -o GGCi ${CFLAGS} ${Sruntime} ${GGCCruntime} ${Aruntime} sci.o \ X -lXaw -lXt -lX11 -lm X X--- 74,80 ---- X -lm X X GGCi: ${Sruntimec} ${Sruntime} ${Aruntime} GGC.o sci.c sci.o X! $(MAKE) "CFLAGS = -DGGC ${CFLAGS}" GGCheap.o GGCscinit.o X ${CC} -o GGCi ${CFLAGS} ${Sruntime} ${GGCCruntime} ${Aruntime} sci.o \ X -lXaw -lXt -lX11 -lm X X*************** X*** 78,84 **** X mv Xlibsc.a libsc.a X X port: X! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \ X Xlibsc.a Xsci Xmv ${Plib} X X libsc_p.a: libsc.a X--- 83,89 ---- X mv Xlibsc.a libsc.a X X port: X! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \ X Xlibsc.a Xsci Xmv ${Plib} X X libsc_p.a: libsc.a X*************** X*** 85,91 **** X mkdir saveobj X mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj X rm -f libsc_p.a X! make "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \ X ${Aruntime} X ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime} X ranlib libsc_p.a X--- 90,96 ---- X mkdir saveobj X mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj X rm -f libsc_p.a X! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \ X ${Aruntime} X ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime} X ranlib libsc_p.a X*************** X*** 134,140 **** X libsc.a ${Plib} sci ${destdir} X X all: X! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" Xlibsc.a Xsci Xmv ${Plib} X X srclinks: X for x in ${Cruntimec} ${Chfiles} ${Sruntimec} ${Sruntimesc} ${Smisc}; \ X--- 139,145 ---- X libsc.a ${Plib} sci ${destdir} X X all: X! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" Xlibsc.a Xsci Xmv ${Plib} X X srclinks: X for x in ${Cruntimec} ${Chfiles} ${Sruntimec} ${Sruntimesc} ${Smisc}; \ X*** ./scrt/objects.c.orig Thu Feb 22 17:47:27 1990 X--- ./scrt/objects.c Tue May 1 14:49:59 1990 X*************** X*** 471,477 **** X break; X case EXTENDEDTAG: X if (TX_U( p )->extendedobj.tag == FLOATTAG) X! return( (int)( TX_U( p )->FLOATUTYPE.value ) ); X break; X } X sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 ); X--- 471,477 ---- X break; X case EXTENDEDTAG: X if (TX_U( p )->extendedobj.tag == FLOATTAG) X! return ROUND( FLOAT_VALUE( p ) ); X break; X } X sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 ); X*************** X*** 495,503 **** X if (TX_U( p )->extendedobj.tag == FLOATTAG) { X v = TX_U( p )->FLOATUTYPE.value; X if (v <= (double)(0x7fffffff)) X! return( (unsigned)( v ) ); X else X! return( (unsigned)( v-((double)(0x40000000))*2.0 ) | X 0x80000000 ); X } X break; X--- 495,503 ---- X if (TX_U( p )->extendedobj.tag == FLOATTAG) { X v = TX_U( p )->FLOATUTYPE.value; X if (v <= (double)(0x7fffffff)) X! return( (unsigned)ROUND( v ) ); X else X! return( (unsigned)ROUND( v-((double)(0x40000000))*2.0 ) | X 0x80000000 ); X } X break; X*************** X*** 529,535 **** X return( sc_procedureaddress( p ) ); X break; X case FLOATTAG: X! return( (int)s->FLOATUTYPE.value ); X break; X } X break; X--- 529,535 ---- X return( sc_procedureaddress( p ) ); X break; X case FLOATTAG: X! return( (unsigned int)s->FLOATUTYPE.value ); X break; X } X break; X*** ./scrt/objects.h.orig Thu Feb 22 17:47:22 1990 X--- ./scrt/objects.h Tue May 1 09:45:16 1990 X*************** X*** 47,52 **** X--- 47,61 ---- X #ifndef MIPS X #ifndef TITAN X #ifndef VAX X+ #ifndef APOLLO X+ #ifndef PRISM X+ #ifdef apollo X+ #ifdef _ISP_A88K X+ #define PRISM 1 X+ #else X+ #define APOLLO 1 X+ #endif X+ #endif X #ifdef mips X #define MIPS 1 X #endif X*************** X*** 59,65 **** X--- 68,83 ---- X #endif X #endif X #endif X+ #endif X+ #endif X X+ #ifdef APOLLO X+ #define BIG_ENDIAN X+ #endif X+ #ifdef PRISM X+ #define BIG_ENDIAN X+ #endif X+ X /* The Scheme->C installer may elect to have arithmetic overflow handled X gracefully on either the MIPS or the VAX implementations. The default X is to handle it. X*************** X*** 80,85 **** X--- 98,104 ---- X #ifdef TITAN X #include X #define CPUTYPE TITAN X+ #undef MATHTRAPS X #endif X X #ifdef VAX X*************** X*** 96,101 **** X--- 115,136 ---- X #define CPUTYPE VAX X #endif X X+ #ifdef APOLLO X+ #include X+ #define CPUTYPE APOLLO X+ #endif X+ X+ #ifdef PRISM X+ /* Use our own setjmp/longjmp so we can make sure all the registers X+ are saved that need to be saved, namely, .10 through .23, X+ plus the signal mask, return PC, and PSWs. X+ X+ The layout of these registers in the array is described in prism.asm. X+ */ X+ typedef int jmp_buf[18]; X+ #define CPUTYPE PRISM X+ #endif X+ X /* The data encoding scheme is similar to that used by Vax NIL and T, where X all objects are represented by 32-bit pointers, with a "low tag" encoded X in the two least significant bits encoding the type. All objects are X*************** X*** 121,126 **** X--- 156,179 ---- X TP_U( tscp ) convert Tagged Pair pointer to an Untagged SCP. X */ X X+ /* X+ Ugly, but machine independent way to declare and use bit fields: X+ Bit fields are declared using F?(...), where the least significant X+ fields are listed first (in honor of the original implementations). X+ Similarly, static objects are created with the U?(...) macros. X+ */ X+ #ifdef BIG_ENDIAN X+ #define F2(a,b) b;a X+ #define F3(a,b,c) c;b;a X+ #define U2(a,b) (b),(a) X+ #define U3(a,b,c) (c),(b),(a) X+ #else X+ #define F2(a,b) a;b X+ #define F3(a,b,c) a;b;c X+ #define U2(a,b) (a),(b) X+ #define U3(a,b,c) (a),(b),(c) X+ #endif X+ X typedef char *TSCP; X X typedef union SCOBJ { /* SCHEME to C OBJECT */ X*************** X*** 128,139 **** X unsigned gned; X } unsi; X struct { /* EXTENDEDOBJ */ X! unsigned tag:8; X! unsigned rest:24; X } extendedobj; X struct { /* SYMBOL */ X! unsigned tag:8; X! unsigned rest:24; X TSCP name; X TSCP *ptrtovalue; X TSCP value; X--- 181,192 ---- X unsigned gned; X } unsi; X struct { /* EXTENDEDOBJ */ X! F2(unsigned tag:8, X! unsigned rest:24); X } extendedobj; X struct { /* SYMBOL */ X! F2(unsigned tag:8, X! unsigned rest:24); X TSCP name; X TSCP *ptrtovalue; X TSCP value; X*************** X*** 140,170 **** X TSCP propertylist; X } symbol; X struct { /* STRING */ X! unsigned tag:8; X! unsigned length:24; X char char0; X } string; X struct { /* VECTOR */ X! unsigned tag:8; X! unsigned length:24; X TSCP element0; X } vector; X struct { /* PROCEDURE */ X! unsigned tag:8; X! unsigned required:8; X! unsigned optional:16; X TSCP (*code)(); X TSCP closure; X } procedure; X struct { /* CLOSURE */ X! unsigned tag:8; X! unsigned length:24; X TSCP closure; X TSCP var0; X } closure; X struct { /* CONTINUATION */ X! unsigned tag:8; X! unsigned length:24; X TSCP continuation; X jmp_buf savedstate; X int *address; X--- 193,223 ---- X TSCP propertylist; X } symbol; X struct { /* STRING */ X! F2(unsigned tag:8, X! unsigned length:24); X char char0; X } string; X struct { /* VECTOR */ X! F2(unsigned tag:8, X! unsigned length:24); X TSCP element0; X } vector; X struct { /* PROCEDURE */ X! F3(unsigned tag:8, X! unsigned required:8, X! unsigned optional:16); X TSCP (*code)(); X TSCP closure; X } procedure; X struct { /* CLOSURE */ X! F2(unsigned tag:8, X! unsigned length:24); X TSCP closure; X TSCP var0; X } closure; X struct { /* CONTINUATION */ X! F2(unsigned tag:8, X! unsigned length:24); X TSCP continuation; X jmp_buf savedstate; X int *address; X*************** X*** 172,189 **** X int word0; X } continuation; X struct { /* FLOAT32 */ X! unsigned tag:8; X! unsigned rest:24; X float value; X } float32; X struct { /* FLOAT64 */ X! unsigned tag:8; X! unsigned rest:24; X double value; X } float64; X struct { /* FORWARD */ X! unsigned tag:8; X! unsigned length:24; X TSCP forward; X } forward; X struct { /* PAIR */ X--- 225,242 ---- X int word0; X } continuation; X struct { /* FLOAT32 */ X! F2(unsigned tag:8, X! unsigned rest:24); X float value; X } float32; X struct { /* FLOAT64 */ X! F2(unsigned tag:8, X! unsigned rest:24); X double value; X } float64; X struct { /* FORWARD */ X! F2(unsigned tag:8, X! unsigned length:24); X TSCP forward; X } forward; X struct { /* PAIR */ X*************** X*** 214,219 **** X--- 267,276 ---- X #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) X #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) X #endif X+ #ifdef apollo X+ #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG)) X+ #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG)) X+ #endif X X /* Fixed point numbers are encoded in the address portion of the pointer. The X value is obtained by arithmetically shifting the pointer value two bits to X*************** X*** 609,615 **** X interpreted X X When the procedure is exited, sc_stacktrace is restored. X! */ X X struct STACKTRACE { /* Stack trace back record */ X unsigned prevstacktrace; X--- 666,700 ---- X interpreted X X When the procedure is exited, sc_stacktrace is restored. X! In dobacktrace(), the stack is traced by calling C-UNSIGNED-REF X! to get the prevstacktrace pointer. The problem with this is that X! C-UNSIGNED-REF (aka scrt4_c_2dunsigned_2dref) uses MUNSIGNED, which X! uses T_U, which masks out the least significant two bits of the pointer. X! The trick is to get an implementation independent method of aligning X! the stacktrace structure. Most compilers at least align the structure X! with an even address, but only some will align it on a four-byte boundary. X! X! The macro ALIGN4(t,x) declares "x" to be a pointer to "t", aligned on X! a 4-byte boundary. If nothing special needs to be done, then the default X! definition can be used. X! */ X! X! #ifdef APOLLO X! /* On an Apollo, things are usually aligned properly on the stack, X! but after an interrupt, things can get screwy, and even doubles X! can end up non-longword aligned. To be safe, we need to align X! everything on a longword boundary ourselves. X! */ X! #define IDENT(a) a X! #define CAT(a,b) IDENT(a)b X! #define ALIGN4(t,x) char CAT(x,buf)[sizeof(t) + sizeof(long)];\ X! t& x = * (t*) ((unsigned)CAT(x,buf) & ~(sizeof(long)-1)) X! #endif X! X! /* the rest of the world does not need to worry about such matters */ X! #ifndef ALIGN4 X! #define ALIGN4(t,x) t x X! #endif X X struct STACKTRACE { /* Stack trace back record */ X unsigned prevstacktrace; X*************** X*** 619,625 **** X X extern unsigned sc_stacktrace; X X! #define PUSHSTACKTRACE( procedure ) struct STACKTRACE st; \ X TSCP returntrace; \ X st.prevstacktrace = sc_stacktrace; \ X st.procname = procedure; \ X--- 704,710 ---- X X extern unsigned sc_stacktrace; X X! #define PUSHSTACKTRACE( procedure ) ALIGN4(struct STACKTRACE, st); \ X TSCP returntrace; \ X st.prevstacktrace = sc_stacktrace; \ X st.procname = procedure; \ X*************** X*** 711,716 **** X--- 796,804 ---- X #ifdef VAX X #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) X #endif X+ #ifdef apollo X+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n)))) X+ #endif X X #define PROCEDURE_REQUIRED( tscp ) (TX_U( tscp )->procedure.required) X #define PROCEDURE_OPTIONAL( tscp ) (TX_U( tscp )->procedure.optional) X*************** X*** 729,744 **** X /* C declarations */ X X #define DEFSTRING( name, chars, len ) \ X! static struct { unsigned tag:8; \ X! unsigned length:24; \ X char char0[len+(4-(len % 4))]; } \ X! name = { STRINGTAG, len, chars } X X #define DEFFLOAT( name, value ) \ X! static struct { unsigned tag:8; \ X! unsigned length: 24; \ X FLOATTYPE f; } \ X! name = { FLOATTAG, 0, value } X X #define DEFTSCP( name ) TSCP name X X--- 817,832 ---- X /* C declarations */ X X #define DEFSTRING( name, chars, len ) \ X! static struct { F2(unsigned tag:8, \ X! unsigned length:24); \ X char char0[len+(4-(len % 4))]; } \ X! name = { U2(STRINGTAG, len), chars } X X #define DEFFLOAT( name, value ) \ X! static struct { F2(unsigned tag:8, \ X! unsigned length: 24); \ X FLOATTYPE f; } \ X! name = { U2(FLOATTAG, 0), value } X X #define DEFTSCP( name ) TSCP name X X*************** X*** 833,846 **** X X /* C operators that detect integer overflow in some implementations */ X X! #if (MATHTRAPS == 0 || CPUTYPE == TITAN) X #define IPLUS( a, b ) (a + b) X #define IDIFFERENCE( a, b ) (a - b) X #define INEGATE( a ) (- a) X #define ITIMES( a, b ) (a * b) X- #endif X X! #if (MATHTRAPS && (CPUTYPE == MIPS || CPUTYPE == VAX)) X #define IPLUS( a, b ) sc_iplus( a, b ) X #define IDIFFERENCE( a, b ) sc_idifference( a, b ) X #define ITIMES( a, b ) sc_itimes( a, b ) X--- 921,934 ---- X X /* C operators that detect integer overflow in some implementations */ X X! #if !defined(MATHTRAPS) || MATHTRAPS == 0 X #define IPLUS( a, b ) (a + b) X #define IDIFFERENCE( a, b ) (a - b) X #define INEGATE( a ) (- a) X #define ITIMES( a, b ) (a * b) X X! #else X! X #define IPLUS( a, b ) sc_iplus( a, b ) X #define IDIFFERENCE( a, b ) sc_idifference( a, b ) X #define ITIMES( a, b ) sc_itimes( a, b ) X*************** X*** 871,886 **** X significant 8 bits of the extended object header. X */ X X! #define UNKNOWNCALL( proc, argc ) (sc_unknownargc = argc, \ X! sc_unknownproc[ 1 ] = proc, \ X! sc_unknownproc[ \ X! (UNSI_GNED( \ X! sc_unknownproc[ TSCPTAG( proc ) ] ) \ X! == (argc*256+PROCEDURETAG)) ]) X X /* Inline type conversions */ X X! #define FLT_FIX( flt ) C_FIXED( (int)(FLOAT_VALUE( flt )) ) X #define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) ) X #define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix ))) X #define FLTV_FLT( flt ) MAKEFLOAT( flt ) X--- 959,990 ---- X significant 8 bits of the extended object header. X */ X X! #define UNKNOWNCALL( proc, argc ) \ X! (sc_unknownargc = argc, sc_unknownproc[ 1 ] = proc, \ X! sc_unknownproc[(PROCEDURE_REQUIRED(sc_unknownproc[ TSCPTAG(proc) ]) == argc\ X! && ! PROCEDURE_OPTIONAL(sc_unknownproc[ TSCPTAG( proc )]))]) X! /* UNSI_GNED(sc_unknownproc[ TSCPTAG( proc ) ] ) \ X! == (argc*256+PROCEDURETAG)) ]) X! */ X X /* Inline type conversions */ X X! /* round a floating point number to the nearest integer */ X! #ifdef apollo X! #include X! /* Apollo SR10.2, with cc 6.7: rint() returns a bogus value (e.g., 0.9 X! is "rounded" to 0.899902). X! If Apollo does not fix rint() soon, then we should write our own. X! */ X! #define rint(x) floor((x) + 0.5) X! #define ROUND(x) ((int) rint(x)) X! #endif X! X! #ifndef ROUND X! #define ROUND(x) ((int) (x)) X! #endif X! X! #define FLT_FIX( flt ) C_FIXED( ROUND(FLOAT_VALUE( flt )) ) X #define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) ) X #define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix ))) X #define FLTV_FLT( flt ) MAKEFLOAT( flt ) X*************** X*** 929,936 **** X--- 1033,1049 ---- X definitions needed by a SCHEME->C program. X */ X X+ #ifdef PRISM X+ /* As explained in heap.c, it is important to declare the function prototype, X+ so the compiler passes the floating point argument in a register, rather X+ than on the stack. X+ */ X+ extern TSCP sc_makefloat32(float); X+ extern TSCP sc_makefloat64(double); X+ #else X extern TSCP sc_makefloat32(); X extern TSCP sc_makefloat64(); X+ #endif X extern TSCP sc_cons(); X extern int sc_unknownargc; X extern TSCP sc_unknownproc[ 4 ]; X*** ./scrt/prism.asm.orig Tue May 1 14:31:43 1990 X--- ./scrt/prism.asm Tue May 1 12:48:17 1990 X*************** X*** 0 **** X--- 1,387 ---- X+ * prism.asm - Apollo Prism (DN10000) specific module for DEC's Scheme->C X+ * X+ * This file implements the assembly language part of the Prism port, X+ * specifically for the DN10000. X+ * X+ * Included are all the necessary math routines to catch integer overflow. X+ * X+ * NOTE: Don't even try to read this file if you do not understand X+ * how an Apollo Prism (also called an AT, for Advanced Technology; X+ * perhaps Apollo thinks the Prism is as good as an IBM PC AT :-) works. X+ * I have tried to optimize the parallel operations, such as branch and X+ * call shadows, and combining integer and floating point operations. X+ * (The former are common; the latter are rare in this file.) X+ * X+ * The sematics of b.sa are completely different from b.sn, and the X+ * subtle differences are too lengthy to discuss here. Read the X+ * various Apollo manuals, such as the AT Assembler Reference and X+ * the AT Technical Reference. X+ * X+ * Apollo's setjmp/longjmp do not permit jumps to random locations in the X+ * stack, so we must write our own. On the DN3000 (M68K), we can get away X+ * with simply altering the stack and frame pointers (A6 and A7) before X+ * calling longjmp, but on the Prism this does not work because longjmp X+ * only jumps to a valid stack frame. I tried modifying call/cc to X+ * restore the stack and registers before calling longjmp(), but this X+ * does not work because it changes the data base register, which messes X+ * up the call to longjmp. The simplest solution is to reimplemen]t X+ * setjmp and longjmp. X+ * X+ * Another reason to write our own setjmp/longjmp is to make sure all X+ * the registers are saved properly. The standard jmp_buf does not have X+ * enough room to save all the needed registers. X+ * X+ * Ray Lischner (uunet!mntgfx!lisch) X+ * 1 May 1990 X+ X+ module sc_prism X+ X+ export.f prism_stack_frame X+ export.p sc_longjmp X+ export.f sc_setjmp X+ export.p sc_regs X+ export.f sc_iplus X+ export.f sc_idifference X+ export.f sc_inegate X+ export.f sc_itimes X+ X+ import.f sc_makefloat64 X+ import.f sigblock X+ import.f sigsetmask X+ X+ data X+ X+ * set up ECBs for all the functions that need one X+ data_frame equ * X+ X+ sc_setjmp procedure ok X+ .0 = sc$setjmp ; get the relocatable address of the routine X+ .1 = .sf ; save the old stack frame X+ .2 = #data_frame ; get the relocatable data frame X+ b.sa [.0] ; branch to the real routine X+ [--.sf,#16] = .1 ; push the old .SF onto the stack X+ X+ sc_longjmp procedure ok X+ .0 = sc$longjmp ; get the relocatable address of the routine X+ .1 = .sf ; save the old stack frame X+ .2 = #data_frame ; get the relocatable data frame X+ b.sa [.0] ; branch to the real routine X+ [--.sf,#16] = .1 ; push the old .SF onto the stack X+ X+ sc_idifference procedure ok X+ .0 = sc$idifference ; get the relocatable address of the routine X+ .1 = .sf ; save the old stack frame X+ .2 = #data_frame ; get the relocatable data frame X+ b.sa [.0] ; branch to the real routine X+ [--.sf,#16] = .1 ; push the old .SF onto the stack X+ X+ sc_inegate procedure ok X+ .0 = sc$inegate ; get the relocatable address of the routine X+ .1 = .sf ; save the old stack frame X+ .2 = #data_frame ; get the relocatable data frame X+ b.sa [.0] ; branch to the real routine X+ [--.sf,#16] = .1 ; push the old .SF onto the stack X+ X+ sc_iplus procedure ok X+ .0 = sc$iplus ; get the relocatable address of the routine X+ .1 = .sf ; save the old stack frame X+ .2 = #data_frame ; get the relocatable data frame X+ b.sa [.0] ; branch to the real routine X+ [--.sf,#16] = .1 ; push the old .SF onto the stack X+ X+ sc_itimes procedure ok X+ .0 = sc$itimes ; get the relocatable address of the routine X+ .1 = .sf ; save the old stack frame X+ .2 = #data_frame ; get the relocatable data frame X+ b.sa [.0] ; branch to the real routine X+ [--.sf,#16] = .1 ; push the old .SF onto the stack X+ X+ * jump table for the ECBs X+ sc$setjmp data.l sc$$setjmp X+ sc$longjmp data.l sc$$longjmp X+ sc$idifference data.l sc$$idifference X+ sc$inegate data.l sc$$inegate X+ sc$iplus data.l sc$$iplus X+ sc$itimes data.l sc$$itimes X+ X+ * relocation table for the external functions X+ sc$makefloat64 data.l sc_makefloat64 X+ sig$setmask data.l sigsetmask X+ sig$block data.l sigblock X+ proc X+ X+ *********************************************************************** X+ * int prism_stack_frame(void) X+ * Return the caller's stack frame pointer. See the STACKPTR macro X+ * in heap.h for how this is called. X+ X+ prism_stack_frame procedure ok X+ b.sa [.return] X+ .0 = .sf X+ X+ X+ *********************************************************************** X+ * int sc_setjmp(jmp_buf buf) X+ * Save the current signal mask, processor status words, and preserved X+ * registers in the caller-supplied buffer, and return zero. X+ X+ sc$$setjmp procedure name="sc_setjmp",return=save,stack=(),save=1$ X+ [.sf,4] = .4 X+ [.sf,8] = .return X+ [.sf,12] = .10 X+ .10 = .2 X+ using .10, data_frame X+ 1$ .0 = .ipsw ; and the processor status words X+ [.4++] = .0 X+ .0 = .fppsw X+ [.4++] = .0 X+ .0 = [.sf,12] ; old value of .10 X+ [.4++] = .0 X+ [.4++] = .11 X+ [.4++] = .12 X+ [.4++] = .13 X+ [.4++] = .14 X+ [.4++] = .15 X+ [.4++] = .16 X+ [.4++] = .17 X+ [.4++] = .18 X+ [.4++] = .19 X+ [.4++] = .20 X+ [.4++] = .21 X+ [.4++] = .return X+ .0 = [.sf] X+ [.4++] = .0 X+ X+ .3 = sig$block ; and the current signal mask X+ .return = call.sa [.3] ; sigblock(0) X+ .4 = .null X+ .4 = [.sf,4] X+ [.4++] = .0 X+ X+ .10 = [.sf,12] ; restore the saved registers X+ .return = [.sf,8] X+ .0 = .null X+ b.sa [.return] ; return(0) X+ .sf = [.sf] X+ X+ drop .10 X+ endp X+ X+ * void longjmp(jmp_buf buf, int rtn) X+ * Jump to the location saved by a previous call to setjmp(), such that X+ * it looks to the caller of setjmp() as though setjmp returned "rtn". X+ * If "rtn" is zero, one is returned. X+ X+ sc$$longjmp procedure name="sc_longjmp",return=save,stack=(),save=1$ X+ [.sf,8] = .return X+ using .2, data_frame X+ 1$ .cc = .5 X+ .0 = [.4++] X+ bnz.sf 2$ ; make sure the return value is non-zero X+ .5 = #1 X+ 2$ .ipsw = .0 X+ .0 = [.4++] X+ .fppsw = .0 X+ .10 = [.4++] X+ .11 = [.4++] X+ .12 = [.4++] X+ .13 = [.4++] X+ .14 = [.4++] X+ .15 = [.4++] X+ .16 = [.4++] X+ .17 = [.4++] X+ .18 = [.4++] X+ .19 = [.4++] X+ .20 = [.4++] X+ .21 = [.4++] X+ .0 = [.4++] X+ [.sf,8] = .0 ; save the return PC X+ .0 = [.4++] X+ [.sf] = .0 ; save .sf X+ [.sf,4] = .5 ; save return value X+ X+ .3 = sig$setmask ; restore the signal mask X+ .return = call.sa [.3] X+ .4 = [.4] X+ X+ .0 = [.sf,4] ; return the user-supplied "rtn" X+ .return = [.sf,8] X+ b.sa [.return] X+ .sf = [.sf] X+ endp X+ X+ *********************************************************************** X+ * void sc_regs(int regs[12]) X+ * sc_regs stores the values of .10 - .21 in the caller supplied buffer. X+ * These are the "callee" save registers that need to be examined during X+ * garbage collection. X+ X+ sc_regs procedure ok X+ [.4++] = .10 X+ [.4++] = .11 X+ [.4++] = .12 X+ [.4++] = .13 X+ [.4++] = .14 X+ [.4++] = .15 X+ [.4++] = .16 X+ [.4++] = .17 X+ [.4++] = .18 X+ [.4++] = .19 X+ [.4++] = .20 X+ b.sa [.return] X+ [.4] = .21 X+ endp X+ X+ *********************************************************************** X+ * The following routines are for doing arithmetic on tagged numbers. X+ * The input arguments are tagged integers, that is, integers shifted X+ * left by two bits. (Except for sc_itimes, where only the second X+ * argument, b, is shifted.) This makes it easier to check for overflow, X+ * but we must unshift the values before calling sc_makefloat64(). X+ * X+ * When the result of any operation overflows, the operands are converted X+ * to floating point, and the operation is repeated. The floating point X+ * result is then passed to sc_makefloat64() to produce a float object X+ * to return. X+ X+ X+ * int sc_iplus(int a, int b) X+ * returns the integer sum, a + b, where a and b are the two X+ * integer arguments, unless integer overflow occurs, then returns X+ * (unsigned int) sc_makefloat64( (double)a + (double)b ) instead. X+ X+ sc$$iplus procedure name="sc_iplus",return=save,stack=(),save=1$ X+ [.sf,8] = .return X+ * add the arguments X+ 1$ .0.cc = .4 + .5 ; try adding the arguments as integers X+ .4 = .4 SHRA #2 ; wait 1 cycle until CCs set X+ bnv.sf 2$ ; return if the integer operation worked X+ .5 = .5 SHRA #2 ; otherwise keep working X+ .fs0.i = .5 ; convert the integers to floating point X+ .fs1.i = .4 X+ .fd8 = float(.fs1.i) X+ .fd0 = float(.fs0.i) X+ * get ready to call makefloat64, while adding the operands X+ .3 = sc$makefloat64, .fd8 += .fd0 X+ .return = call.sn [.3] ; call sc_makefloat64() X+ nop X+ .return = [.sf,8] ; pop the return PC X+ X+ 2$ b.sa [.return] ; return X+ .sf = [.sf] ; restore the old .SF X+ endp X+ X+ X+ * int sc_idifference(int a, int b) X+ * returns integer difference, a - b, where a and b are the two X+ * integer arguments, unless integer overflow occurs, then returns X+ * (unsigned int) sc_makefloat64( (double)a - (double)b ) instead. X+ X+ sc$$idifference procedure ok,name="sc_idifference" X+ [.sf,8] = .return X+ * subtract the arguments X+ 1$ .0.cc = .4 - .5 ; try subtracting the arguments as integers X+ .4 = .4 SHRA #2 ; wait 1 cycle until CCs set X+ bnv.sf 2$ ; return if the integer operation worked X+ .5 = .5 SHRA #2 ; otherwise keep working X+ .fs0.i = .5 ; convert the integers to floating point X+ .fs1.i = .4 X+ .fd8 = float(.fs1.i) X+ .fd0 = float(.fs0.i) X+ * get ready to call makefloat64, while subtracting the operands X+ .3 = sc$makefloat64, .fd8 -= .fd0 X+ .return = call.sn [.3] ; call sc_makefloat64() X+ nop X+ .return = [.sf,8] ; pop the return PC X+ X+ 2$ b.sa [.return] ; return X+ .sf = [.sf] ; restore the old .SF X+ endp X+ X+ * int sc_inegate(int a) X+ * returns integer negation, -a, where a is the integer X+ * argument, unless integer overflow occurs, then returns X+ * (unsigned int) sc_makefloat64( -(double)a) instead. X+ X+ sc$$inegate procedure ok,name="sc_inegate" X+ [.sf,8] = .return X+ * negate the argument X+ 1$ .0.cc = -.4 ; try negating the argument as an integer X+ .4 = .4 SHRA #2 ; wait 1 cycle until CCs set X+ bnv.sf 2$ ; return if the integer operation worked X+ .fs0.i = .4 ; otherwise keep working X+ .fd8 = float(.fs0.i) ; convert the argument to floating point X+ * get ready to call makefloat64, while negating the argument X+ .3 = sc$makefloat64, .fd8 = -.fd8 X+ .return = call.sn [.3] ; call sc_makefloat64() X+ nop X+ .return = [.sf,8] ; pop the return PC X+ X+ 2$ b.sa [.return] ; return X+ .sf = [.sf] ; restore the old .SF X+ endp X+ X+ * sc_itimes(int a, int b) X+ * returns integer procuct, a * b, where a and b are the two X+ * integer arguments, unless integer overflow occurs, then returns X+ * (unsigned int) sc_makefloat64( (double)a * (double)b ) instead. X+ * Unlike the previous arithmetic functions, only "b" has been shifted. X+ * X+ * This is a pain on a Prism because we need to use the floating X+ * point unit for the integer multiply, and that means we cannot X+ * set the integer condition codes. Instead, we do a normal X+ * floating point multiply and explicitly check the result to see X+ * if it fits into an integer. If not, we divide by 4 to get the X+ * true result. Note that this does not affect the precision X+ * of the result. X+ X+ sc$$itimes procedure name="sc_itimes",return=save,stack=(),save=1$ X+ [.sf,8] = .return X+ 1$ .fs0.i = .4 ; load floating point registers for the X+ .fs1.i = .5 ; multiplication X+ .fd8 = float(.fs0.i) X+ .fd2 = float(.fs1.i) X+ * do the multiply; at the same time, load sc_makefloat64's address, to X+ * get ready for calling it, in case the multiply overflows X+ .3 = sc$makefloat64, .fd8 *= .fd2 X+ X+ * The floating point constants do not change, so we can put them in X+ * the shared text segment. Change the address base to .PC, so we X+ * use PC-relative addressing. X+ drop .2 X+ X+ * look for overflow by comparing with the maximum allowable integer X+ .fd2 = maxint ; get maxint X+ .fcc = .fd8 ? .fd2 X+ bfgt.sf 2$ ; see if the result fits into an integer X+ .fd2 = minint.fd X+ .fcc = .fd8 ? .fd2 X+ bflt.sf 2$ X+ X+ .fs0.i = round(.fd8) ; yes, so convert it to an integer X+ b.sa 3$ ; and return X+ .0 = .fs0.i X+ X+ 2$ .fd0 = four X+ .fd8 /= .fd0 ; get the real floating point value X+ .return = call.sn [.3] ; call sc_makefloat64() X+ nop X+ .return = [.sf,8] ; pop the return PC X+ X+ 3$ b.sa [.return] ; return X+ .sf = [.sf] ; restore the old .SF X+ X+ * constant value for the division, above X+ four data.fd 4.0 X+ X+ * maximum and minimum possible integer, for comparison, above X+ maxint data.fd 2147483644.0 X+ X+ * The assembler seems to ignore the sign of a floating point constant. X+ * A Prism uses IEEE format, so the smallest possible integer X+ * is pretty easy to write in hexadecimal. X+ *minint data.fd -2147483648.0 X+ minint data.q h'C1E00000, h'00000000 X+ endp X+ X+ end X*** ./scrt/scinit.c.orig Thu Feb 22 17:47:40 1990 X--- ./scrt/scinit.c Fri Mar 2 09:31:07 1990 X*************** X*** 70,75 **** X--- 70,85 ---- X #include X #define STACKBASE (int*)USRSTACK X #endif X+ #ifdef apollo X+ #define ETEXT ((int)&etext) /* First address after text */ X+ #include X+ /* the stack back moves depending on shared libraries */ X+ #include X+ #include X+ #include X+ static proc2_$info_t sc_apollo_proc2; X+ #define STACKBASE ((int*) sc_apollo_proc2.stack_base) X+ #endif X X #include X #include X*************** X*** 96,103 **** X X /* Global data structure for this module. */ X X! static int emptyvector = VECTORTAG, X! emptystring[2] = {STRINGTAG, 0}; X X FILE *sc_stdin, /* Standard I/O Subroutine FILE pointers */ X *sc_stdout, X--- 106,117 ---- X X /* Global data structure for this module. */ X X! /* this struct must look like an SCOBJ */ X! static struct X! { X! F2(unsigned tag:8, X! unsigned length:24); X! } emptyvector, emptystring[2]; X X FILE *sc_stdin, /* Standard I/O Subroutine FILE pointers */ X *sc_stdout, X*************** X*** 284,289 **** X--- 298,316 ---- X char *freebase; X TSCP unknown; X X+ #ifdef apollo X+ /* on an apollo, we get the stack top at run time */ X+ uid_$t me; X+ status_$t status; X+ proc2_$who_am_i(&me); X+ proc2_$get_info(me, &sc_apollo_proc2, sizeof(sc_apollo_proc2), &status); X+ if (status.all != status_$ok && status.all != proc2_$is_current) X+ { X+ error_$print(status); X+ exit(2); X+ } X+ #endif X+ X if (sc_gcinfo) X fprintf( stderr, "***** SCGCINFO = %d SCHEAP = %d SCLIMIT = %d\n", X sc_gcinfo, scheap, sclimit ); X*************** X*** 315,320 **** X--- 342,349 ---- X sc_mutex = 0; X sc_pendingsignals = 0; X sc_emptylist = EMPTYLIST; X+ emptyvector.tag = VECTORTAG; X+ emptystring[0].tag = STRINGTAG; X sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG ); X sc_emptystring = U_T( emptystring, EXTENDEDTAG ); X sc_falsevalue = FALSEVALUE; X*************** X*** 598,603 **** X--- 627,634 ---- X sc_mutex = 0; X sc_pendingsignals = 0; X sc_emptylist = EMPTYLIST; X+ emptyvector.tag = VECTORTAG; X+ emptystring[0].tag = STRINGTAG; X sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG ); X sc_emptystring = U_T( emptystring, EXTENDEDTAG ); X sc_falsevalue = FALSEVALUE; X*************** X*** 698,703 **** X--- 729,735 ---- X scrt6_error( sc_string_2d_3esymbol( sc_cstringtostring( symbol ) ), X sc_cstringtostring( format ), X scrt1_reverse( argl ) ); X+ va_end( argp ); X } X X /* The following function returns informations about the implementation. The X*************** X*** 726,731 **** X--- 758,766 ---- X #ifdef VAX X sc_cstringtostring( "VAX" ), X #endif X+ #ifdef apollo X+ sc_cstringtostring( "Apollo" ), X+ #endif X sc_cons( X #ifdef MIPS X sc_cstringtostring( "R2000" ), X*************** X*** 736,743 **** X--- 771,788 ---- X #ifdef VAX X sc_cstringtostring( "VAX" ), X #endif X+ #ifdef APOLLO X+ sc_cstringtostring( "68K" ), X+ #endif X+ #ifdef PRISM X+ sc_cstringtostring( "PRISM" ), X+ #endif X sc_cons( X+ #ifdef apollo X+ sc_cstringtostring( "Domain/OS" ), X+ #else X sc_cstringtostring( "ULTRIX" ), X+ #endif X sc_cons( X FALSEVALUE, X EMPTYLIST X*** ./scrt/scrt7.sc.orig Thu Feb 22 17:45:17 1990 X--- ./scrt/scrt7.sc Thu Mar 1 12:41:50 1990 X*************** X*** 465,475 **** X ((and (zero? number) cl) X (if (< obj 0) (cons #\- cl) cl)))) X X (define (FLOAT->CLIST obj) X! (let* ((null (integer->char 0)) X! (buffer (make-string 30 null))) X! (gcvt obj 16 buffer) X! (let loop ((cli (string->list buffer)) (clo '())) X! (if (eq? (car cli) null) X! (reverse (if (memq #\. clo) clo (cons #\. clo))) X! (loop (cdr cli) (cons (car cli) clo)))))) X--- 465,520 ---- X ((and (zero? number) cl) X (if (< obj 0) (cons #\- cl) cl)))) X X+ ;; LIST-SEARCH-POSITIVE, contributed by Patrick Logan (uunet!mntgfx!plogan). X+ ;; (list-search-positive list pred? fail) searches the list until pred? X+ ;; is true. If pred? is never true, then (fail) is returned. X+ (define (LIST-SEARCH-POSITIVE list pred? fail) X+ (let loop ((cur list)) X+ (if (null? cur) X+ (fail) X+ (let ((item (car cur))) X+ (if (pred? item) X+ item X+ (loop (cdr cur))))))) X+ X+ ;; (list-search-negative list pred? fail) searched the list until pred? X+ ;; is false. If pred? is never false, then (fail) is returned. X+ (define (LIST-SEARCH-NEGATIVE list pred? fail) X+ (list-search-positive list (lambda (x) (not (pred? x))) fail)) X+ X+ ;; New, improved FLOAT->CLIST, contributed by Patrick Logan (uunt!mntgfx!plogan) X+ ;; Make only one pass over the character list. If the list contains only X+ ;; digits and sign characters, then append a decimal (.), otherwise, the X+ ;; number has already been properly formatted, either with a decimal point X+ ;; or with an exponent, e.g., 3.1415, 1e-27. X+ X (define (FLOAT->CLIST obj) X! (let* ((null (integer->char 0)) X! (buffer (make-string 30 null)) X! (clo (cons #f '()))) ; The car is a flag, the cdr is the list being built. X! ; I do this because in some good Scheme compilers, it is X! ; more efficient to SET-CR! a pair than SET! a variable. X! (gcvt obj 16 buffer) X! (let loop ((cli (string->list buffer)) (clo-tail '())) X! (if (null? cli) X! (error 'float->clist "Expected the null character terminator: ~s." buffer) X! (let* ((ch (car cli))) X! (if (eq? ch null) X! ;; This branch returns the cdr of clo, possibly adding a #\. X! (cdr (if (list-search-negative (cdr clo) X! (lambda (x) (or (eq? x #\+) (eq? x #\-) X! (and (char>=? x #\0) X! (char<=? x #\9)))) X! (lambda () #f)) X! clo X! (begin (set-cdr! clo-tail (cons #\. '())) X! clo))) X! ;; This branch continues the loop with the new char at the end. X! (let ((new-tail (cons ch '()))) X! (if (car clo) X! ;; Store another character at the end of clo. X! (set-cdr! clo-tail new-tail) X! ;; First time to store a character in clo. X! (begin (set-car! clo #t) X! (set-cdr! clo new-tail))) X! (loop (cdr cli) new-tail)))))))) X*** ./scrt/signal.c.orig Thu Feb 22 17:47:51 1990 X--- ./scrt/signal.c Tue May 8 14:39:43 1990 X*************** X*** 227,232 **** X--- 227,261 ---- X C_FIXED( code )); X } X #endif X+ #if defined(APOLLO) || defined(PRISM) X+ if (sig == SIGFPE) { X+ if (code == FPE_INTDIV_TRAP || code == FPE_FLTDIV_FAULT || X+ code == FPE_FLTDIV_TRAP) X+ /***** divide by zero exception *****/ X+ sc_error ("?????", "Divide by zero", 0); X+ if (code == FPE_FLTOVF_TRAP || code == FPE_FLTOVF_FAULT) X+ /***** floating point overflow *****/ X+ sc_error ("?????", "Overflow", 0); X+ if (code == FPE_FLTUND_FAULT || code == FPE_FLTUND_TRAP) X+ /***** floating point underflow *****/ X+ sc_error ("?????", "Underflow", 0); X+ sc_error ("?????", "Floating point exception: ~s", 1, X+ C_FIXED( code )); X+ } X+ else if (sig == SIGAPOLLO) { X+ status_$t status; X+ char *subsys, *module, *error; X+ short lsubsys, lmodule, lerror; X+ char buffer[256]; X+ X+ status.all = code; X+ error_$find_text(status, &subsys, &lsubsys, &module, &lmodule, X+ &error, &lerror); X+ sprintf(buffer, "%.*s (%.*s/%.*s)", lerror, error, X+ lsubsys, subsys, lmodule, module); X+ sc_error("?????", buffer, 0); X+ } X+ #endif X X /*************************************** X other possibly recoverable exceptions X*** ./scsc/makefile-tail.orig Thu Aug 17 11:25:26 1989 X--- ./scsc/makefile-tail Mon Feb 26 14:14:52 1990 X*************** X*** 46,52 **** X mv Xsccomp.heap sccomp.heap X X port: X! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \ X Xsccomp.heap Xmv X X install-private: X--- 46,52 ---- X mv Xsccomp.heap sccomp.heap X X port: X! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \ X Xsccomp.heap Xmv X X install-private: X*************** X*** 94,100 **** X rdist -c sccomp makefile-tail makefile ${destdir} X X all: X! make Xsccomp.heap Xmv X X srclinks: X for x in ${scsc} ${scc} ${scsch}; \ X--- 94,100 ---- X rdist -c sccomp makefile-tail makefile ${destdir} X X all: X! $(MAKE) Xsccomp.heap Xmv X X srclinks: X for x in ${scsc} ${scc} ${scsch}; \ X*** ./xlib/makefile.orig Tue Jan 30 10:40:08 1990 X--- ./xlib/makefile Fri Mar 2 13:21:23 1990 X*************** X*** 91,97 **** X rm -f *.o scixl scxl.a hello puzzle clear X X all: X! make scixl scxl.a X X gensource: X! make ${xwssc} ${xwsc} X--- 91,97 ---- X rm -f *.o scixl scxl.a hello puzzle clear X X all: X! $(MAKE) scixl scxl.a X X gensource: X! $(MAKE) ${xwssc} ${xwsc} SHAR_EOF $TOUCH -am 0718121290 apollo.diffs && chmod 0755 apollo.diffs || echo "restore of apollo.diffs failed" set `wc -c apollo.diffs`;Wc_c=$1 if test "$Wc_c" != "61965"; then echo original size 61965, current size $Wc_c fi # ============= apollo.o ============== echo "x - extracting apollo.o (Compressed)" sed 's/^X//' << 'SHAR_EOF' | uudecode && Xbegin 600 shar3_cmp_.tmp XM'YV,`2X!2&#BAB1E``;22`B@`P`6@!P`"#`QX0`2#%DPW,@04$**#!'XX4@2 XM@`LZ9?#0X1@(5<*6'PE\=%F2(P@`(%S4<7,GC1LR#`6Q2BB4(9Z$`H8"0*"( XMXP&;+LB$H1-F(\B*&S76+'D3`"`78MB\&;-FSL>'%;4&`&<1XU)H'&5:3.B" XMC<\R9C\*8#!Q+T-)"0O(W3K7Y)P\;<2\86,V@`!/?2$#$&`I<&7"A5W(N4,F XMC=4""P.`9H@C(0*M"/!Q-,`0I(LV:>1@WJC!--#9DPW+\8P;`-^E(W$+`,#D XM6C``41XY@>;$RC]^(-PL10+-PS\G7IS4:9[P10,52'(N%>'"-[1`:!**$(^` XM'"!Y`(``(!=(7@`@[P$0$"'OQ$H0;0"`@A.00/&("FX\AYUVW`'@'7CLD><; XM).BIQYY[\,E'GWWXP4<`"OW]%^"`!1Z8(#\+;F=%=]^%5QX"(@!`!"#I`8#! XMAO?E1X`&(>(T(H$&(JA@=BJR".&+$C+`1``(`%"C!_*X(-]2.':HWP@]`B@@ XMD"8.J=U&,#DVV%$LT83``#5U55(@L"0$P54`_",G/R\!DY`/`:@IYW,O^7-G XMG@SM22<`@O"0D`R`)B0H4=(!P$.B<%41URY;4C+!@F*K#-,F1(FM8,1+V%"\(F.KH>$:8RL>&VR$R`LOJ%$& XM&W:]00<=+X@U1AAL?%'''&7(\<(9;M3APAQRC.$"''*\H<8+9)0Q1@MSC(%& XM&6V4\4+,5"&',$&/,7._?\!@!#=,=780Z=!1QHUFQ4(`-)^`(`$$]!M]Q"/"/"V XMM%(@`K<$$3P2P-X`=`&`WQ)(D(@$>1-NEM\3A)!X"#(`+D($$HB0>`2)A/`( XM`81/>0279[YYYY\3+LOHI4=`.>::`\XZZ'`#T`SLDDL@@PPCT+ZZ XMYP0`<@%)?.=>107(`R"%5<#R^A$&`!S/D;2&2PL&\]<7;I6SY@9`O?4;26N6 XMM(IP7S[25G'+D+?B5]^\Z-*JHOZQ`(B^$;J\JCM^\Z^35C'NYR8`O&XC].*5 XMO>)'/OSM3EKC(&#N=K<1@#%$8`QL'D4@:('62$M:#AD`"'#%D`Y^Q%)Q(]8( XM:V+"A*A&6LX2X6`4L)$6`B`>N1N!"@=#@1INQ!RY*\$.&>(!'S)$&[E3P1`3 XMDJV$V'`:N7N>",/%$1L*#'LJ#%>32K@17>3.+%-D"/6XR)!6Y$YT84S(BLB8 XM$%/D[G5I!,"^V`B`34PPBPPQF!@!D#"&($(J5/G"'*B2,[)=+6MIXYK7F!8V XMM%&M;&)%VUQA`5!T,<__.&$?-0IE_^@1R_[!$QU#)-0/``F.(XIB$8Q XM)%S#H8@#$J``$13B'*Q)2+*6,JRS4&0P6D!SP3,HC!I!,`@^CA.-M9$24P1"*LH8@3\!=0Y\V3(FL$``T#6@`;,&2A XM$RD`$0Y:@('NDZ%8H*@8*&H&AG"@G2XP0QK8,#:.8&"7"3E#`(H&L3?\+&B] XMF=M+7$(1$@@`3MVL"=1&R1`V5<2F."W@5DZ2DI6`B:86`4D`2%@3G?#$)[\B`H`EJ+J XM7WHS,L0HAC&1X:=<)W.9L&ZF,Y]9"*;0FI#29!.KL)%-3;9(6`!P*JPDXTU) XM$I!4AOQF-FD[9&.>J1_I;<0A%*$AF@C@V8Q4I(>C+6U";E"1(J:V)D&HB?2@ XF$(0I-$%K+!6+UI1F2K*UDI%B(YL;FA;)M-&2E%^X9"8W^89.+@2V X` Xend SHAR_EOF echo "uncompressing file apollo.o" && compress -d < shar3_cmp_.tmp > apollo.o && rm -f shar3_cmp_.tmp && $TOUCH -am 0718124890 apollo.o && chmod 0755 apollo.o || echo "restore of apollo.o failed" set `wc -c apollo.o`;Wc_c=$1 if test "$Wc_c" != "2958"; then echo original size 2958, current size $Wc_c fi # ============= prism.o ============== echo "x - extracting prism.o (Compressed)" sed 's/^X//' << 'SHAR_EOF' | uudecode && Xbegin 600 shar3_cmp_.tmp XM'YV,`2@!0&"BASE,```H@)800`D`+``I`!"`8D("R!J":L@Q(8*&$#J*'.F" XM3AD\=#@B"`!H(,N$`K`E?#F2(P00`$"XJ./F3AHW9#P2P#)P:$,X%XD"2("O XMXX&$(7.Z(!.&3AB;(#MN!(`QH0(?'1-`30C$19LT$'`LT')#0!9N?90Q#'0`/ XM``3.,S%X!-<7`.6Y<_*T$?.&C6$(!3["_EAZY&D2,`!8@'`!Q`S7PWH$^.">#_$%6:,/]?EPGP_YM4@`&MTAX"24":%Q"U=@B`$` XM)02:!@9?`/1'0(0#76A!A@GE4&-XX]V70WXY[)<#D.VQ5Z0.->I0GP[WF:D& XM*1M*"`%_!4`@R"]$M,`-``]`(,HO1?#S2T4Q5L3/)P$04"D!D_P#P`FBBBS;Z:*237FZJKK'I3IKLLM"*VF[!(`01+PQ,""(` XM.V#!<6Y"S$[`BP`"J%`B`VR`14;%%PNP"EL(3'RPJ1P(@``KN9F++G4A`,R. XM!P"@8#*S,#!P;:SW:BLAMR(!$15'07SSS]$-!4.:2"LA0A$:FB:$E$H!.`V` XM$3`E]$\[K@XD``4)"9$U`%L#TA("`C"3$`ICEWWV`&S5W-$_[#2$P`!L)(03 XM1W3;/0`K"5G1=CMF@T$S'A#.#F02TZY XMY5AD_@'C_T#3^>25TXR$Z*3SN.HO)YZS;/_0XGM+CF--MAWDXRW XMUVK?#7AM',E5D0,`Y##"%L9,TY"F0;:;*<%4!`ZE`H@!/7?V_:42)0"`.#RQP*N-(0>_(.+ XM`*@QD@`"P2(4J=OVPI%`M0B@$PUL"&,H%8`2;6\9%:R)`/(&0`U",`!,,&!" XM:A'"D0B`!QE,"`U.*)KMA:*%(A&`6$J8$+X$4"#;TP,.L4<<'@*`$1`#+`X XMD_]AKR%H9-$22<#&A##$B'&4V_8P4$<`1/&-"`$MY8#)5:9A#FUP01B`"0!:?@&4=%!#&Y!B3,&X XMX0S*9.88OI`&,J3!#&8(91G<,(8R%'.:F#E#5;QIS#3`@0V?_"8UZ9`&7!K& XME\`\IE4(\P4SR"$,N%0G,J.I3F="6T)C:UR4UR@M,- XM`QVG.M/`3G`8`9(\#1"#PB`!@-21``T%&/@C2C2"!I1S\:4@`\0:4< XM96E&!5=2F8:D"S`U:4OO0%*;`@"C'0T!1R50TJ(:-0)"#6I-3QH26``@J24E XMZE&GFE2H^G114UUJ2_WQU*A*0`(BD*I0;1J`#'2UHU\%JUAUZID`S."L7PTK XM1\?*U`!,@:1IE0&]!/#5H895K6M]!`):HA*C)$0"X"O*6PZ;V)+AH2&(#5_) XMK`:`R!8%,I5M+`%0`5G-XJ*SX0O)8QD;6@#P`;09)6QF2PNFU6:4LI8-"1)) XMFU'')(0$B0V)0!)BG=)B=@2Y!8`O4!L2833$`L$U1D/84EIE-(1FI75&0W`2 XMOHZXP`QI8(,W.R*"?W`5`&<(`#R#.=4=B1E#PC;[OAA`-8,VA%2DO?]5BUYJDINA XM';@VXQO)0T("M@N79F@BF8!+6O+@^]8&L7,Q"4JH1F+UY4\FI=E)3WX2E*(0 XM!48#""!2W*B6J53E*EE1GXLULI2^F`4M:HE:CI=;FU/>I2:2,4T`)VSDP`RF XM,(=)K)35QY@HP\4RF-&,_#KSOR531#0Q3LUJ6O.:V"AQR^>MB7E=6,PTG,'* XMA!%A3;R@YX;@897E5>=X`3!>>8:!GO;$IT._X$]^&G.?`$WH-;,IT(9.%*+B X<-,E$*YH9=;8A#&LH@QD$4Q4;S'`.=D;FI^>P14]^ X` Xend SHAR_EOF echo "uncompressing file prism.o" && compress -d < shar3_cmp_.tmp > prism.o && rm -f shar3_cmp_.tmp && $TOUCH -am 0718124890 prism.o && chmod 0755 prism.o || echo "restore of prism.o failed" set `wc -c prism.o`;Wc_c=$1 if test "$Wc_c" != "3554"; then echo original size 3554, current size $Wc_c fi exit 0