What is it? =========== This file is set of patches for the 01nov91 version of the Scheme->C system with the MCC01-01nov91.patches applied. These patches do 3 primary things: 1. Correct support for some machines and fix a minor bug reading floating point numbers. 2. Add support for the HP9000/700 (aka snake), the HP9000/300 (the 68k based HP s), the SONY-NEWS machine, and partial support for the IBM RS/6000. 3. Include some features that were developed here at MCC, including CATCH/THROW functions, opaque objects, a simple object system using opaque objects, and a different interface to external C functions. The MCC additions are documented more fully in the file MCC-additions in the top level directory after this patch is applied. As with the MCC01 patch, most of this work is not mine. I simply integrated things other people posted or sent to me. I was a member of the development team here at MCC that produced the MCC additions. I have verified this patch on the following machine/OS combinations: Sun4 - SunOS 4.1.1 Sun4 - SunOS 4.1.3 Sun3 - SunOS 4.1.1 DEC DS/5000-200 - ULTRIX V4.3 HP 9000/750 - HP-UX 8.05 How to use it. ============== This patch was generated against the 01nov91 version of Scheme->C with the MCC01-01nov91.patches patch applied. If this is a first time build, execute steps 1 and 2 in the MCC01-01nov91.patches file. Once you have a directory that contains the 01nov91 version with the MCC01 patch applied, follow the following steps to create a working version with the MCC02 patch applied. 1. cd into the top directory of the distribution. You should see something like this from "ls -F" if you executed the commands as given in the MCC01 patch file: APOLLO MIPS.MCC SUN3 makefile-tail APOLLO.MCC NeXT SUN3.MCC makefile-tail.MCC CHANGES NeXT.MCC VAX makefile.MCC I386 PRISM VAX.MCC scheme/ I386.MCC PRISM.MCC cdecl/ scrt/ ISC386IX README doc/ scsc/ ISC386IX.MCC SPARC gnuemacs/ test/ MIPS SPARC.MCC makefile xlib/ 2. Run the patch file through the patch program, like this ("this" assumes the patch file lives in the directory that is one level up from the top of the distribution): patch -s -p -b ".MCC02" ../MCC02-01nov91.patches Unless there is a problem with a file, the patch program will not print any messages. You may see some messages of the form: mkdir: cannot make directory `scrt': File exists This is OK, its just patch trying to make a directory that already exists. If any other problems were reported by patch you will have to correct the problem by hand. (I tried the patch on the above machines and it works for me :-) 3. Edit the top level makefile-tail (./makefile-tail) to fix up the definition of SRCDIR at a minimum. You may also want to change the various *DIR, *BIN, and *LIB macros that are appropriate for your environment. 4. Run a "make for" command, where ARCH is one of APOLLO HP300 HP700 I386 ISC386IX MIPS NeXT PRISM RS6000 SONYNEWS SPARC SUN3 TITAN or VAX. This will create the $(CPUDIR) directory, if it does not exist. It will then create a tree of symbolic links to all the necessary files in the distribution. [ If you can accept the values for CPUDIR that already exist in the makefile, you can just say "make for SRCDIR=$PWD" where $PWD has a valid pathname to the current directory] 5. cd into $(CPUDIR) which you set in #3 above or was generated by the setting of SRCDIR in #4 above. 6. Do a "make port" 7. Verify the build as in step #4 in the README file. I also suggest running more tests. This can be done like this: 4 >cd test 5 >../scrt/sci Scheme->C -- 01nov91jfb+MCC01 ... > (load "test.sc") MODULE form ignored (DEFINE-EXTERNAL TEST-ERRORS TESTCHK) TEST LOAD-TESTS "test.sc" > (load-tests) . lots of messages . > (test) ***** Begin Scheme->C Tests ***** . . ***** End Scheme->C Tests 0 Errors ***** #F > ^D 6 >make test 7 >./test 8 >cd .. You can also test the compiler by doing a "make test" in the test directory and then executing the "./test" program. It should produce the same results as the "(test)" above. 8. Because these patches modify some of the Scheme (.sc) files in the original distribution, the corresponding .c files need to be recompiled/rebuilt. This can be done with the command "make all". 9. Re-verify the system as in #7 above. More comments ============= Like I said, much of this work is not mine. I simply took all the patches others produced for the 01nov91 version and integrated them. Here is a list of the authors of the various patches I have integrated: SPARC - rec@arris.com (Roger Critchlow) I386 - rec@arris.com (Roger Critchlow) SUN3 - Mikael Pettersson APOLLO - Ray Lischner {uunet,decwrl}!mntgfx!lisch or lisch@mentor.com PRISM - Ray Lischner {uunet,decwrl}!mntgfx!lisch or lisch@mentor.com Sony News 3200 - Christian Queinnec queinnec@poly.polytechnique.fr NeXT - I don't have the name of the original author/porter of Scheme->C for the NeXT system. I must have lost the original posting to comp.lang.scheme. :-( However, David Broman (davbro@poincare.geom.umn.edu) and Scott S. Bertilson (scott@poincare.geom.umn.edu) tested my integration of the NeXT patches for the 28sep90 version. HP700 - osborne@merl.com (Randy Osborne) HP300 - eckelkamp@mcc.com (David Eckelkamp (me!)) RS/6000 - eckelkamp@mcc.com (David Eckelkamp (me!)) I am not able to verify the I386, PRISM, NeXT, APOLLO nor the Sony version of the system. I don't have access to those kinds of machines. The I386 patches seemed to mix conditionals between the 386 and SysV. It would be nice if someone with a 386 and SysV could figure out what things are SysV requirements. There are more SysV problems, though. You should look at the README that originally came with Critchlow's SPARC-I386 patches. The HP700 version appears to touch a bug in the C compiler I have access to. When compiling test02.sc in the test subdirectory this message is generated: cc: "test02.c", line 93: Internal error 4262: Investigation required \ - Please contact HP Support. The scheme compiler is able to compile and build executables from other test cases, though. The support for the RS/6000 is not complete. It compiles and runs many of the tests. It fails when trying to invoke a continuation that requires restoration of the stack (the continuation is not currently on the stack). It appears that the RS/6000 requires the stack to be valid before a longjmp can occur, whereas other machines do not. This problem can probably be circumvented, but it will require some assembly language routines and more knowledge than I possess on the internals of the RS/6000. The next version of Scheme->C may be easier to port to the RS/6000. I have not tried to integrate the AMIGA port that Mike Meyer (mwm@wse.dec.com) provided for the 01nov91 version of Scheme->C. Mostly it is because I forgot about that work, again. :-( Conclusion ========== I hope you find these changes useful. If you have any problems please let me know. I may not be able to respond immediately because my primary job does not include scheme work anymore; but I will try to respond. I appreciate any comments that you might have, good or bad. You can reach me via eckelkamp@mcc.com or uunet!cs.utexas.edu!milano!davide. ____________________________________________________________________________ David Eckelkamp Microelectronics and Computer Technology Corp. (MCC) eckelkamp@mcc.com 3500 W. Balcones Center Dr. (512) 343-0978 Austin,TX 78759 Another try at MCC02 *** /dev/null Mon Nov 30 15:30:41 1992 --- HP300 Mon Nov 30 10:21:34 1992 *************** *** 0 **** --- 1,33 ---- + # + # This is the header file for constructing make files for the HP 9000/300 + # + + SHELL=/bin/sh + + .SUFFIXES: + .SUFFIXES: .o .c .sc .s + + # Processor name: + + cpu = HP300 + + # Default flags to use when invoking the C compiler. + + CFLAGS = +O1 + CC = cc + CLIBS = -lm + + # Assembly language object files. + + Aruntime = hp300.o + + # Profiled library + + Plib = + + # Heap size in megabytes for the compiler. + + + scheapmb = 6 -scl 40 + + # End of HP900s300 header. *** /dev/null Mon Nov 30 15:30:42 1992 --- HP700 Mon Nov 30 13:48:08 1992 *************** *** 0 **** --- 1,33 ---- + # + # This is the header file for constructing make files for the HP 9000/700 + # + + SHELL=/bin/sh + + .SUFFIXES: + .SUFFIXES: .o .c .sc .s + + # Processor name: + + cpu = HP700 + + # Default flags to use when invoking the C compiler. + + CFLAGS = -O + CC = cc + CLIBS = -lm + + # Assembly language object files. + + Aruntime = hp700.o + + # Profiled library + + Plib = + + # Heap size in megabytes for the compiler. + + + scheapmb = 6 -scl 40 + + # End of HP700 (aka PARISC) header. *** /dev/null Mon Nov 30 15:30:44 1992 --- MCC-additions Mon Nov 30 10:21:35 1992 *************** *** 0 **** --- 1,244 ---- + + + Scheme->C Modification Summary + + + Opaque Objects + ============== + + Opaque objects were introduced in order to extend the type system to + accommodate C objects (structs) returned by the C interface system + (see below). The cdecl typing technique of a list whose car is the + type symbol was found to be too insecure. + + These new Scheme objects contain two pointers: a pointer to a symbol + (its type), and a pointer to a body (its value). One can read and + write these fields, and the collector can push through to their + values. An opaque object is created by: + + (make-opaque-object ) + + where is a symbol and is anything. The fields can be read and + written: + + (opaque-type ) + (set-opaque-type! ) + + (opaque-body ) + (set-opaque-body! ) + + and finally, there is the type predicate: + + (opaque? ) + + from which new secure type predicates can be formed: + + (define (foo? o) (and (opaque? o) (eq? (opaque-type o) 'foo))) + + Opaque objects can have a customized external representation (we + needed to write and read a C struct, for example). When an opaque + object is written, the *opaque-write-procedure* property of the type + symbol is examined to see if it has a procedure value. If so, that + procedure is applied to the opaque object, and returns a Scheme + expression representing the body. This expression is written within a + special syntax. For example, if a write-procedure evaluation for an + opaque object of type 'foo' results in '("hi" 42)', then this would be + written: + + #~(foo ("hi" 42)) + + The #~ syntax cues the reader to likewise look up an input conversion + function (the *opaque-read-procedure* property) which (if found) is + applied to an opaque-object containing the external representation. + This function should return a new body value to be inserted + into the object. The following code shows a real-life example: + + + ;;--------------------------------------------- pcsdesc-input-conversion + + (define (pcsdesc-input-conversion d) + (if (not (isa-pcsdescp? d)) + (error 'PCSDESC-INPUT-CONVERSION "argument no a PCS descriptor: ~S" d) + (let* ((body (opaque-body d)) + (host (check-arg (car body) string? "a string")) + (host-name-len (string-length host)) + (addr (check-arg (cadr body) string? "a string")) + (host-addr-len (string-length addr)) + (pid (check-arg (caddr body) integer? "a pid number")) + (port (check-arg (cadddr body) integer? "a port number")) + (tid (check-arg (cadr (cdddr body)) integer? "a tid number")) + (desc (make-pcsdesc)) ) + (do ((i 0 (+ i 1))) + ((>= i host-name-len)) + (pcsdesc-host! desc i (char->integer (string-ref host i))) ) + (do ((i 0 (+ i 1))) + ((>= i host-addr-len)) + (pcsdesc-addr! desc i (char->integer (string-ref addr i))) ) + (pcsdesc-pid! desc pid) + (pcsdesc-port! desc port) + (pcsdesc-tid! desc tid) + (opaque-body desc)))) + + (putprop 'pcsdescp '*opaque-read-procedure* pcsdesc-input-conversion) + + + ;;------------------------------------------- pcsdesc-output-conversion + + (define (pcsdesc-output-conversion d) + (let* ((desc (check-arg d isa-pcsdescp? "a PCS descriptor"))) + (list (pcsdesc-host-string desc) (pcsdesc-addr-string desc) + (pcsdesc-pid desc) (pcsdesc-port desc) (pcsdesc-tid desc)) )) + + (putprop 'pcsdescp '*opaque-write-procedure* pcsdesc-output-conversion) + + + An opaque object can also specify an evaluation function as the + *opaque-eval-procedure* property of its type symbol. This procedure is + passed the object, and returns the result of its evaluation. If no + such property is available, the opaque object is "self-evaluating". + + The opaque object changes touch object.h, object.c, scinit.c, heap.c, + scrt1.sc, predef.sc, scrt7.sc, and sceval.sc. + + + + C-interface + =========== + + The C-interface module is an adaptation of the cdecl system which + implements typedefs and externs as macros. This allows the c-interface + specifications to be intermixed with Scheme in a conventional Scheme + source file. This was seen as rather more convenient than the cdecl + approach, which pre-processes special-purpose files. The major problem + with cdecl, from our perspective, was that an addition or deletion of + a typedef or extern statement required a change to the system + construction (makefiles). We also added support for enum types. + + + + Catch(throw) + ============ + + A "catch" function has been added to callcc.c. This is derived from + the call/cc code, except that it does NOT save the stack (it DOES + save the display). The syntax is the same as call/cc: + + (catch (lambda (throw) + + (if + (throw ) + ...))) + + This is for implementing fast(er) exception handlers. If the throw + procedure is saved and invoked from out-of-stack (from another + continuation), an error is signalled. + + + + Object System + ============= + + A single-inheritance object system has been implemented entirely in + Scheme. It's design derives from several requirements which are + (perhaps) unique to our environment, but which may be shared by + others. To wit, small object size, small generated code, high + performance. The object system run-time support code MUST be + compiled in order to achieve high performance, but in compiled form, + it out-performs (compiled) object systems based on closures, even + for interactively defined objects. It uses *much* less data + space as well. + + + + System File Tasks and System Idle Tasks + ======================================= + + MCC modification to Scheme->C engine to enhance DEFINE-SYSTEM-FILE-TASK + support and to add "system idle task" support for additional event + processing that may not be explicitly associated with a file descriptor. + These enhancements were done in a manner that is fully backward-compatible + with the previous version of DEFINE-SYSTEM-FILE-TASK. + + Each System File Task may now be separately designated as "maskable" or + "non-maskable". This is used to designate whether the task may be + inhibited (masked) when SYSTEM-TASKING is turned off with + ENABLE-SYSTEM-FILE-TASKS, for example, when Scheme enters the debugger. + An optional final argument was added to DEFINE-SYSTEM- + FILE-TASK. (This change provides compatibity with any existing software + that uses DEFINE-SYSTEM-FILE-TASK). + + (DEFINE-SYSTEM-FILE-TASK

[]) + The designated tasks are associated with a system file number + by this procedure. The tasks are deleted by passing #F for + each task procedure. The optional arg, if #T, + designates the file task as nonmaskable. + + Also, SET-SYSTEM-FILE-TASK-MASKABLE was added to support changing the maskable + state of an existing system file task. + + (SET-SYSTEM-FILE-TASK-MASKABLE ) + Sets the maskable state of a system file task. + + In addition to System File Tasks, there are often cases where other operations + should be performed during the event loop, but the operations are not directly + associated with a UNIX system file descriptor. Therefore, DEFINE-SYSTEM-IDLE-TASK + was added for these cases. It is used to define tasks that are to be performed + just prior to the process system file tasks (and possibly blocking to wait for + further input through a call to select.) + + (DEFINE-SYSTEM-IDLE-TASK []) => + Defines a system idle task. DEFINE-SYSTEM-IDLE-TASK returns a "task + identifier" which is used as a "handle" for this task in other + operations. The idle task lambda/procedure must provide + a return value that indicates whether or not it has more processing + to do. #T indicates that it has further processing to do (but other + tasks are to be given a chance to execute). #F indicates that it has + no further processing to do at this time. + + (SET-SYSTEM-IDLE-TASK-MASKABLE ) + This is is used to change the maskable status of a designated task. + + (CANCEL-SYSTEM-IDLE-TASK ) + This is used to cancel a system idle task. + + Three functions were added for selective control of the event processing loop + (in WAIT-SYSTEM-FILE). On some occasions, it is undesirable to permit the + event loop to block, waiting for further input from a file descriptor, for + example when there are other pending operations that could take place in + a system FILE idle task or a system idle task. SYSTEM-TASK-BLOCK, SYSTEM-TASK- + NOBLOCK and SYSTEM-TASK-NOBLOCK-ON-SIGIO were added for assisting in dealing + with these less common event handling situations. + + (SYSTEM-TASK-BLOCK) + This is a function that requests the NEXT select call (within SYSTEM- + TASK-SELECT inside WAIT-SYSTEM-FILE) to block, waiting for input, if + nothing is available. + + (SYSTEM-TASK-NOBLOCK) + This is a function that requests the NEXT select call (within SYSTEM- + TASK-SELECT inside WAIT-SYSTEM-FILE) to NOT block, when no input is + available. + + (SYSTEM-TASK-NOBLOCK-ON-SIGIO) + This is a function that registers a SIGIO signal handler that causes + the NEXT select call (from within SYSTEM-TASK-SELECT inside WAIT- + SYSTEM-FILE) to be a non-blocking select whenever a SIGIO signal + occurs. The handler subsequently invokes the previously registered + (shadowed) SIGIO handler. + + These MCC system file task-related changes were made to be fully backwards + compatible with the previous DEFINE-SYSTEM-FILE-TASK and related functions + and args. + + EVENT PROCESSING: When there are no characters available on a port via + a File Descriptor (FD), the I/O system executes "system idle tasks" (not + associated with an FD) followed by "system file idle tasks" (associated + with an FD) and then followed by "system file tasks" (as a result of FD + activity) and then continues reading from the port FD when some read + completes. + (1) System idle tasks and system file tasks never interrupt an + executing Scheme program. + (2) System idle tasking and system file tasking are disabled while + in the debugger (with the exception of non-maskable tasks). + (3) All pending system file tasks are executed before continuing reads + from the port. *** /dev/null Mon Nov 30 15:30:48 1992 --- RS6000 Thu Feb 13 13:59:52 1992 *************** *** 0 **** --- 1,30 ---- + # + # This is the header file for constructing make files for IBM RS/6000 + # + + .SUFFIXES: + .SUFFIXES: .o .c .sc .s .u + + # Processor name: + + cpu = RS6000 + + # Default flags to use when invoking the C compiler. + + CFLAGS = -O + CC = cc + CLIBS = -lbsd -lm + + # Assembly language object files. + + Aruntime = + + # Profiled library + + Plib = + + # Heap size in megabytes for the compiler. + + scheapmb = 8 -scl 40 + + # End of RS6000 header. *** /dev/null Mon Nov 30 15:30:49 1992 --- SONYNEWS Thu Dec 12 15:18:33 1991 *************** *** 0 **** --- 1,30 ---- + # + # This is the header file for constructing make files for SONYNEWS processors. + # + + .SUFFIXES: + .SUFFIXES: .o .c .sc .s .u + + # Processor name: + + cpu = SONYNEWS + + # Default flags to use when invoking the C compiler. + + CFLAGS = -O2 -Olimit 1050 + CC = cc + CLIBS = -lm + + # Assembly language object files. + + Aruntime = mips.o + + # Profiled library + + Plib = + + # Heap size in megabytes for the compiler. + + scheapmb = 8 -scl 40 + + # End of SONYNEWS header. *** 1.3 1991/10/24 22:16:56 --- makefile 1992/11/30 16:21:36 *************** *** 2,9 **** # This file is used to make the Scheme->C system for multiple processor types. # #SRCDIR = /usrwrl/Gen/src/schemetoc ! SRCDIR = $${PWD:=`pwd`} MIPSDIR = /wrl/pmax/src/schemetoc MIPSBIN = /wrl/pmax/bin --- 2,11 ---- # This file is used to make the Scheme->C system for multiple processor types. # + SHELL=/bin/sh + #SRCDIR = /usrwrl/Gen/src/schemetoc ! SRCDIR = ${PWD} MIPSDIR = /wrl/pmax/src/schemetoc MIPSBIN = /wrl/pmax/bin *************** *** 41,49 **** NeXTBIN = /usr/local/bin NeXTLIB = /usr/local/lib # 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 ISC386IX MIPS NeXT PRISM SPARC SUN3 TITAN VAX # Architecture specific directories and links to the source files are # constructed by the following commands which follow: --- 43,68 ---- NeXTBIN = /usr/local/bin NeXTLIB = /usr/local/lib + SONYNEWSDIR = ${SRCDIR}/news_mips + SONYNEWSBIN = /usr/local/bin + SONYNEWSLIB = /usr/local/lib + + HP300DIR = ${SRCDIR}/hp300 + HP300BIN = ${SRCDIR}/bin.hp300 + HP300LIB = ${SRCDIR}/lib.hp300 + + HP700DIR = ${SRCDIR}/hp700 + HP700BIN = ${SRCDIR}/bin.hp700 + HP700LIB = ${SRCDIR}/lib.hp700 + + RS6kDIR = ${SRCDIR}/rs6000 + RS6kBIN = ${SRCDIR}/bin.rs6000 + RS6kLIB = ${SRCDIR}/lib.rs6000 + # This is a list of the machines/architectures that are currently supported. # These are also the names of the necessary makefile fragements. ! MACHINES = APOLLO HP300 HP700 I386 ISC386IX MIPS NeXT PRISM RS6000 SONYNEWS \ ! SPARC SUN3 TITAN VAX # Architecture specific directories and links to the source files are # constructed by the following commands which follow: *************** *** 161,166 **** --- 180,204 ---- forNeXT forNEXT: $(MAKE) "CPU = NeXT" "CPUDIR = ${NeXTDIR}" "SRCDIR = ${SRCDIR}" \ "BINDIR = ${NeXTBIN}" "LIBDIR = ${NeXTLIB}" forCPU + + forRS6000 forRS6k: + $(MAKE) "CPU = RS6000" CPUDIR=${RS6kDIR} "SRCDIR=${SRCDIR}" \ + "BINDIR=${RS6kBIN}" "LIBDIR=${RS6kLIB}" forCPU + + forSONYNEWS: + $(MAKE) "CPU = SONYNEWS" "CPUDIR = ${SONYNEWSDIR}" \ + "SRCDIR = ${SRCDIR}" "BINDIR = ${SONYNEWSBIN}" \ + "LIBDIR = ${SONYNEWSLIB}" forCPU + + forHP300 forHP9000s300: + $(MAKE) "CPU=HP300" "CPUDIR=${HP300DIR}" \ + "SRCDIR = ${SRCDIR}" "BINDIR=${HP300BIN}" \ + "LIBDIR=${HP300LIB}" forCPU + + forHP700 forHP9000s700: + $(MAKE) "CPU=HP700" "CPUDIR=${HP700DIR}" \ + "SRCDIR=${SRCDIR}" "BINDIR=${HP700BIN}" \ + "LIBDIR=${HP700LIB}" forCPU forI386-inplace: $(MAKE) "CPU = I386" "CPUDIR = /usr/local/src/24mar90" \ *** 1.2 1991/10/24 22:16:56 --- makefile-tail 1992/11/30 16:21:36 *************** *** 2,9 **** # This file is used to make the Scheme->C system for multiple processor types. # #SRCDIR = /usrwrl/Gen/src/schemetoc ! SRCDIR = $${PWD:=`pwd`} MIPSDIR = /wrl/pmax/src/schemetoc MIPSBIN = /wrl/pmax/bin --- 2,11 ---- # This file is used to make the Scheme->C system for multiple processor types. # + SHELL=/bin/sh + #SRCDIR = /usrwrl/Gen/src/schemetoc ! SRCDIR = $${PWD=`pwd`} MIPSDIR = /wrl/pmax/src/schemetoc MIPSBIN = /wrl/pmax/bin *************** *** 41,49 **** NeXTBIN = /usr/local/bin NeXTLIB = /usr/local/lib # 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 ISC386IX MIPS NeXT PRISM SPARC SUN3 TITAN VAX # Architecture specific directories and links to the source files are # constructed by the following commands which follow: --- 43,68 ---- NeXTBIN = /usr/local/bin NeXTLIB = /usr/local/lib + SONYNEWSDIR = ${SRCDIR}/news_mips + SONYNEWSBIN = /usr/local/bin + SONYNEWSLIB = /usr/local/lib + + HP300DIR = ${SRCDIR}/hp300 + HP300BIN = ${SRCDIR}/bin.hp300 + HP300LIB = ${SRCDIR}/lib.hp300 + + HP700DIR = ${SRCDIR}/hp700 + HP700BIN = ${SRCDIR}/bin.hp700 + HP700LIB = ${SRCDIR}/lib.hp700 + + RS6kDIR = ${SRCDIR}/rs6000 + RS6kBIN = ${SRCDIR}/bin.rs6000 + RS6kLIB = ${SRCDIR}/lib.rs6000 + # This is a list of the machines/architectures that are currently supported. # These are also the names of the necessary makefile fragements. ! MACHINES = APOLLO HP300 HP700 I386 ISC386IX MIPS NeXT PRISM RS6000 SONYNEWS \ ! SPARC SUN3 TITAN VAX # Architecture specific directories and links to the source files are # constructed by the following commands which follow: *************** *** 161,166 **** --- 180,204 ---- forNeXT forNEXT: $(MAKE) "CPU = NeXT" "CPUDIR = ${NeXTDIR}" "SRCDIR = ${SRCDIR}" \ "BINDIR = ${NeXTBIN}" "LIBDIR = ${NeXTLIB}" forCPU + + forRS6000 forRS6k: + $(MAKE) "CPU = RS6000" CPUDIR=${RS6kDIR} "SRCDIR=${SRCDIR}" \ + "BINDIR=${RS6kBIN}" "LIBDIR=${RS6kLIB}" forCPU + + forSONYNEWS: + $(MAKE) "CPU = SONYNEWS" "CPUDIR = ${SONYNEWSDIR}" \ + "SRCDIR = ${SRCDIR}" "BINDIR = ${SONYNEWSBIN}" \ + "LIBDIR = ${SONYNEWSLIB}" forCPU + + forHP300 forHP9000s300: + $(MAKE) "CPU=HP300" "CPUDIR=${HP300DIR}" \ + "SCRDIR = ${SRCDIR}" "BINDIR=${HP300BIN}" \ + "LIBDIR=${HP300LIB}" forCPU + + forHP700 forHP9000s700: + $(MAKE) "CPU=HP700" "CPUDIR=${HP700DIR}" \ + "SCRDIR = ${SRCDIR}" "BINDIR=${HP700BIN}" \ + "LIBDIR=${HP700LIB}" forCPU forI386-inplace: $(MAKE) "CPU = I386" "CPUDIR = /usr/local/src/24mar90" \ *** /dev/null Mon Nov 30 15:31:06 1992 --- contrib/mcc-c-interface-test.sc Wed Jan 8 07:14:23 1992 *************** *** 0 **** --- 1,56 ---- + + ;; this module implements access to some unix directory functions, and + ;; provides a directory procedure. + + (module mcc-c-interface-test) + + (include "mcc-c-interface.sc") + + (typedef (char 255) dir-name) + + (typedef (struct + (unsigned d-off) + (unsigned d-fileno) + (shortunsigned d-reclen) + (shortunsigned d-namlen) + (dir-name d-name)) + direct ) + + (typedef (direct *) directp) + + (make-typedef) ;; instantiates accessor functions for data types + + + ;;--------------------------------------------------- unix directory functions + + (extern unsigned "opendir" + (pointer dstream) ) + + (extern directp "readdir" + (pointer dstream) ) + + (extern void "closedir" + (pointer dstream) ) + + + ;;------------------------------------------------------------------ directory + (define (directory path) + + ;; return list of file names given a directory path. + + (if (not (string? path)) + (error 'directory "directory path is not a string: ~s" path) ) + (let ((d (opendir path))) + (if (zero? d) + '() + (let loop ((entry (readdir d)) + (names '()) ) + (if (zero? (opaque-body entry)) + names + (let* ((len (direct-d-namlen entry)) + (name (make-string len)) ) + (do ((i 0 (+ i 1))) + ((>= i len)) + (string-set! name i (integer->char (direct-d-name entry i))) ) + (loop (readdir d) (cons name names)))))))) + *** /dev/null Mon Nov 30 15:31:08 1992 --- contrib/mcc-c-interface.sc Fri Nov 20 15:01:08 1992 *************** *** 0 **** --- 1,1018 ---- + + ;;; C Declaration Language + + ;* Copyright 1989 Digital Equipment Corporation + ;* All Rights Reserved + ;* + ;* Permission to use, copy, and modify this software and its documentation is + ;* hereby granted only under the following terms and conditions. Both the + ;* above copyright notice and this permission notice must appear in all copies + ;* of the software, derivative works or modified versions, and any portions + ;* thereof, and both notices must appear in supporting documentation. + ;* + ;* Users of this software agree to the terms and conditions set forth herein, + ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free + ;* right and license under any changes, enhancements or extensions made to the + ;* core functions of the software, including but not limited to those affording + ;* compatibility with other hardware or software environments, but excluding + ;* applications which incorporate this software. Users further agree to use + ;* their best efforts to return to Digital any such changes, enhancements or + ;* extensions that they make and inform Digital of noteworthy uses of this + ;* software. Correspondence should be provided to Digital at: + ;* + ;* Director of Licensing + ;* Western Research Laboratory + ;* Digital Equipment Corporation + ;* 100 Hamilton Avenue + ;* Palo Alto, California 94301 + ;* + ;* This software may be distributed (but not offered for sale or transferred + ;* for compensation) to third parties, provided such third parties agree to + ;* abide by the terms and conditions of this notice. + ;* + ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL + ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF + ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT + ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL + ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR + ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS + ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS + ;* SOFTWARE. + + ;; Now, to cover MCC's liability... + ;/* + ; * Copyright (c) 1991 + ; * Microelectronics and Computer Technology Corporation (MCC) + ; * All rights reserved. + ; * + ; * Use and copying of this software and preparation of derivative works + ; * based upon this software are permitted. However, any distribution of + ; * this software or derivative works must include the above copyright + ; * notice. + ; * + ; * This software is made available AS IS, and the MCC makes no + ; * warranty about the software, its performance or its conformity to + ; * any specification. + ; * + ; */ + + ;;; This module compiles type declarations. + ;;; + ;;; Data types are defined by this type of expression. Initially, we'll + ;;; try to accept as few forms as possible by doing a little "hand casting". + ;;; The legal forms are: + ;;; + ;;; (typedef ) + ;;; + ;;; where: + ;;; + ;;; ::= ( *) + ;;; ( *proc) + ;;; + ;;; ::= ( integer) + ;;; + ;;; + ;;; + ;;; ::= char + ;;; shortint + ;;; shortunsigned + ;;; int + ;;; unsigned + ;;; float + ;;; double + ;;; + ;;; + ;;; ::= denoting another type + ;;; + ;;; ::= ( struct [ ...] ) + ;;; ( union [ ...] ) + ;;; + ;;; ::= ( ) + ;;; + ;;; ::= ( enum [ ...] ) + ;;; + ;;; ::= | ( [0-9]+ ) + + + ;; *** Example of typedef and extern usage in a compiled source file: *** + + ;;======================================================================== + ;; this module implements access to some unix directory functions, and + ;; provides a directory procedure. + ; + ; (module dir-ops) + ; + ; (include "mcc-c-interface.sc") + ; + ; (typedef (char 255) dir-name) + ; + ; (typedef (struct + ; (unsigned d-off) + ; (unsigned d-fileno) + ; (shortunsigned d-reclen) + ; (shortunsigned d-namlen) + ; (dir-name d-name)) + ; direct ) + ; + ; (typedef (direct *) directp) + ; + ; (make-typedef) ;; instantiates accessor functions for data types + ; + ; + ; ;;--------------------------------------------------- unix directory functions + ; + ; (extern unsigned "opendir" + ; (pointer dstream) ) + ; + ; (extern directp "readdir" + ; (pointer dstream) ) + ; + ; (extern void "closedir" + ; (pointer dstream) ) + ; + ; + ; ;;------------------------------------------------------------------ directory + ; (define (directory path) + ; + ; ;; return list of file names given a directory path. + ; + ; (if (not (string? path)) + ; (error 'directory "directory path is not a string: ~s" path) ) + ; (let ((d (opendir path))) + ; (if (zero? d) + ; '() + ; (let loop ((entry (readdir d)) + ; (names '()) ) + ; (if (zero? (opaque-body entry)) + ; names + ; (let* ((len (direct-d-namlen entry)) + ; (name (make-string len)) ) + ; (do ((i 0 (+ i 1))) + ; ((>= i len)) + ; (string-set! name i (integer->char (direct-d-name entry i))) ) + ; (loop (readdir d) (cons name names)))))))) + ; + ; + ;;======================================================================== + + + ;; *** Example of enum usage: *** + + ;;======================================================================== + ; (module dir-ops) + ; + ; (include "mcc-c-interface.sc") + ; + ; (typedef (enum (ebadf 9) (epipe 29) (efbig 27) (efault 14)) write-return) + ; + ; (extern write-return "write" + ; (integer descriptor) (pointer buf) (integer nbytes)) + ; + ; (define unix-write (s d) + ; (let* ((len (string->length s)) + ; (status (write d s len)) ) + ; (if (= status len) + ; len + ; (error 'unix-write "error on write: ~a" + ; (enum->symbol write-return status) )))) + ; + ;;======================================================================== + + + + + ;;------------------------------ The following are all compile-time procedures + + (eval-when (compile eval) + + + (define *cdecl-types* '()) + (define *cdecl-procedures* '()) + + (define (push-procedure p) + (set! *cdecl-procedures* (cons p *cdecl-procedures*)) ) + + + ;;; Type declarations are parsed by the following function. It will return + ;;; the type definition, or call error on an error. Some of these type + ;;; transformations may be MACHINE DEPENDENT. + + (define (PARSE-TYPE type) + (if (pair? type) + (cond ((memq (car type) '(struct union)) + (struct-or-union type)) + ((eq? (car type) 'enum) + type) + ((equal? (cdr type) '(*)) + (list (parse-stype (car type)) '*)) + ((equal? (cdr type) '(*proc)) + (list (parse-stype (car type)) '*proc)) + (else (parse-atype type))) + (parse-stype type))) + + (define (PARSE-ATYPE type) + (if (pair? type) + (cond ((memq (car type) '(struct union)) + (struct-or-union type)) + ((and (= (length type) 2) + (integer? (cadr type)) (>= (cadr type) 0)) + (list (parse-stype (car type)) (cadr type))) + (else (error 'parse-atype "Argument is not a legal type: ~s" + type))) + (parse-stype type))) + + (define (PARSE-STYPE type) + (if (symbol? type) + type + (error 'parse-stype "Argument is not a legal type: ~s" type))) + + + ;;; Structs and unions are handled by the following functions. + + (define (STRUCT-OR-UNION exp) + (list (case (car exp) + ((struct) 'struct) + ((union) 'union) + (else (error 'struct-or-union "Illegal syntax: ~s" exp))) + (map (lambda (slot) + (if (and (= (length slot) 2) (symbol? (cadr slot))) + (list (parse-slot-type (car slot)) (cadr slot)) + (error 'struct-or-union + "Argument is not a legal slot: ~s" slot))) + (cdr exp)))) + + + ;;; When the type specifier for a slot is parsed, it may be contain an + ;;; array or structure definition, or a symbol. Arrays and structures + ;;; defined here must have a dummy type assigned to them. + + (define PARSE-SLOT-TYPE + (let ((uid 1)) + (lambda (type) + (let ((parse (parse-atype type))) + (if (symbol? parse) + parse + (let ((symbol + (string->symbol (format "*TYPE~s" uid)))) + (set! uid (+ uid 1)) + (putprop symbol '*cdecl-base-type* #f) + (putprop symbol '*cdecl-type* parse) + symbol)))))) + + + (define (identity x) x) + + ;;; The base types recognized by the type system are known to C and have + ;;; known bytes sizes WHICH MAY BE MACHINE DEPENDENT. + + (for-each + (lambda (x) + (let ((type (list-ref x 0)) + (size (list-ref x 1)) + (to-ref (list-ref x 2)) + (to-set! (list-ref x 3))) + (putprop type '*cdecl-type* #t) + (putprop type '*cdecl-base-type* type) + (putprop type '*cdecl-size* size) + (putprop type '*cdecl-to-get* to-ref) + (putprop type '*cdecl-to-set!* to-set!))) + + ; C type size to access to set! + + '((char 1 c-byte-ref c-byte-set!) + (shortint 2 c-shortint-ref c-shortint-set!) + (shortunsigned 2 c-shortunsigned-ref c-shortunsigned-set!) + (int 4 c-int-ref c-int-set!) + (unsigned 4 c-unsigned-ref c-unsigned-set!) + (pointer 4 c-unsigned-ref c-unsigned-set!) + (procedure 4 c-unsigned-ref c-unsigned-set!) + (float 4 c-float-ref c-float-set!) + (double 8 c-double-ref c-double-set!) + (tscp 4 c-tscp-ref c-tscp-set!))) + + + ;;; Every type symbol can be resolved into a base type symbol by the following + ;;; function. Once a base type has been computed, it is saved on the + ;;; property list. + + (define (BASE-TYPE start-type) + (or (getprop start-type '*cdecl-base-type*) + (let loop ((type start-type) (count 20)) + (let ((typeinfo (getprop type '*cdecl-type*))) + (if (or (not typeinfo) (eq? count 0)) + (error 'base-type "BASE TYPE cannot be resolved: ~s" + start-type)) + (if (symbol? typeinfo) + (loop typeinfo (- count 1)) + (putprop start-type '*cdecl-base-type* type)))))) + + + ;;; Basic information about a type is returned by: + + (define (ISA-UNION? type) + (let ((typeinfo (getprop (base-type type) '*cdecl-type*))) + (and (pair? typeinfo) (eq? (car typeinfo) 'union)))) + + (define (ISA-STRUCT? type) + (let ((typeinfo (getprop (base-type type) '*cdecl-type*))) + (and (pair? typeinfo) (eq? (car typeinfo) 'struct)))) + + (define (UORS-SLOTS type) (cadr (getprop (base-type type) '*cdecl-type*))) + + (define (ISA-PROCP? type) + (let ((typeinfo (getprop (base-type type) '*cdecl-type*))) + (and (pair? typeinfo) (eq? (cadr typeinfo) '*proc)))) + + (define (PROCP-RETURNS type) + (base-type (car (getprop (base-type type) '*cdecl-type*)))) + + (define (ISA-POINTER? type) + (let ((typeinfo (getprop (base-type type) '*cdecl-type*))) + (and (pair? typeinfo) (eq? (cadr typeinfo) '*)))) + + (define (POINTER-TO type) + (base-type (car (getprop (base-type type) '*cdecl-type*)))) + + (define (ISA-ARRAY? type) + (let ((typeinfo (getprop (base-type type) '*cdecl-type*))) + (and (pair? typeinfo) (number? (cadr typeinfo))))) + + (define (ARRAY-SIZE type) (cadr (getprop (base-type type) '*cdecl-type*))) + + (define (ARRAY-TYPE type) (base-type (car (getprop (base-type type) '*cdecl-type*)))) + + (define (POINTED-TO-BY type) + (base-type (getprop (base-type type) 'pointed-to-by))) + + + ;;; enum "stuff" + + (define (EMIT-ENUM-FORMS type) + (when (isa-enum? type) + (for-each + (lambda (var) + (push-procedure `(define-enum ,var ,type))) + (reverse (cdr (getprop type '*cdecl-type*)))) + ;; push this on the list *last* so it will actually be first! + (push-procedure `(define ,type '())))) + + (define (ISA-ENUM? type) + (let ((cdecl-type (getprop type '*cdecl-type*))) + (and (pair? cdecl-type) (eq? (car cdecl-type)'enum)))) + + (define (CANONICALIZE-ENUM type type-list accessor) + (and (string? type) (set! type (string->symbol type))) + (cond + ((integer? type) + (let ((val (assq type type-list))) + (when val + (accessor val)))) + ((symbol? type) + (do ((rem type-list (cdr rem)) + (match? #f)) + ((or match? (not rem)) + (when match? + (accessor match?))) + (when (eq? type (cdar rem)) + (set! match? (car rem))))) + (else + #f))) + + ;;; + ;;; This function (ENUM->SYMBOL) is especially useful for + ;;; comprehending an ENUM return value. + ;;; + (define (ENUM->SYMBOL type-list type) + (canonicalize-enum type type-list cdr)) + + (define (ENUM->INT type-list type) + (canonicalize-enum type type-list car)) + + (define (CHK-ENUM type-list type-list-symbol type) + (or (enum->int type-list type) + (error 'chk-enum "Argument is invalid ~s enumeration: ~s" + type type-list-symbol))) + + (define (next-enum type-list) + (if type-list (+ (caar type-list) 1) 0)) + + + + ;;; Given this information, we can now compute sizes of things. There may + ;;; be future MACHINE DEPENDENT problems here as we aren't worrying about + ;;; alignment. + + (define (SIZE-OF type) + + (define (SIZE-OF-SU slots func) + (let ((size 0)) + (for-each + (lambda (slot) + (set! size (func size (size-of (car slot))))) + slots) + size)) + + (cond ((getprop (base-type type) '*cdecl-size*)) + ((isa-enum? type) (size-of 'int)) + ((isa-union? type) (size-of-su (uors-slots type) max)) + ((isa-struct? type) (size-of-su (uors-slots type) +)) + ((isa-procp? type) (size-of 'procedure)) + ((isa-pointer? type) (size-of 'pointer)) + ((isa-array? type) (* (array-size type) (size-of (array-type type)))) + (else (error 'size-of "Mystery type: ~s" type)))) + + + ;;; A method for loading a type which takes an object, an offset, and an + ;;; index (only for arrays) as it's arguments is returned by the following + ;;; function. + + (define (TO-GET-TYPE type) + (let ((base (base-type type))) + (cond ((getprop base '*cdecl-to-get*)) + ((isa-enum? base) + `(lambda (x y) + (chk-enum ,base ',base (,(to-get-type 'int) x y)))) + ((isa-array? base) + `(lambda (x y i) + (,(to-get-type (array-type base)) x + (+ y (* ,(size-of (array-type base)) i))))) + ((isa-pointer? base) + `(lambda (x y) + (make-opaque-object ',base + (,(to-get-type 'pointer) x y)))) + ((isa-procp? base) + `(lambda (x y) + (make-opaque-object ',base + (,(to-get-type 'pointer) x y)))) + (else #f)))) + + + ;;; A method for storing a type which takes an object, an offset, an index + ;;; (only for arrays), and a new value as it's arguments is returned by the + ;;; following function. + + (define (TO-SET!-TYPE type) + (let ((base (base-type type))) + (cond ((getprop base '*cdecl-to-set!*)) + ((isa-enum? base) + `(lambda (x y z) + (,(to-set!-type 'int) x y (chk-enum ,base ',base z)))) + ((isa-array? base) + `(lambda (x y i z) + (,(to-set!-type (array-type base)) x + (+ y (* ,(size-of (array-type base)) i)) + ;;; this is a bug!: (,(to-check-type (array-type base)) z)))) + ;;; it should be this: (I think) Kevin + z))) + ((isa-pointer? base) + `(lambda (x y z) + (,(to-set!-type 'pointer) x y + (,(to-check-type base) z)))) + ((isa-procp? base) + `(lambda (x y z) + (,(to-set!-type 'pointer) x y + (,(to-check-type base) z)))) + (else #f)))) + + + ;;; A method for checking a type and returning the "raw" value which takes an + ;;; object as it's argument is returned by the following function. + + (define (TO-CHECK-TYPE type) + (let ((base (base-type type))) + (if (or (isa-pointer? base) (isa-procp? base)) + (uis "CHK-" base) + '(lambda (x) x)))) + + + ;;; The symbol that is used as the type tag for objects is returned by the + ;;; following procedure. It returns #f when there is no type tag. + + (define (TYPE-TAG type) + (let ((base (base-type type))) + (if (or (isa-pointer? base) (isa-procp? base)) + base + #f))) + + + ;;; Converts a list of strings or symbols into an upper-case interned symbol. + + (define (UIS . syms) + (string->symbol + (list->string + (let loop ((syms syms)) + (if syms + (append (map char-upcase + (string->list + (if (symbol? (car syms)) + (symbol->string (car syms)) + (car syms)))) + (loop (cdr syms))) + '()))))) + + + ;;; Scheme code for type definitions is emitted by the following procedure + ;;; which is called with a list of all type names, a list of definition + ;;; only types, and a list of read-only types, and the filename/modulename + ;;; prefix. + + (define (EMIT-TYPEDEFS types define-only read-only) + (define (EMIT-TYPE type read-only) + (cond ((isa-enum? type) + (emit-enum-forms type)) + ((isa-pointer? type) + (emit-chk-procs type def-print) + (cond ((or (isa-union? (pointer-to type)) + (isa-struct? (pointer-to type))) + (emit-struct-procs type read-only) ) + ((isa-array? (pointer-to type)) + (emit-array-procs type read-only def-print)))) + ((isa-procp? type) + (emit-chk-procs type def-print)))) + + (define (DEF-PRINT exp) + (format "defining ~S~%" exp) + (eval exp) ) + + (for-each + (lambda (type) + (unless (or (memq type define-only) + (not (eq? type (base-type type)))) + (emit-type type (memq type read-only)))) + types)) + + + ;;; Checking functions for procedure pointer types are emitted by the + ;;; following procedure. The arguments are the object type and the procedure + ;;; to print the definitions. + + (define (EMIT-CHK-PROCS type def-print) + (push-procedure `(define (,(uis "CHK-" (type-tag type)) x) + (if (and (opaque? x) + (eq? (opaque-type x) ',(type-tag type))) + (opaque-body x) + (error ',(uis "CHK-" (type-tag type)) + "Argument is incorrect type: ~s" x)))) + (push-procedure `(define (,(uis "ISA-" (type-tag type) "?") x) + (and (opaque? x) + (eq? (opaque-type x) ',(type-tag type)))))) + + + + ;;; Access functions for array types are generated by the following procedure. + ;;; The arguments are the object type, a read-only flag, and the function to + ;;; print the definitions. + + (define (EMIT-ARRAY-PROCS pointer read-only def-print) + (let* ((type (pointer-to pointer)) + (size (array-size type)) + (entry-type (array-type type)) + (chk (to-check-type pointer))) + (push-procedure `(define (,(uis type "-LENGTH") x) + (quotient (string-length (,chk x)) + ,(size-of entry-type)))) + (cond ((or (isa-struct? entry-type) (isa-union? entry-type)) + (push-procedure + `(define (,(uis type "->" entry-type "-LIST") x) + (let* ((array (,chk x)) + (asize (string-length array)) + (esize ,(size-of entry-type))) + (let loop ((x 0)) + (if (eq? x asize) + '() + (cons (make-opaque-object + ',(pointed-to-by entry-type) + (substring array x (+ x esize))) + (loop (+ x esize)))))))) + (push-procedure + `(define (,(uis entry-type "-LIST->" type) x) + (make-opaque-object ',pointer + (apply string-append + (map ,(to-check-type + (pointed-to-by + entry-type)) + x)))))) + (else + (push-procedure + `(define (,type x i) + (,(to-get-type type) (,chk x) 0 i))) + (push-procedure + `(define (,(uis type "->" entry-type "-LIST") x) + (let loop ((i 0) + (count (,(uis type "-LENGTH") x))) + (if (eq? i count) + '() + (cons (,type x i) + (loop (+ i 1) count)))))) + (push-procedure + `(define (,(uis entry-type "-LIST->" type) l) + (let loop ((l l) + (i 0) + (a (,(uis "MAKE-" type) + ,@(if (eq? size 0) + '((length l)) + '())))) + (if l + (begin (,(uis type "!") a i (car l)) + (loop (cdr l) (+ i 1) a)) + a)))) + (push-procedure + `(define (,(uis type "!") x i z) + (,(to-set!-type type) (,chk x) 0 i z))) + (push-procedure + `(define (,(uis "MAKE-" type) + ,@(if (eq? size 0) '(x) '())) + (make-opaque-object ',pointer + (make-string + (* ,(size-of entry-type) + ,(if (eq? size 0) 'x size)) + (integer->char 0))))))))) + + + ;;; Create struct definition functions. + + (define (EMIT-STRUCT-PROCS pointer read-only ) + (let* ((type (pointer-to pointer)) + (slots (uors-slots type))) + (if slots + (let* () + (define (DEF-PRINT exp) + (format "defining ~S~%" exp) + (eval exp) ) + + (push-procedure + `(define (,(uis "MAKE-" type)) + (make-opaque-object ',pointer + (make-string + ,(* (quotient + (+ (size-of type) 3) + 4) + 4) + (integer->char 0))))) + (slot-getset type type 0 pointer read-only def-print) )))) + + + ;;; Slot access functions for a structure are created by the following + ;;; function. + + (define (SLOT-GETSET type preamble offset base-type read-only def-print) + + (define (EMIT-PROCS type name offset) + (let ((index (if (isa-array? type) '(i) '()))) + (push-procedure + `(define (,(uis preamble "-" name) x ,@index) + (,(to-get-type type) + (,(to-check-type base-type) x) + ,offset + ,@index))) + (unless read-only + (push-procedure + `(define + (,(uis preamble "-" name "!") x ,@index y) + (,(to-set!-type type) + (,(to-check-type base-type) x) + ,offset + ,@index + y)))))) + + (let loop ((slots (uors-slots type)) (offset offset)) + (if slots + (let* ((slot-type (caar slots)) + (slot-name (cadar slots))) + (cond ((or (isa-union? slot-type) (isa-struct? slot-type)) + (slot-getset slot-type + (uis preamble "-" slot-name) + offset base-type read-only def-print)) + (else (emit-procs slot-type slot-name offset))) + (loop (cdr slots) + (if (isa-union? type) + offset + (+ offset (size-of slot-type)))))))) + + + + + ;;-------------------------------------------------------------------- Externs + + ;;; This module compiles "extern" forms which define C library procedures. + ;;; + ;;; ::= ( EXTERN [ ... ] ) + ;;; + ;;; ::= a Scheme string + ;;; + ;;; ::= ( ) + ;;; ( IN ) + ;;; ( OUT ) + ;;; ( IN_OUT ) + ;;; + ;;; ::= a Scheme symbol + + + (define *cdecl-externs* '()) + + (define (push-extern p) + (set! *cdecl-externs* (cons p *cdecl-externs*)) ) + + + ;;; Parses the argument list and calls error on an error. + + (define (PARSE-ARG exp) + (if (and (pair? exp) + (or (and (= (length exp) 2) + (parse-type (car exp)) + (symbol? (cadr exp))) + (and (= (length exp) 3) + (memq (car exp) '(in out in_out)) + (parse-type (cadr exp)) + (symbol? (caddr exp))))) + #t + (error 'PARSE-ARG "Illegal ARGUMENT syntax: ~s" exp))) + + + ;;; The definition for the interface procedure for an extern is created by + ;;; the following procedure. + + (define (EMIT-EXTERNAL extern defform) + (let ((scheme-proc (if (pair? (caddr extern)) + (car (caddr extern)) + (uis (caddr extern)) )) + (c-external (if (pair? (caddr extern)) + (cadr (caddr extern)) + (caddr extern) )) + (c-proc (if (pair? (caddr extern)) + (uis (car (caddr extern)) "*") + (uis (caddr extern) "*") )) + + (rettype (cadr extern)) + (args (cdddr extern))) + + (define (EMIT-CALL) + `(,c-proc ,@(map (lambda (x) (car (last-pair x))) args))) + + (define (FORMALS args) + (if args + (if (eq? (caar args) 'out) + (formals (cdr args)) + (cons (car (last-pair (car args))) + (formals (cdr args)))) + '())) + + (push-extern `(define-c-external + (,c-proc ,@(map simple-type args)) + ,(simple-type (list rettype 'returned)) + ,c-external)) + (newline) + (push-extern `(,defform (,scheme-proc ,@(formals args)) + (let* (,@(map arg-in args) + (return-value + ,(cond ((eq? rettype 'void) + `(begin ,(emit-call) #f)) + ((eq? rettype 'string) + `(c-string->string ,(emit-call))) + ((eq? rettype 'boolean) + `(not (= ,(emit-call) 0))) + ((isa-enum? rettype) + `(chk-enum ,rettype ',rettype ,(emit-call))) + ((isa-pointer? rettype) + `(make-opaque-object ',(base-type rettype) + ,(emit-call))) + (else (emit-call))))) + ,(let ((out (args-out args))) + (if out + (if (eq? rettype 'void) + (if (= (length out) 1) + (car out) + `(list ,@out)) + `(list return-value ,@out)) + 'return-value))))) + (newline))) + + ;;; Called to do input conversion for arguments. Return an expression + ;;; of th form (). + + (define (ARG-IN arg) + (let* ((flag (if (memq (car arg) '(in out in_out)) + (car arg) + #f)) + (type (if flag (cadr arg) (car arg))) + (var (if flag (caddr arg) (cadr arg)))) + (case flag + ((in) `(,var (in->c ,var))) + ((in_out) `(,var (in_out->c ,var))) + ((out) `(,var (make-string ,(if (eq? type 'string) + 4 + (size-of type))))) + (else (cond ((eq? type 'string) + `(,var (if (string? ,var) + ,var + (error 'chk-string + "Argument is incorrect type: ~s" + ,var)))) + ((eq? type 'boolean) + `(,var (if ,var 1 0))) + ((isa-enum? type) + `(,var (chk-enum ,type ',type ,var))) + ((isa-pointer? type) + `(,var (,(uis "CHK-" (base-type type)) ,var))) + (else `(,var ,var))))))) + + ;;; Return a list of the expressions required to do output conversion after + ;;; an external call. + + (define (ARGS-OUT args) + + (define (ARG-OUT arg) + (let* ((flag (if (memq (car arg) '(in out in_out)) + (car arg) + #f)) + (type (if flag (cadr arg) (car arg))) + (var (if flag (caddr arg) (cadr arg)))) + (case flag + ((in) #f) + ((in_out) `(c->in_out ,var)) + ((out) + (cond ((eq? type 'string) + `(c-string->string (c-unsigned-ref ,var 0))) + ((isa-enum? type) + `(chk-enum ,type ',type (c-int-ref ,var 0))) + ((isa-pointer? type) + `(make-opaque-object ',(base-type type) + (c-unsigned-ref ,var 0))) + ((or (isa-union? type) (isa-struct? type) + (isa-array? type)) + `(make-opaque-object ',(pointed-to-by type) + ,var)) + (else `(,(getprop (base-type type) '*cdecl-to-get*) + ,var 0)))) + (else #f)))) + + (if args + (let ((out (arg-out (car args)))) + (if out + (cons out (args-out (cdr args))) + (args-out (cdr args)))) + '())) + + ;;; Converts the type of a procedure argument to a simple C-type. + + (define (SIMPLE-TYPE type) + (cond ((memq (car type) '(in out in_out string)) 'pointer) + ((eq? (car type) 'boolean) 'int) + ((eq? (car type) 'void) 'void) + ((isa-enum? (car type)) 'int) + ((isa-pointer? (car type)) 'pointer) + ((isa-procp? (car type)) 'pointer) + (else (base-type (car type))))) + + + ;; *** Warning, all this stub file stuff is not yet converted!!! + + ;;; The STUBS file is written by the following function. + + (define (EMIT-STUBS externs stubs-file-root) + (with-output-to-file + (string-append stubs-file-root ".sc") + (lambda () + (write `(module ,(uis stubs-file-root))) + (newline) + (for-each emit-stub externs)))) + + ;;; The external definition for a procedure is written by the following + ;;; function. + + (define (EMIT-DEFINE-EXTERNAL extern module) + (let ((formals (let loop ((args (cdddr extern)) + (formals '(a b c d e f g h i j k l m + n o p q r s t u v w x y z))) + (cond ((null? args) '()) + ((eq? (caar args) 'out) + (loop (cdr args) (cdr formals))) + (else (cons (car formals) + (loop (cdr args) (cdr formals)))))))) + + (push-extern `(define-external (,(uis (caddr extern)) ,@formals) ,module)) + (newline))) + + ;;; The definition for a stub procedure is written by the following function. + + (define (EMIT-STUB extern) + (let* ((c-name (uis (caddr extern) "**")) + (stub-name (uis (caddr extern) "*")) + (rettype (cadr extern)) + (args (cdddr extern)) + (formals (let loop ((args args) + (formals '(a b c d e f g h i j k l m + n o p q r s t u v w x y z))) + (if (not (null? args)) + (cons (car formals) + (loop (cdr args) (cdr formals))) + '())))) + + (push-extern `(define-c-external + (,c-name ,@(map simple-type args)) + ,(simple-type (list rettype 'returned)) + ,(caddr extern))) + (newline) + (push-extern `(define (,stub-name ,@formals) + (,c-name ,@formals) + ,@(if (eq? rettype 'void) '(#f) '()))) + (newline))) + + + );; end eval-when + + + ;====================================================================== macros + + + ;;---------------------------------------------------------------- define-enum + ;;; + ;;; DEFINE-ENUM is a utility function that is used for defining + ;;; variables that are additionally maintained in a specified alist. + ;;; (The ENUM canonicalization functions, ENUM->SYMBOL and ENUM->INT + ;;; functions (above) may be used to canonicalize a symbol, string, or + ;;; value (typically integer) reference into a symbol or integer + ;;; representation, respectively. The ENUM->SYMBOL function is + ;;; especially useful for comprehending an ENUM return value.) + ;;; + (define-macro DEFINE-ENUM + (lambda (form expander) + (expander + (let* ((variable-name (cadr form)) + (list-name (caddr form)) + (variable-value (if (pair? variable-name) + (let ((val (cadr variable-name))) + (set! variable-name (car variable-name)) + val) + ;; otherwise, find a "suitable" value + `(next-enum ,list-name)))) + `(define ,variable-name + (let ((initial-value ,variable-value)) + (set! ,list-name (cons (cons initial-value ',variable-name) + ,list-name)) + initial-value))) + expander))) + + ;;-------------------------------------------------------------------- typedef + + (define-macro + TYPEDEF + (lambda (exp e) + (if (and (= (length exp) 3) (symbol? (caddr exp))) + (let ((id (caddr exp)) + (parse (parse-type (cadr exp)))) + (putprop id '*cdecl-base-type* #f) + (putprop id '*cdecl-type* parse) + (if (and (pair? parse) (symbol? (car parse)) + (eq? (cadr parse) '*)) + (putprop (car parse) 'pointed-to-by id)) + (set! *cdecl-types* (cons id *cdecl-types*)) + #t ) + (error 'typedef "Illegal syntax: ~s" exp)))) + + + ;;------------------------------------------------------------- clear-typedefs + + (define-macro + CLEAR-TYPEDEFS + (lambda (exp e) + (set! *cdecl-types* '()) + (set! *cdecl-procedures* '()) + #t)) + + + + ;;--------------------------------------------------------------- make-typedef + + (define-macro + MAKE-TYPEDEF + (lambda (exp e) + (let ((id-list (if (> (length exp) 1) + (cdr exp) + (reverse *cdecl-types*) ))) + (set! *cdecl-procedures* '()) + (emit-typedefs id-list '() '()) + (e `(begin ,@*cdecl-procedures* #t) + e )))) + + + ;;--------------------------------------------------------------------- extern + + (define-macro + EXTERN + (lambda (exp e) + (if (and (>= (length exp) 3) + (parse-type (cadr exp)) + (or (and (pair? (caddr exp)) + (symbol? (car (caddr exp))) + (string? (cadr (caddr exp))) ) + (string? (caddr exp)) )) + (begin + (set! *cdecl-externs* '()) + (if (> (length exp) 3) + (for-each parse-arg (cdddr exp))) + (emit-external exp 'define) + (e `(begin ,@(reverse *cdecl-externs*) #t) + e )) + (error 'extern "Illegal EXTERN syntax: ~s" exp)))) + *** /dev/null Mon Nov 30 15:31:10 1992 --- contrib/mcc-sos-test.sc Fri Nov 20 15:01:56 1992 *************** *** 0 **** --- 1,87 ---- + + (module mcc-sos-test) + + (include "mcc-sos.sch") + + ;;------------------------------------------------------------------ my-vector + + (declare-class my-vector + + (class-data (vectors '())) + + (data + (v #f) + (sz 0) ) + + (methods + (vsize () sz) + (vref (i) (vector-ref v i)) + (vset! (i val) (vector-set! v i val)) ) + + (constructor + (size) () + (cond ((> size 0) + (set! v (make-vector size)) + (set! sz size) + (set! vectors (cons v vectors)) ) + (else + (error 'make-vector "Size must be positive") ))) + + (destructor + () () + (set! sz 0) + (set! v #f) ) + ) + + ;;--------------------------------------------------------------------- my-vec + + (declare-class my-vec + + (parent my-vector) + + (data + (hi 0 my-vec-hi-index) + (lo 0 my-vec-lo-index) ) + + (methods + (check-range (i) (if (or (< i lo) (> i hi) ) + (error 'my-vec "index out of range") + (- i lo) )) + (show-vectors () vectors) + (vref (i) (vector-ref v (send self check-range i))) + (vset! (i val) (vector-set! v (send self check-range i) val)) ) + + (constructor + (low high) + ((+ 1 (abs (- high low)))) ;calculate size for parent + (set! lo (min low high)) + (set! hi (max low high)) ) + ) + + (declare-method show-all my-vec () (list vectors sz v)) + + ;; instantiate classes + (define-class my-vec my-vector) + + + (define (test-sos) + ;;----------------------------------------------------------- test constuctors + (list + (set! y (make-my-vector 10)) + (set! x (make-my-vec 4 10)) + + + ;;---------------------------------------------------------- test method calls + (send y vset! 4 "hi") + (send y vref 4) + (send x vset! 4 "hi") + (send x vref 4) + (send x my-vec-hi-index) + (send x my-vec-lo-index) + + + ;;------------------------------------ test declare-method and class variables + (send x show-all) + (send x show-vectors) + )) + *** /dev/null Mon Nov 30 15:31:11 1992 --- contrib/mcc-sos.doc Fri Nov 20 15:01:58 1992 *************** *** 0 **** --- 1,411 ---- + ;/* + ; * Copyright (c) 1991 + ; * Microelectronics and Computer Technology Corporation (MCC) + ; * All rights reserved. + ; * + ; * Use and copying of this software and preparation of derivative works + ; * based upon this software are permitted. However, any distribution of + ; * this software or derivative works must include the above copyright + ; * notice. + ; * + ; * This software is made available AS IS, and the MCC makes no + ; * warranty about the software, its performance or its conformity to + ; * any specification. + ; * + ; */ + + + MCC SOS - Scheme Object System + ========================== + + The Scheme Object System is a fairly conventional (!) single-inheritance + object system. It uses data slots, methods, constructors, destructors, and + accessors. + + The syntax of a class declaration is: + + (declare-class + [(parent )] + [(data ( []) ... )] + [(class-data ( []) ... )] + [(methods ( ( ...) ) ...)] + [(constructor ( ...) ( ...) )] + [(destructor ( ...) ( ...) )] + ) + + In the data or class-data slots, may be a symbol like + 'foo', in which case the reader is called 'foo' and the writer 'foo!'. + Keywords can also be used to specify seperate reader and writer + functions: + + ... (data (x 0 reader get-x writer put-x) + (y 0 reader get-y) ) ... + + In this case, no writer function is generated for y. + + The sections of the declaration can be in any order, and all are + optional (although at least ONE must appear). This is a DECLARATION, + not a definition. That is, you can put a bunch of these declarations + in an "include" file just like C declarations. A class is DEFINED by: + + (define-class ...) + + This actually generates code for the class operations. Classes may be + DEFINED in any order, provided they and all of their parent classes + have been DECLARED. The following examples shall be used to + illustrate: + + (declare-class my-vector + (class-data + (vectors '())) + (data (v #f) + (sz 0) ) + (methods (vsize () sz) + (vref (i) (vector-ref v i)) + (vset! (i val) (vector-set! v i val)) ) + (constructor (size) () + (cond ((> size 0) + (set! v (make-vector size)) + (set! vectors (cons v vectors)) + (set! sz size) ) + (else + (error 'make-vector "Size must be positive") ))) + (destructor () () + (set! sz 0) + (set! v #f) ) + ) + + (define-class my-vector) + + Now, you would use such a class like: + + >(set! x (make-my-vector 10)) + #(1 #(() () () () () () () () () ()) 10) + >(send x vsize) + 10 + >(send x vset! 9 "hi") + "hi" + >(send x vref 9) + "hi" + + Ok so far? Alright, now we'll derive a vector class with specifiable index + limits, such as a vector indexed 5 to 10, for example. + + (declare-class my-vec + (parent my-vector) + (data (hi 0 my-vec-hi-index) + (lo 0 my-vec-lo-index) ) + (methods (check-range (i) (if (or (< i lo) (> i hi) ) + (error 'my-vec "index out of range") + (- i lo) )) + (vref (i) (vector-ref v (send self check-range i))) + (vset! (i val) (vector-set! v (send self check-range i) val)) ) + (constructor (low high) + ((+ 1 (abs (- high low)))) ;calculate size for parent + (set! lo (min low high)) + (set! hi (max low high)) ) + ) + + (define-class my-vec) + + Now, we've derived a new class from my-vector, and added the HI and LO + data slots. Unlike the parent class data slots, these slots have + accessors which allow their direct access by non-methods. For example, + if X is a MY-VEC object, the HI slot can be read by: + + (send x my-vec-hi-index) + + and written by: + + (send x my-vec-hi-index! 3) + + (Of course, this is not a good idea in this particular case!) One can + also specify reader and writer function using the reader/writer + keywords. Now, we also added a method CHECK-RANGE, and re-defined VREF + and VSET! to check the range of the specified index. We had the + MY-VEC constructor calculate and pass the vector size to the + constructor of the parent class (who actually allocates the vector + space), and the constructor also sets the HI and LO fields. We would + use it like: + + (set! x (make-my-vec 5 10)) + #(2 #(() () () () () ()) 6 10 5) + > (send x vset! 11 "hi") + ***** MY-VEC index out of range + (ERROR 'MY-VEC "index out of range") in ENV-0 + (VECTOR-SET! (VECTOR-REF SELF 1) ((SOS-GENERIC-DISPATCHER CHECK-R ... in ENV-1 + (EVAL ...) + (SCREP_REP ...) + (READ-EVAL-PRINT ...) + >> + > (send x vset! 10 "hi") + "hi" + > (send x vref 10) + "hi" + > + + Classes can be re-defined on the fly. If data slots change, all + derived class types must also be re-defined and object instances + re-made. However, methods can be changed or added without + disturbing the rest of the definitions OR existing object instances. + This should provide fairly convenient interactive class development. + + An inherited method can be invoked from within a method by: + + (inherited-method foo 2 3 4) + + This guarantees that the selected foo method will come from a parent + class. + + Let's define a new method for my-vector which shows us the value of + the 'vectors' class variable: + + (declare-method show-vectors my-vec () vectors) + + (define-class my-vector) + + Now we can say (using the existing object x!) + + (send x show-vectors) + + and get: + + (#(() () () () () () () () () "hi") #(() () () () () "hi")) + + The DECLARE-METHOD macro is considered an addendum to the class + declaration, and so must appear after the corresponding DECLARE-CLASS + macro. + + Class variables get re-initilized every time the class is re-defined. + If we had put the 'show-vectors' method on the 'my-vector' class and + then re-defined the class, the value of 'vectors' would have been the + empty list. + + + Various helper functions allow you to peruse the class hierarchy and + definitions. + + (sos-show-method ) + shows the method associated with . is a class name + (symbol) and is a class name or object. + + (sos-get-method ) + like sos-show-method, above, except that it returns the + method definition. + + (sos-get-classes) + returns the list of defined classes. + + (sos-get-inheritance ) + returns class names of the specified class and its parents (in order). + + (sos-get-class-definition ) + returns shows all the methods, data, etc. for the specified class or + object. + + (sos-class-of