Path: utzoo!censor!geac!torsqnt!news-server.csri.toronto.edu!cs.utexas.edu!milano!cadillac!davide
From: davide@maverick.cad.mcc.com (David Eckelkamp)
Newsgroups: comp.lang.scheme
Subject: integrated patch for Scheme->C (Part 2/3)
Message-ID: <DAVIDE.90Nov13084037@maverick.cad.mcc.com>
Date: 13 Nov 90 14:40:37 GMT
Sender: news@cadillac.CAD.MCC.COM
Reply-To: eckelkamp@mcc.com (David Eckelkamp)
Organization: MCC CAD Program, Austin, Texas
Lines: 1940

*** /tmp/,RCSt1a07923	Mon Nov 12 11:05:59 1990
--- makefile	Mon Nov 12 11:03:15 1990
***************
*** 16,25 ****
--- 16,52 ----
  VAXBIN = /wrl/vax/bin
  VAXLIB = /wrl/vax/lib
  
+ APOLLODIR = $(SRCDIR)/apollo
+ APOLLOBIN = $(SRCDIR)/bin.apollo
+ APOLLOLIB = $(SRCDIR)/lib.apollo
  
+ PRISMDIR = $(SRCDIR)/prism
+ PRISMBIN = $(SRCDIR)/bin.prism
+ PRISMLIB = $(SRCDIR)/lib.prism
+ 
+ SPARCDIR = ${SRCDIR}/sparc
+ SPARCBIN = ${SRCDIR}/bin.sparc
+ SPARCLIB = ${SRCDIR}/lib.sparc
+ 
+ SUN3DIR = ${SRCDIR}/sun3
+ SUN3BIN = ${SRCDIR}/bin.sun3
+ SUN3LIB = ${SRCDIR}/lib.sun3
+ 
+ I386DIR = ${SRCDIR}/i386
+ I386BIN = ${SRCDIR}/bin.i386
+ I386LIB = ${SRCDIR}/lib.i386
+ 
+ # This is a list of the machines/architectures that are currently supported. 
+ # These are also the names of the necessary makefile fragements.
+ MACHINES = APOLLO I386 MIPS PRISM SPARC SUN3 TITAN VAX
+ 
  # Architecture specific directories and links to the source files are
  # constructed by the following commands which follow:
  
+ no-target:
+ 	@echo 'Use "make for<target>", where <target> is one of:'
+ 	@echo '    $(MACHINES)'
+ 
  forCPU:
  	-mkdir ${CPUDIR}
  	cp ${CPU} ${CPUDIR}
***************
*** 64,157 ****
  	-cd ${CPUDIR}/test; make srclinks
  
  forMIPS:
! 	make "CPU = MIPS" "CPUDIR = ${MIPSDIR}" \
  	     "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU
  
  forTITAN:
! 	make "CPU = TITAN" "CPUDIR = ${TITANDIR}" \
  	     "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU
  
  forVAX:
! 	make "CPU = VAX" "CPUDIR = ${VAXDIR}" \
  	     "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU
  
  # The Scheme->C system is initially compiled from the C sources by the
  # following:
  
  port:
! 	cd scrt; make port
! 	cd scsc; make port
  
  # A "private" working copy of the current compiler, libary, and interpreter
  # is installed in a directory by the following command:
  
  install-private:
! 	cd scrt; make "destdir = ${destdir}" install-private
! 	cd scsc; make "destdir = ${destdir}" install-private
  
  # Clean out working files.
  
  clean:
  	rm -f *.BAK *.CKP SC-TO-C*
! 	cd doc; make clean
! 	cd scrt; make clean
! 	cd scsc; make clean
! 	cd test; make clean
  
  # Clean up C source files generated from Scheme source.
  
  clean-sc-to-c:
! 	cd scrt; make clean-sc-to-c
! 	cd scsc; make clean-sc-to-c
! 	cd test; make clean-sc-to-c
  
  # Delete programs and libraries.
  
  noprogs:
! 	cd scrt; make noprogs
! 	cd scsc; make noprogs
! 	cd test; make noprogs
  
  # All binaries and documentation files are installed by the following command
  # for access by all users.
  
  install:
! 	cd doc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
! 	cd scrt; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
! 	cd scsc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
  
  # All files which must be constructed are made by the following command:
  
  all:
! 	cd scrt; make all
! 	cd scsc; make all
  
  # Distribute "source" files required to make the Scheme->C system.
  
  srcdist:
! 	rdist -c MIPS README TITAN VAX makefile ${destdir}
! 	cd doc; make "destdir = ${destdir}/doc" srcdist
! 	-cd scbenchmark; make "destdir = ${destdir}/scbenchmark" srcdist
! 	cd scrt; make "destdir = ${destdir}/scrt" srcdist
! 	cd scsc; make "destdir = ${destdir}/scsc" srcdist
! 	-cd test; make "destdir = ${destdir}/test" srcdist
! 	-cd tools; make "destdir = ${destdir}/tools" srcdist
  
  # Distribute "binary" files so that they may be installed on some other
  # system.
  
  bindist:
! 	rdist -c MIPS README TITAN VAX makefile ${destdir}
! 	cd doc; make "destdir = ${destdir}/doc" bindist
! 	cd scrt; make "destdir = ${destdir}/scrt" bindist
! 	cd scsc; make "destdir = ${destdir}/scsc" bindist
  
  # Write the tar tape for distribution.
  
! TARFILES = CHANGES MIPS README VAX makefile \
  	   doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile \
  	   gnuemacs/README gnuemacs/[a-z]* \
  	   scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \
  	   scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \
  	   test/[a-z]*.sc test/test54c.c test/makefile-tail \
  	   cdecl/README cdecl/[a-z]* \
--- 91,207 ----
  	-cd ${CPUDIR}/test; make srclinks
  
  forMIPS:
! 	$(MAKE) "CPU = MIPS" "CPUDIR = ${MIPSDIR}" "SRCDIR = ${SRCDIR}" \
  	     "BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU
  
  forTITAN:
! 	$(MAKE) "CPU = TITAN" "CPUDIR = ${TITANDIR}" "SRCDIR = ${SRCDIR}"  \
  	     "BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU
  
  forVAX:
! 	$(MAKE) "CPU = VAX" "CPUDIR = ${VAXDIR}" "SRCDIR = ${SRCDIR}"  \
  	     "BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU
  
+ forAPOLLO:
+ 	$(MAKE) "CPU = APOLLO" "CPUDIR = ${APOLLODIR}" "SRCDIR = ${SRCDIR}" \
+ 	     "BINDIR = ${APOLLOBIN}" "LIBDIR = ${APOLLOLIB}" forCPU
+ 	cd $(APOLLODIR)/scrt; ln -s $(SRCDIR)/mul-fix.perl mul-fix.perl
+ 
+ forPRISM:
+ 	$(MAKE) "CPU = PRISM" "CPUDIR = ${PRISMDIR}" "SRCDIR = ${SRCDIR}" \
+ 	     "BINDIR = ${PRISMBIN}" "LIBDIR = ${PRISMLIB}" forCPU
+ 
+ forSPARC:
+ 	$(MAKE) "CPU = SPARC" "CPUDIR = ${SPARCDIR}" "SRCDIR = ${SRCDIR}" \
+ 	     "BINDIR = ${SPARCBIN}" "LIBDIR = ${SPARCLIB}" forCPU
+ 
+ 
+ forSUN3:
+ 	$(MAKE) "CPU = SUN3" "CPUDIR = ${SUN3DIR}" "SRCDIR = ${SRCDIR}" \
+ 	     "BINDIR=${SUN3BIN}" "LIBDIR=${SUN3LIB}" forCPU
+ 
+ forI386:
+ 	$(MAKE) "CPU = I386" "CPUDIR = ${I386DIR}" "SRCDIR = ${SRCDIR}" \
+ 	     "BINDIR = ${I386BIN}" "LIBDIR = ${I386LIB}" forCPU
+ 
  # The Scheme->C system is initially compiled from the C sources by the
  # following:
  
  port:
! 	cd scrt; $(MAKE) port
! 	cd scsc; $(MAKE) port
  
  # A "private" working copy of the current compiler, libary, and interpreter
  # is installed in a directory by the following command:
  
  install-private:
! 	cd scrt; $(MAKE) "destdir = ${destdir}" install-private
! 	cd scsc; $(MAKE) "destdir = ${destdir}" install-private
  
  # Clean out working files.
  
  clean:
  	rm -f *.BAK *.CKP SC-TO-C*
! 	cd doc; $(MAKE) clean
! 	cd scrt; $(MAKE) clean
! 	cd scsc; $(MAKE) clean
! 	cd test; $(MAKE) clean
  
  # Clean up C source files generated from Scheme source.
  
  clean-sc-to-c:
! 	cd scrt; $(MAKE) clean-sc-to-c
! 	cd scsc; $(MAKE) clean-sc-to-c
! 	cd test; $(MAKE) clean-sc-to-c
  
  # Delete programs and libraries.
  
  noprogs:
! 	cd scrt; $(MAKE) noprogs
! 	cd scsc; $(MAKE) noprogs
! 	cd test; $(MAKE) noprogs
  
  # All binaries and documentation files are installed by the following command
  # for access by all users.
  
  install:
! 	cd doc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
! 	cd scrt; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
! 	cd scsc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
  
  # All files which must be constructed are made by the following command:
  
  all:
! 	cd scrt; $(MAKE) all
! 	cd scsc; $(MAKE) all
  
  # Distribute "source" files required to make the Scheme->C system.
  
  srcdist:
! 	rdist -c $(MACHINES) README makefile ${destdir}
! 	cd doc; $(MAKE) "destdir = ${destdir}/doc" srcdist
! 	-cd scbenchmark; $(MAKE) "destdir = ${destdir}/scbenchmark" srcdist
! 	cd scrt; $(MAKE) "destdir = ${destdir}/scrt" srcdist
! 	cd scsc; $(MAKE) "destdir = ${destdir}/scsc" srcdist
! 	-cd test; $(MAKE) "destdir = ${destdir}/test" srcdist
! 	-cd tools; $(MAKE) "destdir = ${destdir}/tools" srcdist
  
  # Distribute "binary" files so that they may be installed on some other
  # system.
  
  bindist:
! 	rdist -c $(MACHINES) README makefile ${destdir}
! 	cd doc; $(MAKE) "destdir = ${destdir}/doc" bindist
! 	cd scrt; $(MAKE) "destdir = ${destdir}/scrt" bindist
! 	cd scsc; $(MAKE) "destdir = ${destdir}/scsc" bindist
  
  # Write the tar tape for distribution.
  
! TARFILES = CHANGES README $(MACHINES) makefile \
  	   doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile \
  	   gnuemacs/README gnuemacs/[a-z]* \
  	   scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \
+ 	   scrt/[a-z]*.asm \
  	   scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \
  	   test/[a-z]*.sc test/test54c.c test/makefile-tail \
  	   cdecl/README cdecl/[a-z]* \

*** /tmp/,RCSt1a27358	Fri Nov  9 17:25:53 1990
--- scrt/apply.h	Fri Nov  9 14:05:39 1990
***************
*** 44,57 ****
     by the compiler to call unknown functions.
  */
  
- #ifdef MIPS
- #define MAXARGS 25	/* Maximum number of required arguments permitted.
- 			   Note that this does not preclude an optional
- 			   argument list as an additional argument.  This
- 			   number is typically determined by the ability
- 			   of one's C compiler.  */
- #endif
- 
  #ifdef TITAN
  #define MAXARGS 16	/* Maximum number of required arguments permitted.
  			   Note that this does not preclude an optional
--- 44,49 ----
***************
*** 58,66 ****
  			   argument list as an additional argument.  This
  			   number is typically determined by the ability
  			   of one's C compiler.  */
! #endif
! 
! #ifdef VAX
  #define MAXARGS 25	/* Maximum number of required arguments permitted.
  			   Note that this does not preclude an optional
  			   argument list as an additional argument.  This
--- 50,56 ----
  			   argument list as an additional argument.  This
  			   number is typically determined by the ability
  			   of one's C compiler.  */
! #else
  #define MAXARGS 25	/* Maximum number of required arguments permitted.
  			   Note that this does not preclude an optional
  			   argument list as an additional argument.  This

*** /tmp/,RCSt1a27363	Fri Nov  9 17:25:55 1990
--- scrt/callcc.c	Fri Nov  9 14:05:43 1990
***************
*** 57,62 ****
--- 57,74 ----
  #include "callcc.h"
  #include "apply.h"
  #include "signal.h"
+ 
+ #ifdef SPARC
+ extern	sc_setjmp();
+ /* This is really tacky, but it appears to be necessary because of the */
+ /* compiler on the DECStation 5100.  That beast does not seem to be able to */
+ /* grok the #pragma directive. The one I tried appeared to be */
+ /* Ultrix T3.1D-0 (Rev. 45) Worksystem X2.2.  */
+ #include "sparc-pragma.h"
+ #define setjmp( x )	sc_setjmp( x )
+ #define longjmp( x, y )	sc_longjmp( x, y )
+ #endif
+ 
  #ifdef MIPS
  extern  sc_setsp();
  #endif
***************
*** 66,71 ****
--- 78,92 ----
  #define  setjmp( x )		sc_setjmp( x )
  #endif
  
+ #ifdef APOLLO
+ extern sc_setregs(int a6, int a7);
+ #endif
+ 
+ #ifdef PRISM
+ #define longjmp(x, y)		sc_longjmp(x, y)
+ #define setjmp(x)		sc_setjmp(x)
+ #endif
+ 
  TSCP  sc_clink;		/* Pointer to inner most continuation on stack. */
  
  /* Static declarations for data structures internal to the module.  These
***************
*** 97,102 ****
--- 118,127 ----
             it will restore the stack.  */
  #ifdef MIPS
  	sc_setsp( (T_U(callcccp))->continuation.address );
+ #endif
+ #ifdef APOLLO
+ 	sc_setregs( (T_U(callcccp))->continuation.savedstate[3],
+ 		   (T_U(callcccp))->continuation.savedstate[2]);
  #endif
  	longjmp( (T_U(callcccp))->continuation.savedstate, 1 );
  }

*** /tmp/,RCSt1a27372	Fri Nov  9 17:25:59 1990
--- scrt/cio.c	Fri Nov  9 14:05:49 1990
***************
*** 46,51 ****
--- 46,64 ----
  #include <sys/time.h>
  #include "objects.h"
  
+ /* This really does not need to be dependant on ISC386IX, just the lack of */
+ /* a rename function.  This is just a dirty hack. */
+ #ifdef ISC386IX
+ #include <stropts.h>
+ #include <poll.h>
+ int rename(old, new) char *old, *new;
+ {
+   if (link(old, new) == 0 && unlink(old) == 0)
+     return 0;
+   return -1;
+ }
+ #endif
+ 
  int  sc_libc_eof = EOF;
  
  /*  feof(stream)  */
***************
*** 84,100 ****
--- 97,124 ----
     input characters ready, and 0 when none are available.
  */
  
+ /* The changes here are probably generic Sys5 changes, but what the heck */
  int sc_inputchars( stream )
  	FILE *stream;
  {
  	int  readfds, nfound;
+ #ifndef ISC386IX
  	struct  timeval  timeout;
+ #else
+ 	struct pollfd pollfd;
+ #endif
  	
  	if  (((stream)->_cnt) <= 0)  {
+ #ifndef ISC386IX
  	   readfds = 1<<(fileno( stream ));
  	   timeout.tv_sec = 0;
  	   timeout.tv_usec = 0;
  	   nfound = select( fileno( stream )+1, &readfds, 0, 0, &timeout );
+ #else
+ 	   pollfd.fd = fileno( stream );
+ 	   pollfd.events = POLLIN;
+ 	   nfound = poll(&pollfd, 1, 0);
+ #endif
  	   if  (nfound == 0)  return( 0 );
  	}
  	return( 1 );

*** /tmp/,RCSt1a27381	Fri Nov  9 17:26:04 1990
--- scrt/heap.c	Fri Nov  9 14:05:58 1990
***************
*** 59,64 ****
--- 59,70 ----
  #ifdef VAX
  extern  sc_r2tor11();
  #endif
+ #ifdef APOLLO
+ extern sc_regs();
+ #endif
+ #ifdef SUN3
+ extern	sc_a2to5d2to7();
+ #endif
  
  /* Forward declarations */
  
***************
*** 100,108 ****
--- 106,116 ----
  
  int	sc_gcinfo;		/* controls logging */
  
+ #ifndef SYSV
  static struct rusage gcru,	/* resource consumption during collection */
  	             startru,
  	      	     stopru;
+ #endif
  
  int	*sc_stackbase;		/* pointer to base of the stack */
  
***************
*** 111,116 ****
--- 119,125 ----
  
  TSCP	sc_after_2dcollect_v;	/* Collection status callback */
  
+ #ifndef SYSV
  /* The following function converts a rusage structure into an 18 word Scheme
     vector composed of the same items.
  */
***************
*** 241,246 ****
--- 250,260 ----
  	return( rusagevector( &gcru ) );
  }
  
+ #else
+ #define	getrusage(x,y)	/* no operation */
+ #define updategcru()	/* no operation */
+ #endif		/* SYSV-BSD dependency */
+ 
  /* Errors detected during garbage collection are logged by the following
     procedure.  If any errors occur, the program will abort after logging
     them.  More than 30 errors will result in the program being aborted at
***************
*** 348,354 ****
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif TITAN
  
  #ifdef VAX
  /* The following code is used to read the stack pointer.  The register
--- 362,368 ----
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif /* TITAN */
  
  #ifdef VAX
  /* The following code is used to read the stack pointer.  The register
***************
*** 374,380 ****
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif VAX
  
  #ifdef MIPS
  /* The following code is used to read the stack pointer.  The register
--- 388,394 ----
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif /* VAX */
  
  #ifdef MIPS
  /* The following code is used to read the stack pointer.  The register
***************
*** 400,408 ****
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif MIPS
  
  
  /* The size of an extended object in words is returned by the following
     function.
  */
--- 414,532 ----
  	pp = STACKPTR;
  	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
  }
! #endif /* MIPS */
  
+ #ifdef APOLLO
+ /* The following code is used to read the stack pointer.  The register
+    number is passed in to force an argument to be on the stack, which in
+    turn can be used to find the address of the top of stack.
+ */
  
+ int  *sc_processor_register( reg )
+ 	int  reg;
+ {
+ 	return( &reg );
+ }
+ 
+ /* All processor registers that might contain pointers are traced by the
+    following procedure.
+ */
+ 
+ static  trace_stack_and_registers()
+ {
+ 	int  i, a1toa4_d0tod7[12], *pp;
+ 
+ 	sc_regs( a1toa4_d0tod7 );
+ 	pp = STACKPTR;
+ 	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
+ }
+ #endif /* APOLLO */
+ 
+ #ifdef PRISM
+ /* All processor registers that might contain pointers are traced by the
+    following procedure.
+ */
+ 
+ static  trace_stack_and_registers()
+ {
+ 	int  i, regs[12], *pp;
+ 
+ 	sc_regs( regs );
+ 	pp = STACKPTR;
+ 	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
+ }
+ #endif /* PRISM */
+ 
+ #ifdef SPARC
+ /* All processor registers which might contain pointers are traced by the
+    following procedure.
+ */
+ 
+ static  trace_stack_and_registers()
+ {
+ 	int  i, *pp;
+ 	jmp_buf tmp;
+ 
+ 	pp = STACKPTR;
+ 	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
+ }
+ #endif SPARC
+ 
+ #ifdef SUN3
+ /* The following code is used to read the stack pointer.  The register
+    number is passed in to force an argument to be on the stack, which in
+    turn can be used to find the address of the top of stack.
+ */
+ 
+ int  *sc_processor_register( reg )
+ 	int  reg;
+ {
+ 	return( &reg+1 );
+ }
+ 
+ /* All processor registers which might contain pointers are traced by the
+    following procedure.
+ */
+ 
+ static  trace_stack_and_registers()
+ {
+ 	int  i, a2to5d2to7[10], *pp;
+ 
+ 	sc_a2to5d2to7( a2to5d2to7 );
+ 	pp = STACKPTR;
+ 	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
+ }
+ #endif SUN3
+ 
+ 
+ #ifdef I386
+ /* The following code is used to read the stack pointer.  The register
+    number is passed in to force an argument to be on the stack, which in
+    turn can be used to find the address of the top of stack.
+ */
+ 
+ int  *sc_processor_register( reg )
+ 	int  reg;
+ {
+ 	return( &reg );
+ }
+ 
+ /* All processor registers which might contain pointers are traced by the
+    following procedure.
+ */
+ 
+ static  trace_stack_and_registers()
+ {
+ 	int  i, *pp;
+ 	jmp_buf tmp;
+ 
+ 	setjmp(tmp);
+ 	pp = STACKPTR;
+ 	while  (pp != sc_stackbase)  move_continuation_ptr( *pp++ );
+ }
+ #endif I386
+ 
+ 
  /* The size of an extended object in words is returned by the following
     function.
  */
***************
*** 1421,1426 ****
--- 1545,1551 ----
  	getrusage( 0, &stopru );
  	updategcru();
  	if  (sc_gcinfo)  { 
+ #ifndef SYSV
  	   fprintf( stderr,
  	            "              %d%% locked  %d%% retained  %d user ms",
  		    (sc_lockcnt*100)/sc_heappages,
***************
*** 1430,1435 ****
--- 1555,1566 ----
  	   	    "  %d system ms  %d page faults\n",
  		    stopru.ru_stime.tv_sec*1000+stopru.ru_stime.tv_usec/1000,
  		    stopru.ru_majflt );
+ #else
+ 	   fprintf( stderr,
+ 	            "              %d%% locked  %d%% retained\n",
+ 		    (sc_lockcnt*100)/sc_heappages,
+ 	            (sc_generationpages*100)/sc_heappages);
+ #endif
  	}
  	if  (sc_gcinfo == 2)  {
  	   /* Perform additional consistency checks */
***************
*** 1663,1670 ****
--- 1794,1805 ----
     the Scheme object with that value.
  */
  
+ #ifdef PRISM
+ TSCP sc_makefloat32( float value )
+ #else
  TSCP sc_makefloat32( value )
  	float  value;
+ #endif
  {
  	SCP  pp;
  
***************
*** 1673,1679 ****
  	   pp = sc_extobjp;
  	   sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE);
  	   sc_extobjwords = sc_extobjwords-FLOAT32SIZE;
! 	   pp->unsi.gned = FLOAT32TAG;
  	}
  	else
  	   pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 );
--- 1808,1815 ----
  	   pp = sc_extobjp;
  	   sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE);
  	   sc_extobjwords = sc_extobjwords-FLOAT32SIZE;
! 	   pp->float32.tag = FLOAT32TAG;
! 	   pp->float32.rest = 0;
  	}
  	else
  	   pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 );
***************
*** 1685,1694 ****
--- 1821,1840 ----
  /* 64-bit floating point numbers are constructed by the following function.  It
     is called with a 64-bit floating point value and it returns a pointer to
     the Scheme object with that value.
+ 
+    On the Apollo Prism, it is vital that we use a function prototype,
+    so the compiler knows that the function's argument is being passed
+    in a register.  Without the prototype, the argument is read from
+    the stack.  See prism.asm for examples where it is simpler to pass
+    the argument in a register.  Also see objects.h for the declaration.
  */
  
+ #ifdef PRISM
+ TSCP sc_makefloat64( double value )
+ #else
  TSCP sc_makefloat64( value )
  	double  value;
+ #endif
  {
  	SCP  pp;
  
***************
*** 1698,1704 ****
  	   pp = sc_extobjp;
  	   sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE);
  	   sc_extobjwords = sc_extobjwords-FLOAT64SIZE;
! 	   pp->unsi.gned = FLOAT64TAG;
  	}
  	else
  	   pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 );
--- 1844,1851 ----
  	   pp = sc_extobjp;
  	   sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE);
  	   sc_extobjwords = sc_extobjwords-FLOAT64SIZE;
! 	   pp->float64.tag = FLOAT64TAG;
! 	   pp->float64.rest = 0;
  	}
  	else
  	   pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 );

*** /tmp/,RCSt1a27386	Fri Nov  9 17:26:09 1990
--- scrt/heap.h	Fri Nov  9 14:06:04 1990
***************
*** 42,51 ****
--- 42,70 ----
  /* Import definitions */
  
  #ifndef rusage
+ 
+ #ifdef apollo
+ #include <sys/time.h>
+ #else
+ #ifdef SPARC
+ #include <sys/time.h>
+ #else
+ #ifdef SUN3
+ #include <sys/time.h>
+ #else
+ #ifndef SYSV
  #include <time.h>
+ #endif
+ #endif
+ #endif
+ #endif
+ 
+ #ifndef SYSV
  #include <sys/resource.h>
  #endif
  
+ #endif
+ 
  /* This module implements the object storage storage system for SCHEME->C.
  
     Unlike most Lisp systems, it is not intended that SCHEME->C provide a
***************
*** 318,323 ****
--- 337,363 ----
  
  #ifdef VAX
  #define STACKPTR sc_processor_register( 14 )
+ #endif
+ 
+ #ifdef APOLLO
+ #define STACKPTR sc_processor_register( 7 )
+ #endif
+ 
+ #ifdef PRISM
+ extern int* prism_stack_frame(void);
+ #define STACKPTR prism_stack_frame()
+ #endif
+ 
+ #ifdef I386
+ #define STACKPTR sc_processor_register( 4 )
+ #endif
+ 
+ #ifdef SPARC
+ #define STACKPTR sc_processor_register( 0 )
+ #endif
+ 
+ #ifdef SUN3
+ #define STACKPTR sc_processor_register( 15 )
  #endif
  
  /* Some objects require cleanup actions when they are freed.  For example,

No differences encountered

*** /tmp/,RCSt1a27395	Fri Nov  9 17:26:13 1990
--- scrt/makefile-tail	Fri Nov  9 14:06:07 1990
***************
*** 34,40 ****
              scqquote.sc screp.sc \
              scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc
  
! Smisc = GGC.c GGC.h GGCprivate.h mips.s predef.sc repdef.sc sci.sc sci.c vax.s
  
  ${Sruntimec} sci.c:	${predef.sc} ${objects.h}
  
--- 34,41 ----
              scqquote.sc screp.sc \
              scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc
  
! Smisc = GGC.c GGC.h GGCprivate.h apollo.asm prism.asm mips.s predef.sc \
! 	repdef.sc sci.sc sci.c vax.s sparc.s i386.s sun3.s sparc-pragma.h
  
  ${Sruntimec} sci.c:	${predef.sc} ${objects.h}
  
***************
*** 49,54 ****
--- 50,60 ----
  .c.u:
  	${CC} -j -D${cpu} -I. $*.c
  
+ # Apollo assembler
+ .asm.o:
+ 	$(ASM) $* $(AFLAGS)
+ 	-mv $*.bin $*.o
+ 
  .s.o:
  	${CC} -c $*.s
  
***************
*** 69,75 ****
  	      -lm
  
  GGCi:		${Sruntimec} ${Sruntime} ${Aruntime} GGC.o sci.c sci.o
! 	make "CFLAGS = -DGGC ${CFLAGS}" GGCheap.o GGCscinit.o
  	${CC} -o GGCi ${CFLAGS} ${Sruntime} ${GGCCruntime} ${Aruntime} sci.o \
  	      -lXaw -lXt -lX11 -lm
  
--- 75,81 ----
  	      -lm
  
  GGCi:		${Sruntimec} ${Sruntime} ${Aruntime} GGC.o sci.c sci.o
! 	$(MAKE) "CFLAGS = -DGGC ${CFLAGS}" GGCheap.o GGCscinit.o
  	${CC} -o GGCi ${CFLAGS} ${Sruntime} ${GGCCruntime} ${Aruntime} sci.o \
  	      -lXaw -lXt -lX11 -lm
  
***************
*** 78,84 ****
  	mv Xlibsc.a libsc.a
  	
  port:
! 	make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \
  	     Xlibsc.a Xsci Xmv ${Plib}
  
  libsc_p.a:	libsc.a
--- 84,90 ----
  	mv Xlibsc.a libsc.a
  	
  port:
! 	$(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \
  	     Xlibsc.a Xsci Xmv ${Plib}
  
  libsc_p.a:	libsc.a
***************
*** 85,91 ****
  	mkdir saveobj
  	mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj
  	rm -f libsc_p.a
! 	make "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \
  	     ${Aruntime}
  	ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime}
  	ranlib libsc_p.a
--- 91,97 ----
  	mkdir saveobj
  	mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj
  	rm -f libsc_p.a
! 	$(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \
  	     ${Aruntime}
  	ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime}
  	ranlib libsc_p.a
***************
*** 127,133 ****
  	rm -f sci libsc.a libsc_p.a
  
  srcdist:
! 	rdist -c README *.c *.h *.s *.sc makefile-tail ${destdir}
  
  bindist:
  	rdist -c README makefile makefile-tail predef.sc objects.h \
--- 133,139 ----
  	rm -f sci libsc.a libsc_p.a
  
  srcdist:
! 	rdist -c README *.c *.h *.s *.sc *.asm makefile-tail ${destdir}
  
  bindist:
  	rdist -c README makefile makefile-tail predef.sc objects.h \
***************
*** 134,140 ****
  	      libsc.a ${Plib} sci ${destdir}
  
  all:
! 	make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = ${sccomp}" \
  	     Xlibsc.a Xsci Xmv ${Plib}
  
  srclinks:
--- 140,146 ----
  	      libsc.a ${Plib} sci ${destdir}
  
  all:
! 	$(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = ${sccomp}" \
  	     Xlibsc.a Xsci Xmv ${Plib}
  
  srclinks:

*** /tmp/,RCSt1a27404	Fri Nov  9 17:26:15 1990
--- scrt/objects.c	Thu Nov  1 08:05:03 1990
***************
*** 482,488 ****
  		break;
  	   case EXTENDEDTAG:
  	        if  (TX_U( p )->extendedobj.tag == FLOATTAG)
! 		   return( (int)( TX_U( p )->FLOATUTYPE.value ) );
  		break;
  	}
  	sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 );
--- 482,488 ----
  		break;
  	   case EXTENDEDTAG:
  	        if  (TX_U( p )->extendedobj.tag == FLOATTAG)
! 		   return ROUND( FLOAT_VALUE( p ) );
  		break;
  	}
  	sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 );
***************
*** 506,514 ****
  	        if  (TX_U( p )->extendedobj.tag == FLOATTAG)  {
  		   v = TX_U( p )->FLOATUTYPE.value;
  		   if  (v <= (double)(0x7fffffff))
! 		      return( (unsigned)( v ) );
  		   else
! 		      return( (unsigned)( v-((double)(0x40000000))*2.0 ) |
  		   	      0x80000000 );
  		}
  		break;
--- 506,514 ----
  	        if  (TX_U( p )->extendedobj.tag == FLOATTAG)  {
  		   v = TX_U( p )->FLOATUTYPE.value;
  		   if  (v <= (double)(0x7fffffff))
! 		      return( (unsigned)ROUND( v ) );
  		   else
! 		      return( (unsigned)ROUND( v-((double)(0x40000000))*2.0 ) |
  		   	      0x80000000 );
  		}
  		break;
***************
*** 543,551 ****
  		   case FLOATTAG:
  		      v = TX_U( p )->FLOATUTYPE.value;
  		      if  (v <= (double)(0x7fffffff))
! 		         return( (unsigned)( v ) );
  		      else
! 		         return( (unsigned)( v-((double)(0x40000000))*2.0 ) |
  		   	         0x80000000 );
  		      break;
  		}
--- 543,551 ----
  		   case FLOATTAG:
  		      v = TX_U( p )->FLOATUTYPE.value;
  		      if  (v <= (double)(0x7fffffff))
! 		         return( (unsigned int)( v ) );
  		      else
! 		         return( (unsigned int)( v-((double)(0x40000000))*2.0 ) |
  		   	         0x80000000 );
  		      break;
  		}

*** /tmp/,RCSt1a27409	Fri Nov  9 17:26:19 1990
--- scrt/objects.h	Fri Nov  9 14:06:14 1990
***************
*** 43,52 ****
  */
  
  /* Default the value of CPUTYPE if not currently defined. */
- 
  #ifndef MIPS
  #ifndef TITAN
  #ifndef VAX
  #ifdef mips
  #define MIPS 1
  #endif
--- 43,57 ----
  */
  
  /* Default the value of CPUTYPE if not currently defined. */
  #ifndef MIPS
  #ifndef TITAN
  #ifndef VAX
+ #ifndef SPARC
+ #ifndef SUN3
+ #ifndef I386
+ #ifndef APOLLO
+ #ifndef PRISM
+ 
  #ifdef mips
  #define MIPS 1
  #endif
***************
*** 56,65 ****
--- 61,95 ----
  #ifdef vax
  #define VAX 1
  #endif
+ #ifdef sun
+ #  ifdef sparc
+ #    define SPARC 1
+ #  else
+ #    ifdef mc68000
+ #      define SUN3 1
+ #    endif
+ #  endif
  #endif
+ #ifdef i386
+ #define I386 1
  #endif
+ #ifdef apollo
+ #  ifdef _ISP_A88K
+ #    define PRISM 1
+ #  else
+ #    define APOLLO 1
+ #  endif
  #endif
  
+ #endif /* PRISM */
+ #endif /* APOLLO */
+ #endif /* I386 */
+ #endif /* SUN3 */
+ #endif /* SPARC */
+ #endif /* VAX */
+ #endif /* TITAN */
+ #endif /* MIPS */
+ 
  /* The Scheme->C installer may elect to have arithmetic overflow handled
     gracefully on either the MIPS or the VAX implementations.  The default
     is to handle it.
***************
*** 80,85 ****
--- 110,116 ----
  #ifdef TITAN
  #include <setjmp.h>
  #define CPUTYPE TITAN
+ #undef MATHTRAPS
  #endif
  
  #ifdef VAX
***************
*** 96,101 ****
--- 127,174 ----
  #define CPUTYPE VAX
  #endif
  
+ #ifdef APOLLO
+ #include <setjmp.h>
+ #define CPUTYPE APOLLO
+ #define BIG_ENDIAN
+ #endif
+ 
+ #ifdef PRISM
+ /* Use our own setjmp/longjmp so we can make sure all the registers
+    are saved that need to be saved, namely, .10 through .23,
+    plus the signal mask, return PC, and PSWs.
+ 
+    The layout of these registers in the array is described in prism.asm.
+ */
+ typedef int jmp_buf[18];
+ #define CPUTYPE PRISM
+ #define BIG_ENDIAN
+ #endif
+ 
+ #ifdef SPARC
+ typedef int jmp_buf[2+7+8+8+1];
+ #define DOUBLE_ALIGN 1
+ #define CPUTYPE SPARC
+ #define BIG_ENDIAN
+ #undef MATHTRAPS
+ #define MATHTRAPS 0
+ #endif
+ 
+ #ifdef SUN3
+ #include <setjmp.h>
+ #define CPUTYPE SUN3
+ #define BIG_ENDIAN
+ #undef MATHTRAPS
+ #define MATHTRAPS 0
+ #endif
+ 
+ #ifdef I386
+ #include <setjmp.h>
+ #define CPUTYPE I386
+ #undef MATHTRAPS
+ #define MATHTRAPS 0
+ #endif
+ 
  /* The data encoding scheme is similar to that used by Vax NIL and T, where
     all objects are represented by 32-bit pointers, with a "low tag" encoded
     in the two least significant bits encoding the type.  All objects are
***************
*** 123,128 ****
--- 196,219 ----
  
  struct  STACKTRACE;
  
+ /*
+   Ugly, but machine independent way to declare and use bit fields:
+   Bit fields are declared using F?(...), where the least significant
+   fields are listed first (in honor of the original implementations).
+   Similarly, static objects are created with the U?(...) macros.
+  */
+ #ifdef BIG_ENDIAN
+ #define	F2(a,b)		b;a
+ #define F3(a,b,c)	c;b;a
+ #define U2(a,b)		(b),(a)
+ #define	U3(a,b,c)	(c),(b),(a)
+ #else
+ #define F2(a,b)		a;b
+ #define F3(a,b,c)	a;b;c
+ #define U2(a,b)		(a),(b)
+ #define U3(a,b,c)	(a),(b),(c)
+ #endif
+ 
  typedef char *TSCP;
  
  typedef union SCOBJ {		/* SCHEME to C OBJECT */
***************
*** 130,141 ****
  	      unsigned  gned;
  	   }  unsi;
  	   struct {	/* EXTENDEDOBJ */
! 	      unsigned  tag:8;
! 	      unsigned  rest:24;
  	   }  extendedobj;
  	   struct {	/* SYMBOL */
! 	      unsigned  tag:8;
! 	      unsigned  rest:24;
  	      TSCP  name;
  	      TSCP  *ptrtovalue;
  	      TSCP  value;
--- 221,232 ----
  	      unsigned  gned;
  	   }  unsi;
  	   struct {	/* EXTENDEDOBJ */
! 	      F2(unsigned  tag:8,
! 	      unsigned  rest:24);
  	   }  extendedobj;
  	   struct {	/* SYMBOL */
! 	      F2(unsigned  tag:8,
! 	      unsigned  rest:24);
  	      TSCP  name;
  	      TSCP  *ptrtovalue;
  	      TSCP  value;
***************
*** 142,172 ****
  	      TSCP  propertylist;
  	   }  symbol;
  	   struct {	/* STRING */
! 	      unsigned  tag:8;
! 	      unsigned  length:24;
  	      char  char0;
  	   }  string;
  	   struct {	/* VECTOR */
! 	      unsigned  tag:8;
! 	      unsigned  length:24;
  	      TSCP  element0;
  	   }  vector;
  	   struct {	/* PROCEDURE */
! 	      unsigned  tag:8;
! 	      unsigned  required:8;
! 	      unsigned  optional:16;
  	      TSCP  (*code)();
  	      TSCP  closure;
  	   }  procedure;
  	   struct {	/* CLOSURE */
! 	      unsigned  tag:8;
! 	      unsigned  length:24;
  	      TSCP  closure;
  	      TSCP  var0;
  	   }  closure;
  	   struct {	/* CONTINUATION */
! 	      unsigned  tag:8;
! 	      unsigned  length:24;
  	      TSCP  continuation;
  	      jmp_buf  savedstate;
  	      int  *address;
--- 233,263 ----
  	      TSCP  propertylist;
  	   }  symbol;
  	   struct {	/* STRING */
! 	      F2(unsigned  tag:8,
! 	      unsigned  length:24);
  	      char  char0;
  	   }  string;
  	   struct {	/* VECTOR */
! 	      F2(unsigned  tag:8,
! 	      unsigned  length:24);
  	      TSCP  element0;
  	   }  vector;
  	   struct {	/* PROCEDURE */
! 	      F3(unsigned  tag:8,
! 	      unsigned  required:8,
! 	      unsigned  optional:16);
  	      TSCP  (*code)();
  	      TSCP  closure;
  	   }  procedure;
  	   struct {	/* CLOSURE */
! 	      F2(unsigned  tag:8,
! 	      unsigned  length:24);
  	      TSCP  closure;
  	      TSCP  var0;
  	   }  closure;
  	   struct {	/* CONTINUATION */
! 	      F2(unsigned  tag:8,
! 	      unsigned  length:24);
  	      TSCP  continuation;
  	      jmp_buf  savedstate;
  	      int  *address;
***************
*** 174,196 ****
  	      int  word0;
  	   }  continuation;
  	   struct {	/* FLOAT32 */
! 	      unsigned  tag:8;
! 	      unsigned  rest:24;
  	      float  value;
  	   }  float32;
  	   struct {	/* FLOAT64 */
! 	      unsigned  tag:8;
! 	      unsigned  rest:24;
  	      double  value;
  	   }  float64;
  	   struct {	/* FORWARD */
! 	      unsigned  tag:8;
! 	      unsigned  length:24;
  	      TSCP  forward;
  	   } forward;
  	   struct {	/* WORDALIGN */
! 	      unsigned  tag:8;
! 	      unsigned  length:24;
  	   }  wordalign;
  	   struct {	/* PAIR */
  	      TSCP  car;
--- 265,287 ----
  	      int  word0;
  	   }  continuation;
  	   struct {	/* FLOAT32 */
! 	      F2(unsigned  tag:8,
! 	      unsigned  rest:24);
  	      float  value;
  	   }  float32;
  	   struct {	/* FLOAT64 */
! 	      F2(unsigned  tag:8,
! 	      unsigned  rest:24);
  	      double  value;
  	   }  float64;
  	   struct {	/* FORWARD */
! 	      F2(unsigned  tag:8,
! 	      unsigned  length:24);
  	      TSCP  forward;
  	   } forward;
  	   struct {	/* WORDALIGN */
! 	      F2(unsigned  tag:8,
! 	      unsigned  length:24);
  	   }  wordalign;
  	   struct {	/* PAIR */
  	      TSCP  car;
***************
*** 220,225 ****
--- 311,332 ----
  #define  TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
  #define  TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
  #endif
+ #ifdef apollo
+ #define  TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
+ #define  TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
+ #endif
+ #ifdef SPARC
+ #define  TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
+ #define  TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
+ #endif
+ #ifdef SUN3
+ #define  TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
+ #define  TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
+ #endif
+ #ifdef I386
+ #define  TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
+ #define  TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
+ #endif
  
  /* Fixed point numbers are encoded in the address portion of the pointer.  The
     value is obtained by arithmetically shifting the pointer value two bits to
***************
*** 626,633 ****
--- 733,768 ----
     When the procedure is exited, sc_stacktrace is restored.  In order to assure
     that sc_stacktrace always points to a valid entry, the list is maintained
     by subroutines (compilers want to optimize it out!).
+ 
+    In dobacktrace(), the stack is traced by calling C-UNSIGNED-REF
+    to get the prevstacktrace pointer.  The problem with this is that
+    C-UNSIGNED-REF (aka scrt4_c_2dunsigned_2dref) uses MUNSIGNED, which
+    uses T_U, which masks out the least significant two bits of the pointer.
+    The trick is to get an implementation independent method of aligning
+    the stacktrace structure.  Most compilers at least align the structure
+    with an even address, but only some will align it on a four-byte boundary.
+ 
+    The macro ALIGN4(t,x) declares "x" to be a pointer to "t", aligned on
+    a 4-byte boundary.  If nothing special needs to be done, then the default
+    definition can be used.
  */
  
+ #ifdef APOLLO
+ /* On an Apollo, things are usually aligned properly on the stack,
+    but after an interrupt, things can get screwy, and even doubles
+    can end up non-longword aligned.  To be safe, we need to align
+    everything on a longword boundary ourselves.
+ */
+ #define IDENT(a)	a
+ #define CAT(a,b)	IDENT(a)b
+ #define ALIGN4(t,x)	char CAT(x,buf)[sizeof(t) + sizeof(long)];\
+     t& x = * (t*) ((unsigned)CAT(x,buf) & ~(sizeof(long)-1))
+ #endif
+ 
+ /* the rest of the world does not need to worry about such matters */
+ #ifndef ALIGN4
+ #define ALIGN4(t,x)	t x
+ #endif
  struct  STACKTRACE {			/* Stack trace back record */
  	struct STACKTRACE*  prevstacktrace;	
  	TSCP  procname;
***************
*** 636,642 ****
  
  extern  struct STACKTRACE  *sc_stacktrace;
  
! #define  PUSHSTACKTRACE( procedure )	struct  STACKTRACE  st; \
  					sc_pushtrace( &st, (procedure) )
  
  #define  POPSTACKTRACE( exp )		return( sc_poptrace( &st, (exp) ) )
--- 771,777 ----
  
  extern  struct STACKTRACE  *sc_stacktrace;
  
! #define  PUSHSTACKTRACE( procedure )	ALIGN4(struct  STACKTRACE,  st); \
  					sc_pushtrace( &st, (procedure) )
  
  #define  POPSTACKTRACE( exp )		return( sc_poptrace( &st, (exp) ) )
***************
*** 735,740 ****
--- 870,887 ----
  #ifdef VAX
  #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
  #endif
+ #ifdef apollo
+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
+ #endif
+ #ifdef SPARC
+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
+ #endif
+ #ifdef I386
+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
+ #endif
+ #ifdef SUN3
+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
+ #endif
  
  #define PROCEDURE_REQUIRED( tscp )  (TX_U( tscp )->procedure.required)
  #define PROCEDURE_OPTIONAL( tscp )  (TX_U( tscp )->procedure.optional)
***************
*** 753,768 ****
  /* C declarations */
  
  #define DEFSTRING( name, chars, len ) \
! 	static struct { unsigned tag:8; \
! 		        unsigned length:24; \
  		        char char0[len+(4-(len % 4))]; } \
! 	name = { STRINGTAG, len, chars }
  
  #define DEFFLOAT( name, value ) \
! 	static struct { unsigned tag:8; \
! 		        unsigned length: 24; \
  		        FLOATTYPE f; } \
! 	name = { FLOATTAG, 0, value }
  
  #define DEFTSCP( name ) TSCP  name
  
--- 900,915 ----
  /* C declarations */
  
  #define DEFSTRING( name, chars, len ) \
! 	static struct { F2(unsigned tag:8, \
! 		        unsigned length:24); \
  		        char char0[len+(4-(len % 4))]; } \
! 	name = { U2(STRINGTAG, len), chars }
  
  #define DEFFLOAT( name, value ) \
! 	static struct { F2(unsigned tag:8, \
! 		        unsigned length: 24); \
  		        FLOATTYPE f; } \
! 	name = { U2(FLOATTAG, 0), value }
  
  #define DEFTSCP( name ) TSCP  name
  
***************
*** 857,870 ****
  
  /* C operators that detect integer overflow in some implementations */
  
! #if (MATHTRAPS == 0  ||  CPUTYPE == TITAN)
  #define IPLUS( a, b )		(a + b)
  #define IDIFFERENCE( a, b )	(a - b)
  #define INEGATE( a )		(- a)
  #define ITIMES( a, b )		(a * b)
- #endif
  
! #if  (MATHTRAPS  &&  (CPUTYPE == MIPS || CPUTYPE == VAX))
  #define IPLUS( a, b )		sc_iplus( a, b )
  #define IDIFFERENCE( a, b )	sc_idifference( a, b )
  #define ITIMES( a, b )		sc_itimes( a, b )
--- 1004,1017 ----
  
  /* C operators that detect integer overflow in some implementations */
  
! #if (MATHTRAPS == 0 || CPUTYPE == TITAN)
  #define IPLUS( a, b )		(a + b)
  #define IDIFFERENCE( a, b )	(a - b)
  #define INEGATE( a )		(- a)
  #define ITIMES( a, b )		(a * b)
  
! #else
! 
  #define IPLUS( a, b )		sc_iplus( a, b )
  #define IDIFFERENCE( a, b )	sc_idifference( a, b )
  #define ITIMES( a, b )		sc_itimes( a, b )
***************
*** 895,910 ****
     significant 8 bits of the extended object header.
  */
  
! #define UNKNOWNCALL( proc, argc ) (sc_unknownargc = argc, \
! 				   sc_unknownproc[ 1 ] = proc, \
! 				   sc_unknownproc[ \
! 				     (UNSI_GNED( \
! 				         sc_unknownproc[ TSCPTAG( proc ) ] ) \
! 				      == (argc*256+PROCEDURETAG)) ])
  
  /* Inline type conversions */
  
! #define FLT_FIX( flt )   C_FIXED( (int)(FLOAT_VALUE( flt )) )
  #define FIX_FLT( fix )   MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) )
  #define FIX_FLTV( fix )  ((FLOATTYPE)(FIXED_C( fix )))
  #define FLTV_FLT( flt )	 MAKEFLOAT( flt )
--- 1042,1073 ----
     significant 8 bits of the extended object header.
  */
  
! #define UNKNOWNCALL( proc, argc ) \
!     (sc_unknownargc = argc, sc_unknownproc[ 1 ] = proc, \
!     sc_unknownproc[(PROCEDURE_REQUIRED(sc_unknownproc[ TSCPTAG(proc) ]) == argc\
! 		    && ! PROCEDURE_OPTIONAL(sc_unknownproc[ TSCPTAG( proc )]))])
! /* UNSI_GNED(sc_unknownproc[ TSCPTAG( proc ) ] ) \
! 		    == (argc*256+PROCEDURETAG)) ])
! */
  
  /* Inline type conversions */
  
! /* round a floating point number to the nearest integer */
! #ifdef apollo
! #include <math.h>
! /* Apollo SR10.2, with cc 6.7: rint() returns a bogus value (e.g., 0.9
!    is "rounded" to 0.899902).
!    If Apollo does not fix rint() soon, then we should write our own.
! */
! #define rint(x)		floor((x) + 0.5)
! #define ROUND(x)	((int) rint(x))
! #endif
! 
! #ifndef ROUND
! #define ROUND(x)	((int) (x))
! #endif
! 
! #define FLT_FIX( flt )   C_FIXED( ROUND(FLOAT_VALUE( flt )) )
  #define FIX_FLT( fix )   MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) )
  #define FIX_FLTV( fix )  ((FLOATTYPE)(FIXED_C( fix )))
  #define FLTV_FLT( flt )	 MAKEFLOAT( flt )
***************
*** 953,960 ****
--- 1116,1132 ----
     definitions needed by a SCHEME->C program.
  */
  
+ #ifdef PRISM
+ /* As explained in heap.c, it is important to declare the function prototype,
+    so the compiler passes the floating point argument in a register, rather
+    than on the stack.
+ */
+ extern  TSCP  sc_makefloat32(float);
+ extern  TSCP  sc_makefloat64(double);
+ #else
  extern  TSCP  sc_makefloat32();
  extern  TSCP  sc_makefloat64();
+ #endif
  extern  TSCP  sc_cons();
  extern  int  sc_unknownargc;
  extern  TSCP  sc_unknownproc[ 4 ];

*** /tmp/,RCSt1a27478	Fri Nov  9 17:26:44 1990
--- scrt/scinit.c	Fri Nov  9 14:06:20 1990
***************
*** 70,78 ****
  #include <vax/vmparam.h>
  #define STACKBASE (int*)USRSTACK
  #endif
  
- #include <sys/file.h>
  #include <sys/types.h>
  #include <sys/uio.h>
  #include <strings.h>
  #include <varargs.h>
--- 70,106 ----
  #include <vax/vmparam.h>
  #define STACKBASE (int*)USRSTACK
  #endif
+ #ifdef apollo
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #include <sys/param.h>
+ /* the stack back moves depending on shared libraries */
+ #include <apollo/base.h>
+ #include <apollo/error.h>
+ #include <apollo/proc2.h>
+ static proc2_$info_t sc_apollo_proc2;
+ #define STACKBASE ((int*) sc_apollo_proc2.stack_base)
+ #endif
+ #ifdef SPARC
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #include <sun4/vmparam.h>
+ #define STACKBASE (int*)USRSTACK
+ #endif
+ #ifdef SUN3
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #include <sun3/param.h>
+ #include <sun3/vmparam.h>
+ #define STACKBASE (int*)USRSTACK
+ #endif
+ #ifdef ISC386IX
+ #define ETEXT	((int)&etext)	/* First address after text */
+ #include <sys/types.h>
+ #include <sys/fcntl.h>		/* probably should be elsewhere */
+ #include <sys/immu.h>
+ #define STACKBASE (int*)UVSTACK
+ #endif
  
  #include <sys/types.h>
+ #include <sys/file.h>
  #include <sys/uio.h>
  #include <strings.h>
  #include <varargs.h>
***************
*** 96,103 ****
  
  /* Global data structure for this module. */
  
! static int  emptyvector = VECTORTAG,
!             emptystring[2] = {STRINGTAG, 0};
  
  FILE   *sc_stdin,	/* Standard I/O Subroutine FILE pointers */
         *sc_stdout,
--- 124,135 ----
  
  /* Global data structure for this module. */
  
! /* this struct must look like an SCOBJ */
! static struct
! {
!     F2(unsigned  tag:8,
!     unsigned  length:24);
! } emptyvector, emptystring[2];
  
  FILE   *sc_stdin,	/* Standard I/O Subroutine FILE pointers */
         *sc_stdout,
***************
*** 183,188 ****
--- 215,221 ----
  
  static  init_procs()
  {
+ #ifndef SYSV
          INITIALIZEVAR( U_TX( ADR( t1030 ) ), 
                         ADR( sc_my_2drusage_v ), 
                         MAKEPROCEDURE( 0, 
***************
*** 192,197 ****
--- 225,231 ----
                         MAKEPROCEDURE( 0, 
                                        0, 
                                        sc_collect_2drusage, EMPTYLIST ) );
+ #endif
          INITIALIZEVAR( U_TX( ADR( t1034 ) ), 
                         ADR( sc_collect_v ), 
                         MAKEPROCEDURE( 0, 
***************
*** 288,293 ****
--- 322,340 ----
  	char  *freebase;
  	TSCP  unknown;
  
+ #ifdef apollo
+ 	/* on an apollo, we get the stack top at run time */
+ 	uid_$t me;
+ 	status_$t status;
+ 	proc2_$who_am_i(&me);
+ 	proc2_$get_info(me, &sc_apollo_proc2, sizeof(sc_apollo_proc2), &status);
+ 	if (status.all != status_$ok && status.all != proc2_$is_current)
+ 	{
+ 	    error_$print(status);
+ 	    exit(2);
+ 	}
+ #endif
+ 
  	if  (sc_gcinfo)
  	   fprintf( stderr, "***** SCGCINFO = %d  SCHEAP = %d  SCLIMIT = %d\n",
  	   	    sc_gcinfo, scheap, sclimit );
***************
*** 319,324 ****
--- 366,373 ----
  	sc_mutex = 0;
  	sc_pendingsignals = 0;
  	sc_emptylist = EMPTYLIST;
+ 	emptyvector.tag = VECTORTAG;
+ 	emptystring[0].tag = STRINGTAG;
  	sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG );
  	sc_emptystring = U_T( emptystring, EXTENDEDTAG );
  	sc_falsevalue = FALSEVALUE;
***************
*** 557,562 ****
--- 606,617 ----
  	if  (scheap < save.heappages/(ONEMB/PAGEBYTES))
  	   scheap = save.heappages/(ONEMB/PAGEBYTES);
  	if  (sclimit < save.limit)  sclimit = save.limit;
+ #ifdef sun
+ 	/* in SunOS, stderr is line buffered, which causes some unwanted */
+ 	/* malloc..  */
+ 	if (sc_gcinfo)
+ 	    setbuf(stderr, (char*)0);
+ #endif
  	if  (sc_gcinfo)
  	   fprintf( stderr, "***** SCGCINFO = %d  SCHEAP = %d  SCLIMIT = %d\n",
  		    sc_gcinfo, scheap, sclimit );
***************
*** 602,607 ****
--- 657,664 ----
  	sc_mutex = 0;
  	sc_pendingsignals = 0;
  	sc_emptylist = EMPTYLIST;
+ 	emptyvector.tag = VECTORTAG;
+ 	emptystring[0].tag = STRINGTAG;
  	sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG );
  	sc_emptystring = U_T( emptystring, EXTENDEDTAG );
  	sc_falsevalue = FALSEVALUE;
***************
*** 702,707 ****
--- 759,765 ----
  	scrt6_error( sc_string_2d_3esymbol( sc_cstringtostring( symbol ) ),
  		     sc_cstringtostring( format ),
  		     scrt1_reverse( argl ) );
+ 	va_end( argp );
  }
  
  /* The following function returns informations about the implementation.  The
***************
*** 730,735 ****
--- 788,806 ----
  #ifdef VAX
  		    sc_cstringtostring( "VAX" ),
  #endif
+ #ifdef apollo
+ 		    sc_cstringtostring( "Apollo" ),
+ #endif
+ #ifdef SPARC
+ 		    sc_cstringtostring( "Sun4/SPARC" ),
+ #endif
+ #ifdef SUN3
+ 		    sc_cstringtostring( "Sun3" ),
+ #endif
+ #ifdef I386
+ 		    sc_cstringtostring( "AT/386" ),
+ #endif
+ 
  		    sc_cons(
  #ifdef MIPS
  		       sc_cstringtostring( "R2000" ),
***************
*** 740,747 ****
--- 811,853 ----
  #ifdef VAX
  		       sc_cstringtostring( "VAX" ),
  #endif
+ #ifdef APOLLO
+ 		       sc_cstringtostring( "68K" ),
+ #endif
+ #ifdef PRISM
+ 		       sc_cstringtostring( "PRISM" ),
+ #endif
+ #ifdef SPARC
+ 		       sc_cstringtostring( "SPARC" ),
+ #endif
+ #ifdef SUN3
+ 		       sc_cstringtostring( "68K" ),
+ #endif
+ #ifdef I386
+ 		       sc_cstringtostring( "Intel 386" ),
+ #endif
  		       sc_cons(
+ #ifdef apollo
+ 		          sc_cstringtostring( "Domain/OS" ),
+ #else /* ! apollo */
+ #ifdef SPARC
+ #ifdef sun
+ 			  sc_cstringtostring( "SunOS" ),
+ #else
+ 			  sc_cstringtostring( "SparcOS" ),
+ #endif /* sun */
+ #else /* ! SPARC */
+ #ifdef SUN3
+ 			  sc_cstringtostring( "SunOS" ),
+ #else
+ #ifdef SYSV
+ 			  sc_cstringtostring( "System V.3.2" ),
+ #else
  		          sc_cstringtostring( "ULTRIX" ),
+ #endif /* SYSV */
+ #endif /* SUN3 */
+ #endif /* SPARC */
+ #endif /* apollo */
  		          sc_cons(
  			      FALSEVALUE,
  			      EMPTYLIST

*** /tmp/,RCSt1a27560	Fri Nov  9 17:27:16 1990
--- scrt/signal.c	Fri Nov  9 14:06:25 1990
***************
*** 49,54 ****
--- 49,57 ----
  #include "apply.h"
  #include "signal.h"
  #include "/usr/include/signal.h"
+ #ifdef apollo
+ #include <apollo/base.h>
+ #endif
  
  extern TSCP  scrt4_onsignal2();
  
***************
*** 118,124 ****
--- 121,131 ----
  	}
  	else  {
  	   /* Signal must be defered */
+ #ifdef SYSV
+ 	   sighold( signal );
+ #else
  	   sigblock( 1<<signal );
+ #endif
  	   pendingsignals = pendingsignals | (1<<signal);
  	   if  (gcinprogress == 0)  sc_pendingsignals = 1;
  	}
***************
*** 150,162 ****
  	/* Send the pending signals and exit the critical section */
  	sc_pendingsignals = 0;
  	self = getpid();
  	oldmask = sigblock( -1 ) & ~pendingsignals;
  	for  (i = 0; i < 32; i++)
! 	   if  (pendingsignals & (1<<i))  kill( self, i );
  	pendingsignals = 0;
  	sc_mutex = 0;
  	sigsetmask( oldmask );
! 
  	/* Apply the when-unreferenced procedures */
  	while  (freed != EMPTYLIST)  {
  	   object_procedure = PAIR_CAR( freed );
--- 157,178 ----
  	/* Send the pending signals and exit the critical section */
  	sc_pendingsignals = 0;
  	self = getpid();
+ #ifndef SYSV
  	oldmask = sigblock( -1 ) & ~pendingsignals;
+ #endif
  	for  (i = 0; i < 32; i++)
! 	  if  (pendingsignals & (1<<i)) {
! #ifdef SYSV
! 	    sigrelse( i );
! #endif
! 	    kill( self, i );
! 	  }
! 
  	pendingsignals = 0;
  	sc_mutex = 0;
+ #ifndef SYSV
  	sigsetmask( oldmask );
! #endif
  	/* Apply the when-unreferenced procedures */
  	while  (freed != EMPTYLIST)  {
  	   object_procedure = PAIR_CAR( freed );
***************
*** 186,192 ****
  	int sig, code;
  	struct sigcontext *scp;
  {
! #if  (TITAN || (MATHTRAPS == 0))
  	sc_error( "???? (in sc_trap_handler)", "Floating point exception", 0 );
  #endif
  
--- 202,208 ----
  	int sig, code;
  	struct sigcontext *scp;
  {
! #if (TITAN || (MATHTRAPS == 0))
  	sc_error( "???? (in sc_trap_handler)", "Floating point exception", 0 );
  #endif
  
***************
*** 229,234 ****
--- 245,279 ----
  		     C_FIXED( code ));
  	}
  #endif	
+ #ifdef apollo
+ 	if  (sig == SIGFPE)  {
+ 	   if  (code == FPE_INTDIV_TRAP  ||  code == FPE_FLTDIV_FAULT  ||
+ 		code == FPE_FLTDIV_TRAP)
+ 		     /***** divide by zero exception *****/
+ 		     sc_error ("?????", "Divide by zero", 0);
+ 	   if  (code == FPE_FLTOVF_TRAP  ||  code == FPE_FLTOVF_FAULT)
+ 		     /***** floating point overflow *****/
+ 		     sc_error ("?????", "Overflow", 0);
+ 	   if  (code == FPE_FLTUND_FAULT  ||  code == FPE_FLTUND_TRAP)
+ 		     /***** floating point underflow *****/
+ 		     sc_error ("?????", "Underflow", 0);
+ 	   sc_error ("?????", "Floating point exception: ~s", 1,
+ 		     C_FIXED( code ));
+ 	}
+ 	else if (sig == SIGAPOLLO) {
+ 	    status_$t status;
+ 	    char *subsys, *module, *error;
+ 	    short lsubsys, lmodule, lerror;
+ 	    char buffer[256];
+ 
+ 	    status.all = code;
+ 	    error_$find_text(status, &subsys, &lsubsys, &module, &lmodule,
+ 			     &error, &lerror);
+ 	    sprintf(buffer, "%.*s (%.*s/%.*s)", lerror, error,
+ 		    lsubsys, subsys, lmodule, module);
+ 	    sc_error("?????", buffer, 0);
+ 	}
+ #endif	
  	
  	/***************************************
  	  other possibly recoverable exceptions
***************
*** 391,397 ****
  
  sc_mathtraps()  {
  	signal(SIGFPE, sc_trap_handler);
! #if MIPS
  	signal(SIGTRAP, sc_trap_handler);
  #endif
  }
--- 436,442 ----
  
  sc_mathtraps()  {
  	signal(SIGFPE, sc_trap_handler);
! #ifdef MIPS
  	signal(SIGTRAP, sc_trap_handler);
  #endif
  }

*** /tmp/,RCSt1a27697	Fri Nov  9 17:28:02 1990
--- scsc/makefile-tail	Thu Nov  1 08:05:18 1990
***************
*** 46,52 ****
  	mv Xsccomp.heap sccomp.heap
  
  port:
! 	make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \
  	     Xsccomp.heap Xmv
  
  install-private:
--- 46,52 ----
  	mv Xsccomp.heap sccomp.heap
  
  port:
! 	$(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \
  	     Xsccomp.heap Xmv
  
  install-private:
***************
*** 94,100 ****
  	rdist -c sccomp makefile-tail makefile ${destdir}
  
  all:
! 	make Xsccomp.heap Xmv
  
  srclinks:
  	for x in ${scsc} ${scc} ${scsch}; \
--- 94,100 ----
  	rdist -c sccomp makefile-tail makefile ${destdir}
  
  all:
! 	$(MAKE) Xsccomp.heap Xmv
  
  srclinks:
  	for x in ${scsc} ${scc} ${scsch}; \

*** /tmp/,RCSt1a27954	Fri Nov  9 17:29:14 1990
--- xlib/makefile	Thu Nov  1 08:05:21 1990
***************
*** 91,97 ****
  	rm -f *.o scixl scxl.a hello puzzle clear
  
  all:
! 	make scixl scxl.a
  
  gensource:
! 	make ${xwssc} ${xwsc}
--- 91,97 ----
  	rm -f *.o scixl scxl.a hello puzzle clear
  
  all:
! 	$(MAKE) scixl scxl.a
  
  gensource:
! 	$(MAKE) ${xwssc} ${xwsc}